content: {-# LANGUAGE BangPatterns #-}
  
  {-| RPC test program.
  
  -}
  
  {-
  
  Copyright (C) 2011, 2012, 2013 Google Inc.
  All rights reserved.
  
  Redistribution and use in source and binary forms, with or without
  modification, are permitted provided that the following conditions are
  met:
  
  1. Redistributions of source code must retain the above copyright notice,
  this list of conditions and the following disclaimer.
  
  2. Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.
  
  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
  IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
  EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
  PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
  PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
  LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  
  -}
  
  import Control.Concurrent
  import Control.Monad
  import System.Console.GetOpt
  import System.Environment
  import System.IO
  import Text.JSON (decode)
  import Text.Printf
  
  import Ganeti.BasicTypes
  import Ganeti.Common
  import Ganeti.Config
  import Ganeti.Errors
  import Ganeti.JSON
  import Ganeti.Objects
  import qualified Ganeti.Path as P
  import Ganeti.Rpc
  import Ganeti.Utils
  import Ganeti.Utils.Time (getCurrentTimeUSec)
  
  
  -- | Command line options structure.
  data Options = Options
    { optRpc      :: String   -- ^ RPC to execute
    , optDataFile :: FilePath -- ^ Path to the RPC serialised form
    , optVerbose  :: Bool     -- ^ Verbosity level
    , optStats    :: Bool     -- ^ Whether to show timing stats
    , optCount    :: Int      -- ^ Count of (multi) RPCs to do
    , optBatch    :: Int      -- ^ How many (multi) RPCs to run in parallel
    , optShowHelp :: Bool     -- ^ Just show the help
    , optShowComp :: Bool     -- ^ Just show the completion info
    , optShowVer  :: Bool     -- ^ Just show the program version
    } deriving Show
  
  -- | Default values for the command line options.
  defaultOptions :: Options
  defaultOptions = Options
    { optRpc      = "version"
    , optDataFile = "rpc.json"
    , optVerbose  = False
    , optStats    = False
    , optCount    = 1
    , optBatch    = 1
    , optShowHelp = False
    , optShowComp = False
    , optShowVer  = False
    }
  
  instance StandardOptions Options where
    helpRequested = optShowHelp
    verRequested  = optShowVer
    compRequested = optShowComp
    requestHelp o = o { optShowHelp = True }
    requestVer  o = o { optShowVer  = True }
    requestComp o = o { optShowComp = True }
  
  -- | The rpcs we support. Sadly this duplicates the RPC list.
  data KnownRpc = KRInstanceInfo        RpcCallInstanceInfo
                | KRAllInstancesInfo    RpcCallAllInstancesInfo
                | KRInstanceConsoleInfo RpcCallInstanceConsoleInfo
                | KRInstanceList        RpcCallInstanceList
                | KRNodeInfo            RpcCallNodeInfo
                | KRVersion             RpcCallVersion
                | KRStorageList         RpcCallStorageList
                | KRTestDelay           RpcCallTestDelay
                | KRExportList          RpcCallExportList
                  deriving (Show)
  
  -- | The command line options.
  options :: [GenericOptType Options]
  options =
    [ (Option "r" ["rpc"]
       (ReqArg (\ r o -> Ok o { optRpc = r }) "RPC")
       "the rpc to use [version]",
       OptComplChoices [])
    , (Option "f" ["data-file"]
       (ReqArg (\ f o -> Ok o { optDataFile = f }) "FILE")
       "the rpc serialised form [\"rpc.json\"]",
       OptComplFile)
    , (Option "v" ["verbose"]
       (NoArg (\ opts -> Ok opts { optVerbose = True}))
       "show more information when executing RPCs",
       OptComplNone)
    , (Option "t" ["stats"]
       (NoArg (\ opts -> Ok opts { optStats = True}))
       "show timing information summary",
       OptComplNone)
    , (Option "c" ["count"]
       (reqWithConversion (tryRead "reading count")
        (\count opts -> Ok opts { optCount = count }) "NUMBER")
       "Count of (multi) RPCs to execute [1]",
       OptComplInteger)
    , (Option "b" ["batch"]
       (reqWithConversion (tryRead "reading batch size")
        (\batch opts -> Ok opts { optBatch = batch }) "NUMBER")
       "Parallelisation factor for RPCs [1]",
       OptComplInteger)
    , oShowHelp
    , oShowComp
    , oShowVer
    ]
  
  -- | Arguments we expect
  arguments :: [ArgCompletion]
  arguments = [ArgCompletion OptComplOneNode 1 Nothing]
  
  -- | Log a message.
  logMsg :: MVar () -> String -> IO ()
  logMsg outmvar text =
    withMVar outmvar $ \_ -> do
      let p = if null text || last text /= '\n'
                then putStrLn
                else putStr
      p text
      hFlush stdout
  
  -- | Parses a RPC.
  parseRpc :: String -> String -> Result KnownRpc
  parseRpc "instance_info"      f =
    fromJResult "parsing rpc" (decode f) >>= Ok . KRInstanceInfo
  parseRpc "all_instances_info" f =
    fromJResult "parsing rpc" (decode f) >>= Ok . KRAllInstancesInfo
  parseRpc "console_instance_info" f =
    fromJResult "parsing rpc" (decode f) >>= Ok . KRInstanceConsoleInfo
  parseRpc "instance_list"      f =
    fromJResult "parsing rpc" (decode f) >>= Ok . KRInstanceList
  parseRpc "node_info"          f =
    fromJResult "parsing rpc" (decode f) >>= Ok . KRNodeInfo
  parseRpc "version"            f =
    fromJResult "parsing rpc" (decode f) >>= Ok . KRVersion
  parseRpc "storage_list"       f =
    fromJResult "parsing rpc" (decode f) >>= Ok . KRStorageList
  parseRpc "test_delay"         f =
    fromJResult "parsing rpc" (decode f) >>= Ok . KRTestDelay
  parseRpc "export_list"        f =
    fromJResult "parsing rpc" (decode f) >>= Ok . KRExportList
  parseRpc s _                  = Bad $ "Unknown rpc '" ++ s ++ "'"
  
  -- | Executes a RPC. These duplicate definitions are needed due to the
  -- polymorphism of 'executeRpcCall', and the binding of the result
  -- based on the input rpc call.
  execRpc :: [Node] -> KnownRpc -> IO [[String]]
  execRpc n (KRInstanceInfo        v) = formatRpcRes `fmap` executeRpcCall n v
  execRpc n (KRAllInstancesInfo    v) = formatRpcRes `fmap` executeRpcCall n v
  execRpc n (KRInstanceConsoleInfo v) = formatRpcRes `fmap` executeRpcCall n v
  execRpc n (KRInstanceList        v) = formatRpcRes `fmap` executeRpcCall n v
  execRpc n (KRNodeInfo            v) = formatRpcRes `fmap` executeRpcCall n v
  execRpc n (KRVersion             v) = formatRpcRes `fmap` executeRpcCall n v
  execRpc n (KRStorageList         v) = formatRpcRes `fmap` executeRpcCall n v
  execRpc n (KRTestDelay           v) = formatRpcRes `fmap` executeRpcCall n v
  execRpc n (KRExportList          v) = formatRpcRes `fmap` executeRpcCall n v
  
  -- | Helper to format the RPC result such that it can be printed by
  -- 'printTable'.
  formatRpcRes :: (Show b) => [(Node, ERpcError b)] -> [[String]]
  formatRpcRes = map (\(n, r) -> [nodeName n, either explainRpcError show r])
  
  -- | Main function.
  main :: IO ()
  main = do
    cmd_args <- getArgs
    (opts, args) <-
      parseOpts defaultOptions cmd_args "rpc-test" options arguments
    rpc <- parseRpc (optRpc opts) `liftM` readFile (optDataFile opts) >>=
           exitIfBad "parsing RPC"
    cfg_file <- P.clusterConfFile
    cfg <- loadConfig  cfg_file>>= exitIfBad "Can't load configuration"
    nodes <- exitIfBad "Can't find node" . errToResult $
              mapM (getNode cfg) args
    token <- newEmptyMVar -- semaphore for batch calls
    outmvar <- newMVar () -- token for stdout non-interleaving
    let logger = if optVerbose opts
                   then logMsg outmvar
                   else const $ return ()
    let batch = [1..optBatch opts]
        count = optCount opts
        rpcs = count * length nodes
    logger $ printf "Will execute %s multi-ops and %s RPCs"
             (show count) (show rpcs)
    tstart <- getCurrentTimeUSec
    _ <- forkIO $ mapM_ (\_ -> putMVar token ()) batch
    mapM_ (\idx -> do
             let str_idx = show idx
             logger $ "Acquiring token for run " ++ str_idx
             _ <- takeMVar token
             forkIO $ do
               start <- getCurrentTimeUSec
               logger $ "Start run " ++ str_idx
               !results <- execRpc nodes rpc
               stop <- getCurrentTimeUSec
               let delta = (fromIntegral (stop - start)::Double) / 1000
               putMVar token ()
               let stats = if optVerbose opts
                             then printf "Done run %d in %7.3fmsec\n" idx delta
                             else ""
                   table = printTable "" ["Node", "Result"]
                             results [False, False]
               logMsg outmvar $ stats ++ table
          ) [1..count]
    mapM_ (\_ -> takeMVar token) batch
    _ <- takeMVar outmvar
    when (optStats opts) $ do
      tstop <- getCurrentTimeUSec
      let delta = (fromIntegral (tstop - tstart) / 1000000)::Double
      printf "Total runtime:     %9.3fs\n" delta :: IO ()
      printf "Total mult-ops:    %9d\n" count :: IO ()
      printf "Total single RPCs: %9d\n" rpcs  :: IO ()
      printf "Multi-ops/sec:     %9.3f\n" (fromIntegral count / delta) :: IO ()
      printf "RPCs/sec:          %9.3f\n" (fromIntegral rpcs / delta) :: IO ()
  