From 13f2321cc5e852dd2183faa1de1c5e14569a5599 Mon Sep 17 00:00:00 2001
From: Iustin Pop <iustin@google.com>
Date: Mon, 13 Aug 2012 15:05:55 +0200
Subject: [PATCH] Add a server-side Luxi implementation

This is a trivial code change, but it allows us to finally test the
send-receive code on both client and server sides via a simple
in-process server.

The unittest works, but it won't handle timeouts very nicely; it will
wait until the actual Luxi timeout expires, instead of using much
shorter timeouts as we could in the same process.

Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Guido Trotter <ultrotter@google.com>
---
 htools/Ganeti/HTools/QC.hs | 64 ++++++++++++++++++++++++++++++++++++++
 htools/Ganeti/Luxi.hs      | 21 +++++++++++++
 2 files changed, 85 insertions(+)

diff --git a/htools/Ganeti/HTools/QC.hs b/htools/Ganeti/HTools/QC.hs
index 5a0d3ee39..4708eaf10 100644
--- a/htools/Ganeti/HTools/QC.hs
+++ b/htools/Ganeti/HTools/QC.hs
@@ -51,6 +51,7 @@ module Ganeti.HTools.QC
   ) where
 
 import Test.QuickCheck
+import Test.QuickCheck.Monadic (assert, monadicIO, run)
 import Text.Printf (printf)
 import Data.List (intercalate, nub, isPrefixOf)
 import Data.Maybe
@@ -60,6 +61,11 @@ import qualified System.Console.GetOpt as GetOpt
 import qualified Text.JSON as J
 import qualified Data.Map
 import qualified Data.IntMap as IntMap
+import Control.Concurrent (forkIO)
+import Control.Exception (bracket, catchJust)
+import System.Directory (getTemporaryDirectory, removeFile)
+import System.IO (hClose, openTempFile)
+import System.IO.Error (isEOFErrorType, ioeGetErrorType)
 
 import qualified Ganeti.Confd as Confd
 import qualified Ganeti.Config as Config
@@ -287,6 +293,9 @@ instance Arbitrary DNSChar where
     x <- elements (['a'..'z'] ++ ['0'..'9'] ++ "_-")
     return (DNSChar x)
 
+instance Show DNSChar where
+  show = show . dnsGetChar
+
 -- | Generates a single name component.
 getName :: Gen String
 getName = do
@@ -1820,8 +1829,63 @@ prop_Luxi_CallEncoding :: Luxi.LuxiOp -> Property
 prop_Luxi_CallEncoding op =
   (Luxi.validateCall (Luxi.buildCall op) >>= Luxi.decodeCall) ==? Types.Ok op
 
+-- | Helper to a get a temporary file name.
+getTempFileName :: IO FilePath
+getTempFileName = do
+  tempdir <- getTemporaryDirectory
+  (fpath, handle) <- openTempFile tempdir "luxitest"
+  _ <- hClose handle
+  removeFile fpath
+  return fpath
+
+-- | Helper to execute recvMsg but return Nothing if we reach EOF.
+handleEOF :: (IO a) -> IO (Maybe a)
+handleEOF action =
+  catchJust
+    (\e -> if isEOFErrorType (ioeGetErrorType e) then Just () else Nothing)
+    (liftM Just action)
+    (\_ -> return Nothing)
+
+-- | Server ping-pong helper.
+luxiServerPong :: Luxi.Client -> IO ()
+luxiServerPong c = do
+  msg <- handleEOF (Luxi.recvMsg c)
+  case msg of
+    Nothing -> return ()
+    Just m -> Luxi.sendMsg c m >> luxiServerPong c
+
+-- | Client ping-pong helper.
+luxiClientPong :: Luxi.Client -> [String] -> IO [String]
+luxiClientPong c =
+  mapM (\m -> Luxi.sendMsg c m >> Luxi.recvMsg c)
+
+-- | Monadic check that, given a server socket, we can connect via a
+-- client to it, and that we can send a list of arbitrary messages and
+-- get back what we sent.
+prop_Luxi_ClientServer :: [[DNSChar]] -> Property
+prop_Luxi_ClientServer dnschars = monadicIO $ do
+  let msgs = map (map dnsGetChar) dnschars
+  fpath <- run $ getTempFileName
+  -- we need to create the server first, otherwise (if we do it in the
+  -- forked thread) the client could try to connect to it before it's
+  -- ready
+  server <- run $ Luxi.getServer fpath
+  -- fork the server responder
+  _ <- run $ forkIO $
+    bracket
+      (Luxi.acceptClient server)
+      (\c -> Luxi.closeClient c >> removeFile fpath)
+      luxiServerPong
+  replies <- run $
+    bracket
+      (Luxi.getClient fpath)
+      Luxi.closeClient
+      (\c -> luxiClientPong c msgs)
+  assert $ replies == msgs
+
 testSuite "LUXI"
           [ 'prop_Luxi_CallEncoding
+          , 'prop_Luxi_ClientServer
           ]
 
 -- * Ssconf tests
diff --git a/htools/Ganeti/Luxi.hs b/htools/Ganeti/Luxi.hs
index b018222ed..ec7d5e2fe 100644
--- a/htools/Ganeti/Luxi.hs
+++ b/htools/Ganeti/Luxi.hs
@@ -34,6 +34,8 @@ module Ganeti.Luxi
   , JobId
   , checkRS
   , getClient
+  , getServer
+  , acceptClient
   , closeClient
   , callMethod
   , submitManyJobs
@@ -41,6 +43,8 @@ module Ganeti.Luxi
   , buildCall
   , validateCall
   , decodeCall
+  , recvMsg
+  , sendMsg
   ) where
 
 import Data.IORef
@@ -216,6 +220,23 @@ getClient path = do
   h <- S.socketToHandle s ReadWriteMode
   return Client { socket=h, rbuf=rf }
 
+-- | Creates and returns a server endpoint.
+getServer :: FilePath -> IO S.Socket
+getServer path = do
+  s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
+  S.bindSocket s (S.SockAddrUnix path)
+  S.listen s 5 -- 5 is the max backlog
+  return s
+
+-- | Accepts a client
+acceptClient :: S.Socket -> IO Client
+acceptClient s = do
+  -- second return is the address of the client, which we ignore here
+  (client_socket, _) <- S.accept s
+  new_buffer <- newIORef B.empty
+  handle <- S.socketToHandle client_socket ReadWriteMode
+  return Client { socket=handle, rbuf=new_buffer }
+
 -- | Closes the client socket.
 closeClient :: Client -> IO ()
 closeClient = hClose . socket
-- 
GitLab