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 instance Arbitrary Luxi.TagObject where
  52   arbitrary = elements [minBound..maxBound]
  53
  54 instance Arbitrary Luxi.LuxiReq where
  55   arbitrary = elements [minBound..maxBound]
  56
  57 instance Arbitrary Luxi.LuxiOp where
  58   arbitrary = do
  59     lreq <- arbitrary
  60     case lreq of
  61       Luxi.ReqQuery -> Luxi.Query <$> arbitrary <*> getFields <*> genFilter
  62       Luxi.ReqQueryFields -> Luxi.QueryFields <$> arbitrary <*> getFields
  63       Luxi.ReqQueryNodes -> Luxi.QueryNodes <$> (listOf getFQDN) <*>
  64                             getFields <*> arbitrary
  65       Luxi.ReqQueryGroups -> Luxi.QueryGroups <$> arbitrary <*>
  66                              arbitrary <*> arbitrary
  67       Luxi.ReqQueryInstances -> Luxi.QueryInstances <$> (listOf getFQDN) <*>
  68                                 getFields <*> arbitrary
  69       Luxi.ReqQueryJobs -> Luxi.QueryJobs <$> arbitrary <*> getFields
  70       Luxi.ReqQueryExports -> Luxi.QueryExports <$>
  71                               (listOf getFQDN) <*> arbitrary
  72       Luxi.ReqQueryConfigValues -> Luxi.QueryConfigValues <$> getFields
  73       Luxi.ReqQueryClusterInfo -> pure Luxi.QueryClusterInfo
  74       Luxi.ReqQueryTags -> Luxi.QueryTags <$> arbitrary <*> getFQDN
  75       Luxi.ReqSubmitJob -> Luxi.SubmitJob <$> (resize maxOpCodes arbitrary)
  76       Luxi.ReqSubmitManyJobs -> Luxi.SubmitManyJobs <$>
  77                                 (resize maxOpCodes arbitrary)
  78       Luxi.ReqWaitForJobChange -> Luxi.WaitForJobChange <$> arbitrary <*>
  79                                   getFields <*> pure J.JSNull <*>
  80                                   pure J.JSNull <*> arbitrary
  81       Luxi.ReqArchiveJob -> Luxi.ArchiveJob <$> arbitrary
  82       Luxi.ReqAutoArchiveJobs -> Luxi.AutoArchiveJobs <$> arbitrary <*>
  83                                  arbitrary
  84       Luxi.ReqCancelJob -> Luxi.CancelJob <$> arbitrary
  85       Luxi.ReqSetDrainFlag -> Luxi.SetDrainFlag <$> arbitrary
  86       Luxi.ReqSetWatcherPause -> Luxi.SetWatcherPause <$> arbitrary
  87
  88 -- | Simple check that encoding/decoding of LuxiOp works.
  89 prop_CallEncoding :: Luxi.LuxiOp -> Property
  90 prop_CallEncoding op =
  91   (Luxi.validateCall (Luxi.buildCall op) >>= Luxi.decodeCall) ==? Ok op
  92
  93 -- | Helper to a get a temporary file name.
  94 getTempFileName :: IO FilePath
  95 getTempFileName = do
  96   tempdir <- getTemporaryDirectory
  97   (fpath, handle) <- openTempFile tempdir "luxitest"
  98   _ <- hClose handle
  99   removeFile fpath
 100   return fpath
 101
 102 -- | Server ping-pong helper.
 103 luxiServerPong :: Luxi.Client -> IO ()
 104 luxiServerPong c = do
 105   msg <- Luxi.recvMsgExt c
 106   case msg of
 107     Luxi.RecvOk m -> Luxi.sendMsg c m >> luxiServerPong c
 108     _ -> return ()
 109
 110 -- | Client ping-pong helper.
 111 luxiClientPong :: Luxi.Client -> [String] -> IO [String]
 112 luxiClientPong c =
 113   mapM (\m -> Luxi.sendMsg c m >> Luxi.recvMsg c)
 114
 115 -- | Monadic check that, given a server socket, we can connect via a
 116 -- client to it, and that we can send a list of arbitrary messages and
 117 -- get back what we sent.
 118 prop_ClientServer :: [[DNSChar]] -> Property
 119 prop_ClientServer dnschars = monadicIO $ do
 120   let msgs = map (map dnsGetChar) dnschars
 121   fpath <- run $ getTempFileName
 122   -- we need to create the server first, otherwise (if we do it in the
 123   -- forked thread) the client could try to connect to it before it's
 124   -- ready
 125   server <- run $ Luxi.getServer fpath
 126   -- fork the server responder
 127   _ <- run . forkIO $
 128     bracket
 129       (Luxi.acceptClient server)
 130       (\c -> Luxi.closeClient c >> Luxi.closeServer fpath server)
 131       luxiServerPong
 132   replies <- run $
 133     bracket
 134       (Luxi.getClient fpath)
 135       Luxi.closeClient
 136       (\c -> luxiClientPong c msgs)
 137   stop $ replies ==? msgs
 138
 139 testSuite "Luxi"
 140           [ 'prop_CallEncoding
 141           , 'prop_ClientServer
 142           ]