1 {-# LANGUAGE TemplateHaskell #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 {-| Unittests for ganeti-htools.
10 Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
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.
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.
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
29 module Test.Ganeti.Luxi (testLuxi) where
31 import Test.QuickCheck
32 import Test.QuickCheck.Monadic (monadicIO, run, stop)
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
41 import Test.Ganeti.TestHelper
42 import Test.Ganeti.TestCommon
43 import Test.Ganeti.Query.Language (genFilter)
44 import Test.Ganeti.OpCodes ()
46 import Ganeti.BasicTypes
47 import qualified Ganeti.Luxi as Luxi
51 $(genArbitrary ''Luxi.TagObject)
53 $(genArbitrary ''Luxi.LuxiReq)
55 instance Arbitrary Luxi.LuxiOp where
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 <*>
82 Luxi.ReqCancelJob -> Luxi.CancelJob <$> arbitrary
83 Luxi.ReqSetDrainFlag -> Luxi.SetDrainFlag <$> arbitrary
84 Luxi.ReqSetWatcherPause -> Luxi.SetWatcherPause <$> arbitrary
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
91 -- | Helper to a get a temporary file name.
92 getTempFileName :: IO FilePath
94 tempdir <- getTemporaryDirectory
95 (fpath, handle) <- openTempFile tempdir "luxitest"
100 -- | Server ping-pong helper.
101 luxiServerPong :: Luxi.Client -> IO ()
102 luxiServerPong c = do
103 msg <- Luxi.recvMsgExt c
105 Luxi.RecvOk m -> Luxi.sendMsg c m >> luxiServerPong c
108 -- | Client ping-pong helper.
109 luxiClientPong :: Luxi.Client -> [String] -> IO [String]
111 mapM (\m -> Luxi.sendMsg c m >> Luxi.recvMsg c)
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
123 server <- run $ Luxi.getServer fpath
124 -- fork the server responder
127 (Luxi.acceptClient server)
128 (\c -> Luxi.closeClient c >> Luxi.closeServer fpath server)
132 (Luxi.getClient fpath)
134 (\c -> luxiClientPong c msgs)
135 stop $ replies ==? msgs