Synnefo » snf-ganeti

import Test.QuickCheck.Monadic (assert, monadicIO, run)

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)

instance Show DNSChar where

  show = show . dnsGetChar

-- | 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

          , 'prop_Luxi_ClientServer

  , getServer

  , acceptClient

  , recvMsg

  , sendMsg

-- | 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 }