{-# LANGUAGE TemplateHaskell #-}

{-| Implementation of the Ganeti LUXI interface.

-}

{-

Copyright (C) 2009, 2010, 2011, 2012 Google Inc.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.

-}

module Ganeti.Luxi
  ( LuxiOp(..)
  , QrViaLuxi(..)
  , ResultStatus(..)
  , LuxiReq(..)
  , Client
  , checkRS
  , getClient
  , closeClient
  , callMethod
  , submitManyJobs
  , queryJobsStatus
  , buildCall
  , validateCall
  , decodeCall
  ) where

import Data.IORef
import Control.Monad
import Text.JSON (encodeStrict, decodeStrict)
import qualified Text.JSON as J
import Text.JSON.Types
import System.Timeout
import qualified Network.Socket as S

import Ganeti.HTools.JSON
import Ganeti.HTools.Types
import Ganeti.HTools.Utils

import Ganeti.Constants
import Ganeti.Jobs (JobStatus)
import Ganeti.OpCodes (OpCode)
import Ganeti.THH

-- * Utility functions

-- | Wrapper over System.Timeout.timeout that fails in the IO monad.
withTimeout :: Int -> String -> IO a -> IO a
withTimeout secs descr action = do
  result <- timeout (secs * 1000000) action
  case result of
    Nothing -> fail $ "Timeout in " ++ descr
    Just v -> return v

-- * Generic protocol functionality

$(declareSADT "QrViaLuxi"
  [ ("QRLock", 'qrLock)
  , ("QRInstance", 'qrInstance)
  , ("QRNode", 'qrNode)
  , ("QRGroup", 'qrGroup)
  , ("QROs", 'qrOs)
  ])
$(makeJSONInstance ''QrViaLuxi)

-- | Currently supported Luxi operations and JSON serialization.
$(genLuxiOp "LuxiOp"
  [(luxiReqQuery,
    [ ("what",    [t| QrViaLuxi |], [| id |])
    , ("fields",  [t| [String]  |], [| id |])
    , ("qfilter", [t| ()        |], [| const JSNull |])
    ])
  , (luxiReqQueryNodes,
     [ ("names",  [t| [String] |], [| id |])
     , ("fields", [t| [String] |], [| id |])
     , ("lock",   [t| Bool     |], [| id |])
     ])
  , (luxiReqQueryGroups,
     [ ("names",  [t| [String] |], [| id |])
     , ("fields", [t| [String] |], [| id |])
     , ("lock",   [t| Bool     |], [| id |])
     ])
  , (luxiReqQueryInstances,
     [ ("names",  [t| [String] |], [| id |])
     , ("fields", [t| [String] |], [| id |])
     , ("lock",   [t| Bool     |], [| id |])
     ])
  , (luxiReqQueryJobs,
     [ ("ids",    [t| [Int]    |], [| map show |])
     , ("fields", [t| [String] |], [| id |])
     ])
  , (luxiReqQueryExports,
     [ ("nodes", [t| [String] |], [| id |])
     , ("lock",  [t| Bool     |], [| id |])
     ])
  , (luxiReqQueryConfigValues,
     [ ("fields", [t| [String] |], [| id |]) ]
    )
  , (luxiReqQueryClusterInfo, [])
  , (luxiReqQueryTags,
     [ ("kind", [t| String |], [| id |])
     , ("name", [t| String |], [| id |])
     ])
  , (luxiReqSubmitJob,
     [ ("job", [t| [OpCode] |], [| id |]) ]
    )
  , (luxiReqSubmitManyJobs,
     [ ("ops", [t| [[OpCode]] |], [| id |]) ]
    )
  , (luxiReqWaitForJobChange,
     [ ("job",      [t| Int     |], [| show |])
     , ("fields",   [t| [String]|], [| id |])
     , ("prev_job", [t| JSValue |], [| id |])
     , ("prev_log", [t| JSValue |], [| id |])
     , ("tmout",    [t| Int     |], [| id |])
     ])
  , (luxiReqArchiveJob,
     [ ("job", [t| Int |], [| show |]) ]
    )
  , (luxiReqAutoArchiveJobs,
     [ ("age",   [t| Int |], [| id |])
     , ("tmout", [t| Int |], [| id |])
     ])
  , (luxiReqCancelJob,
     [ ("job", [t| Int |], [| show |]) ]
    )
  , (luxiReqSetDrainFlag,
     [ ("flag", [t| Bool |], [| id |]) ]
    )
  , (luxiReqSetWatcherPause,
     [ ("duration", [t| Double |], [| id |]) ]
    )
  ])

$(makeJSONInstance ''LuxiReq)

-- | The serialisation of LuxiOps into strings in messages.
$(genStrOfOp ''LuxiOp "strOfOp")

$(declareIADT "ResultStatus"
  [ ("RSNormal", 'rsNormal)
  , ("RSUnknown", 'rsUnknown)
  , ("RSNoData", 'rsNodata)
  , ("RSUnavailable", 'rsUnavail)
  , ("RSOffline", 'rsOffline)
  ])

$(makeJSONInstance ''ResultStatus)

-- | Type holding the initial (unparsed) Luxi call.
data LuxiCall = LuxiCall LuxiReq JSValue

-- | Check that ResultStatus is success or fail with descriptive message.
checkRS :: (Monad m) => ResultStatus -> a -> m a
checkRS RSNormal val    = return val
checkRS RSUnknown _     = fail "Unknown field"
checkRS RSNoData _      = fail "No data for a field"
checkRS RSUnavailable _ = fail "Ganeti reports unavailable data"
checkRS RSOffline _     = fail "Ganeti reports resource as offline"

-- | The end-of-message separator.
eOM :: Char
eOM = '\3'

-- | Valid keys in the requests and responses.
data MsgKeys = Method
             | Args
             | Success
             | Result

-- | The serialisation of MsgKeys into strings in messages.
$(genStrOfKey ''MsgKeys "strOfKey")

-- | Luxi client encapsulation.
data Client = Client { socket :: S.Socket   -- ^ The socket of the client
                     , rbuf :: IORef String -- ^ Already received buffer
                     }

-- | Connects to the master daemon and returns a luxi Client.
getClient :: String -> IO Client
getClient path = do
  s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
  withTimeout connTimeout "creating luxi connection" $
              S.connect s (S.SockAddrUnix path)
  rf <- newIORef ""
  return Client { socket=s, rbuf=rf}

-- | Closes the client socket.
closeClient :: Client -> IO ()
closeClient = S.sClose . socket

-- | Sends a message over a luxi transport.
sendMsg :: Client -> String -> IO ()
sendMsg s buf =
  let _send obuf = do
        sbytes <- withTimeout queryTimeout
                  "sending luxi message" $
                  S.send (socket s) obuf
        unless (sbytes == length obuf) $ _send (drop sbytes obuf)
  in _send (buf ++ [eOM])

-- | Waits for a message over a luxi transport.
recvMsg :: Client -> IO String
recvMsg s = do
  let _recv obuf = do
              nbuf <- withTimeout queryTimeout "reading luxi response" $
                      S.recv (socket s) 4096
              let (msg, remaining) = break (eOM ==) nbuf
              if null remaining
                then _recv (obuf ++ msg)
                else return (obuf ++ msg, tail remaining)
  cbuf <- readIORef $ rbuf s
  let (imsg, ibuf) = break (eOM ==) cbuf
  (msg, nbuf) <-
    if null ibuf      -- if old buffer didn't contain a full message
      then _recv cbuf   -- then we read from network
      else return (imsg, tail ibuf) -- else we return data from our buffer
  writeIORef (rbuf s) nbuf
  return msg

-- | Serialize a request to String.
buildCall :: LuxiOp  -- ^ The method
          -> String  -- ^ The serialized form
buildCall lo =
  let ja = [ (strOfKey Method, JSString $ toJSString $ strOfOp lo::JSValue)
           , (strOfKey Args, opToArgs lo::JSValue)
           ]
      jo = toJSObject ja
  in encodeStrict jo

-- | Check that luxi request contains the required keys and parse it.
validateCall :: String -> Result LuxiCall
validateCall s = do
  arr <- fromJResult "luxi call" $ decodeStrict s::Result (JSObject JSValue)
  let aobj = fromJSObject arr
  call <- fromObj aobj (strOfKey Method)::Result LuxiReq
  args <- fromObj aobj (strOfKey Args)
  return (LuxiCall call args)

-- | Converts Luxi call arguments into a 'LuxiOp' data structure.
--
-- This is currently hand-coded until we make it more uniform so that
-- it can be generated using TH.
decodeCall :: LuxiCall -> Result LuxiOp
decodeCall (LuxiCall call args) =
  case call of
    ReqQueryJobs -> do
              (jid, jargs) <- fromJVal args
              rid <- mapM (tryRead "parsing job ID" . fromJSString) jid
              let rargs = map fromJSString jargs
              return $ QueryJobs rid rargs
    ReqQueryInstances -> do
              (names, fields, locking) <- fromJVal args
              return $ QueryInstances names fields locking
    ReqQueryNodes -> do
              (names, fields, locking) <- fromJVal args
              return $ QueryNodes names fields locking
    ReqQueryGroups -> do
              (names, fields, locking) <- fromJVal args
              return $ QueryGroups names fields locking
    ReqQueryClusterInfo -> do
              return QueryClusterInfo
    ReqQuery -> do
              (what, fields, _) <-
                fromJVal args::Result (QrViaLuxi, [String], JSValue)
              return $ Query what fields ()
    ReqSubmitJob -> do
              [ops1] <- fromJVal args
              ops2 <- mapM (fromJResult (luxiReqToRaw call) . J.readJSON) ops1
              return $ SubmitJob ops2
    ReqSubmitManyJobs -> do
              [ops1] <- fromJVal args
              ops2 <- mapM (fromJResult (luxiReqToRaw call) . J.readJSON) ops1
              return $ SubmitManyJobs ops2
    ReqWaitForJobChange -> do
              (jid, fields, pinfo, pidx, wtmout) <-
                -- No instance for 5-tuple, code copied from the
                -- json sources and adapted
                fromJResult "Parsing WaitForJobChange message" $
                case args of
                  JSArray [a, b, c, d, e] ->
                    (,,,,) `fmap`
                    J.readJSON a `ap`
                    J.readJSON b `ap`
                    J.readJSON c `ap`
                    J.readJSON d `ap`
                    J.readJSON e
                  _ -> J.Error "Not enough values"
              rid <- tryRead "parsing job ID" jid
              return $ WaitForJobChange rid fields pinfo pidx wtmout
    ReqArchiveJob -> do
              [jid] <- fromJVal args
              rid <- tryRead "parsing job ID" jid
              return $ ArchiveJob rid
    ReqAutoArchiveJobs -> do
              (age, tmout) <- fromJVal args
              return $ AutoArchiveJobs age tmout
    ReqQueryExports -> do
              (nodes, lock) <- fromJVal args
              return $ QueryExports nodes lock
    ReqQueryConfigValues -> do
              [fields] <- fromJVal args
              return $ QueryConfigValues fields
    ReqQueryTags -> do
              (kind, name) <- fromJVal args
              return $ QueryTags kind name
    ReqCancelJob -> do
              [job] <- fromJVal args
              rid <- tryRead "parsing job ID" job
              return $ CancelJob rid
    ReqSetDrainFlag -> do
              [flag] <- fromJVal args
              return $ SetDrainFlag flag
    ReqSetWatcherPause -> do
              [duration] <- fromJVal args
              return $ SetWatcherPause duration

-- | Check that luxi responses contain the required keys and that the
-- call was successful.
validateResult :: String -> Result JSValue
validateResult s = do
  oarr <- fromJResult "Parsing LUXI response"
          (decodeStrict s)::Result (JSObject JSValue)
  let arr = J.fromJSObject oarr
  status <- fromObj arr (strOfKey Success)::Result Bool
  let rkey = strOfKey Result
  if status
    then fromObj arr rkey
    else fromObj arr rkey >>= fail

-- | Generic luxi method call.
callMethod :: LuxiOp -> Client -> IO (Result JSValue)
callMethod method s = do
  sendMsg s $ buildCall method
  result <- recvMsg s
  let rval = validateResult result
  return rval

-- | Specialized submitManyJobs call.
submitManyJobs :: Client -> [[OpCode]] -> IO (Result [String])
submitManyJobs s jobs = do
  rval <- callMethod (SubmitManyJobs jobs) s
  -- map each result (status, payload) pair into a nice Result ADT
  return $ case rval of
             Bad x -> Bad x
             Ok (JSArray r) ->
                 mapM (\v -> case v of
                               JSArray [JSBool True, JSString x] ->
                                   Ok (fromJSString x)
                               JSArray [JSBool False, JSString x] ->
                                   Bad (fromJSString x)
                               _ -> Bad "Unknown result from the master daemon"
                      ) r
             x -> Bad ("Cannot parse response from Ganeti: " ++ show x)

-- | Custom queryJobs call.
queryJobsStatus :: Client -> [String] -> IO (Result [JobStatus])
queryJobsStatus s jids = do
  rval <- callMethod (QueryJobs (map read jids) ["status"]) s
  return $ case rval of
             Bad x -> Bad x
             Ok y -> case J.readJSON y::(J.Result [[JobStatus]]) of
                       J.Ok vals -> if any null vals
                                    then Bad "Missing job status field"
                                    else Ok (map head vals)
                       J.Error x -> Bad x