code.grnet.gr Git - ganeti-local/blob - htest/Test/Ganeti/Luxi.hs

   1 {-# LANGUAGE TemplateHaskell #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3
   4 {-| Unittests for ganeti-htools.
   5
   6 -}
   7
   8 {-
   9
  10 Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
  11
  12 This program is free software; you can redistribute it and/or modify
  13 it under the terms of the GNU General Public License as published by
  14 the Free Software Foundation; either version 2 of the License, or
  15 (at your option) any later version.
  16
  17 This program is distributed in the hope that it will be useful, but
  18 WITHOUT ANY WARRANTY; without even the implied warranty of
  19 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 General Public License for more details.
  21
  22 You should have received a copy of the GNU General Public License
  23 along with this program; if not, write to the Free Software
  24 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  25 02110-1301, USA.
  26
  27 -}
  28
  29 module Test.Ganeti.Luxi (testLuxi) where
  30
  31 import Test.QuickCheck
  32 import Test.QuickCheck.Monadic (monadicIO, run, stop)
  33
  34 import Control.Applicative
  35 import Control.Concurrent (forkIO)
  36 import Control.Exception (bracket)
  37 import System.Directory (getTemporaryDirectory, removeFile)
  38 import System.IO (hClose, openTempFile)
  39 import qualified Text.JSON as J
  40
  41 import Test.Ganeti.TestHelper
  42 import Test.Ganeti.TestCommon
  43 import Test.Ganeti.Query.Language (genFilter)
  44 import Test.Ganeti.OpCodes ()
  45
  46 import Ganeti.BasicTypes
  47 import qualified Ganeti.Luxi as Luxi
  48
  49 -- * Luxi tests
  50
  51 $(genArbitrary ''Luxi.TagObject)
  52
  53 $(genArbitrary ''Luxi.LuxiReq)
  54
  55 instance Arbitrary Luxi.LuxiOp where
  56   arbitrary = do
  57     lreq <- arbitrary
  58     case lreq of
  59       Luxi.ReqQuery -> Luxi.Query <$> arbitrary <*> getFields <*> genFilter
  60       Luxi.ReqQueryFields -> Luxi.QueryFields <$> arbitrary <*> getFields
  61       Luxi.ReqQueryNodes -> Luxi.QueryNodes <$> listOf getFQDN <*>
  62                             getFields <*> arbitrary
  63       Luxi.ReqQueryGroups -> Luxi.QueryGroups <$> arbitrary <*>
  64                              arbitrary <*> arbitrary
  65       Luxi.ReqQueryInstances -> Luxi.QueryInstances <$> listOf getFQDN <*>
  66                                 getFields <*> arbitrary
  67       Luxi.ReqQueryJobs -> Luxi.QueryJobs <$> arbitrary <*> getFields
  68       Luxi.ReqQueryExports -> Luxi.QueryExports <$>
  69                               listOf getFQDN <*> arbitrary
  70       Luxi.ReqQueryConfigValues -> Luxi.QueryConfigValues <$> getFields
  71       Luxi.ReqQueryClusterInfo -> pure Luxi.QueryClusterInfo
  72       Luxi.ReqQueryTags -> Luxi.QueryTags <$> arbitrary <*> getFQDN
  73       Luxi.ReqSubmitJob -> Luxi.SubmitJob <$> resize maxOpCodes arbitrary
  74       Luxi.ReqSubmitManyJobs -> Luxi.SubmitManyJobs <$>
  75                                 resize maxOpCodes arbitrary
  76       Luxi.ReqWaitForJobChange -> Luxi.WaitForJobChange <$> arbitrary <*>
  77                                   getFields <*> pure J.JSNull <*>
  78                                   pure J.JSNull <*> arbitrary
  79       Luxi.ReqArchiveJob -> Luxi.ArchiveJob <$> arbitrary
  80       Luxi.ReqAutoArchiveJobs -> Luxi.AutoArchiveJobs <$> arbitrary <*>
  81                                  arbitrary
  82       Luxi.ReqCancelJob -> Luxi.CancelJob <$> arbitrary
  83       Luxi.ReqSetDrainFlag -> Luxi.SetDrainFlag <$> arbitrary
  84       Luxi.ReqSetWatcherPause -> Luxi.SetWatcherPause <$> arbitrary
  85
  86 -- | Simple check that encoding/decoding of LuxiOp works.
  87 prop_CallEncoding :: Luxi.LuxiOp -> Property
  88 prop_CallEncoding op =
  89   (Luxi.validateCall (Luxi.buildCall op) >>= Luxi.decodeCall) ==? Ok op
  90
  91 -- | Helper to a get a temporary file name.
  92 getTempFileName :: IO FilePath
  93 getTempFileName = do
  94   tempdir <- getTemporaryDirectory
  95   (fpath, handle) <- openTempFile tempdir "luxitest"
  96   _ <- hClose handle
  97   removeFile fpath
  98   return fpath
  99
 100 -- | Server ping-pong helper.
 101 luxiServerPong :: Luxi.Client -> IO ()
 102 luxiServerPong c = do
 103   msg <- Luxi.recvMsgExt c
 104   case msg of
 105     Luxi.RecvOk m -> Luxi.sendMsg c m >> luxiServerPong c
 106     _ -> return ()
 107
 108 -- | Client ping-pong helper.
 109 luxiClientPong :: Luxi.Client -> [String] -> IO [String]
 110 luxiClientPong c =
 111   mapM (\m -> Luxi.sendMsg c m >> Luxi.recvMsg c)
 112
 113 -- | Monadic check that, given a server socket, we can connect via a
 114 -- client to it, and that we can send a list of arbitrary messages and
 115 -- get back what we sent.
 116 prop_ClientServer :: [[DNSChar]] -> Property
 117 prop_ClientServer dnschars = monadicIO $ do
 118   let msgs = map (map dnsGetChar) dnschars
 119   fpath <- run getTempFileName
 120   -- we need to create the server first, otherwise (if we do it in the
 121   -- forked thread) the client could try to connect to it before it's
 122   -- ready
 123   server <- run $ Luxi.getServer fpath
 124   -- fork the server responder
 125   _ <- run . forkIO $
 126     bracket
 127       (Luxi.acceptClient server)
 128       (\c -> Luxi.closeClient c >> Luxi.closeServer fpath server)
 129       luxiServerPong
 130   replies <- run $
 131     bracket
 132       (Luxi.getClient fpath)
 133       Luxi.closeClient
 134       (`luxiClientPong` msgs)
 135   stop $ replies ==? msgs
 136
 137 testSuite "Luxi"
 138           [ 'prop_CallEncoding
 139           , 'prop_ClientServer
 140           ]