uniform-io/test/Blocking.hs

{-# LANGUAGE OverloadedStrings #-}

module Blocking (tests) where

import Distribution.TestSuite
import Base (simpleTest)
import Control.Concurrent(forkIO) 
import qualified System.IO.Uniform as U
import qualified System.IO.Uniform.Streamline as S
import System.Timeout (timeout)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C8
import qualified Data.Attoparsec.ByteString as A
--import Control.Monad.IO.Class (liftIO)

tests :: IO [Test]
tests = return [
  simpleTest "recieveLine"
  (successTimeout "A test\n" (restoreLine S.receiveLine)),
  simpleTest "runAttoparsec with successful parser"
  (successTimeout "abcde" (parseBS (A.string "abcde"))),
  simpleTest "runAttoparsec with failed parser"
  (failTimeout "abcde" (parseBS (A.string "c"))),
  simpleTest "lazyRecieveLine"
  (successTimeout "Another test\n" (concatLine S.lazyRecieveLine)),
  simpleTest "lazyReceiveN"
  (failTimeout "abcde" (concatLine (S.lazyReceiveN 5)))
  ]

parseBS :: A.Parser ByteString -> S.Streamline IO ByteString
parseBS p = do
  t <- S.runAttoparsec p
  case t of
    Left e -> return . C8.pack $ e
    Right s -> return s

restoreLine :: S.Streamline IO ByteString -> S.Streamline IO ByteString
restoreLine f = do
  l <- f
  return $ BS.concat [l, "\n"]
  
concatLine :: S.Streamline IO [ByteString] -> S.Streamline IO ByteString
concatLine f = do
  l <- f
  return . BS.concat $ l

-- | Tests the given command, by sending a string to an echo and running the command.
--   the command must not block.
successTimeout :: ByteString -> S.Streamline IO ByteString -> IO Progress
successTimeout txt f = do
  recv <- U.bindPort 8888
  forkIO $ S.withClient (\_ _ -> do
                            l <- f
                            S.send l
                            return ()
                        ) recv
  r' <- timeout 1000000 $ S.withServer (do
                                     S.send txt
                                     t <- f
                                     if t == txt
                                       then return . Finished $ Pass
                                       else return . Finished . Fail . C8.unpack $ t
                                 ) "127.0.0.1" 8888
  U.closePort recv
  case r' of
    Just r -> return r
    Nothing -> return . Finished . Fail $ "Execution blocked"

-- | Tests the given command, by sending text trough the network and running it.
--   Does not care about the result of the command, just wether it blocks.
failTimeout :: ByteString -> S.Streamline IO ByteString -> IO Progress
failTimeout txt f = do
  recv <- U.bindPort 8888
  forkIO $ S.withClient (\_ _ -> do
                            f
                            S.send "\n"
                            return ()
                        ) recv
  r' <- timeout 1000000 $ S.withServer (do
                                     S.send txt
                                     S.receiveLine
                                     return . Finished $ Pass
                                 ) "127.0.0.1" 8888
  U.closePort recv
  case r' of
    Just r -> return r
    Nothing -> return . Finished . Fail $ "Execution blocked"