uniform-io-1.2.0.0: test/Blocking.hs

{-# LANGUAGE OverloadedStrings #-}

module Blocking where

import Distribution.TestSuite
import Base (simpleTest)
import Control.Concurrent(forkIO) 
import System.IO.Uniform.Network
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)
--import Debug.Trace

tests :: IO [Test]
tests = return [
  simpleTest "recieveLine"
  (successTimeout "A test\n" S.recieveLine),
  simpleTest "runAttoparsec with successful parser"
  (successTimeout "abcde" (parseBS (A.string "abcde"))),
  simpleTest "runAttoparsec with failed parser"
  (failTimeout "abcde" (parseBS (A.string "c"))),
  simpleTest "recieveTill"
  (failTimeout "abcde" (restoreLine $ S.recieveTill "de"))
  ]

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 <- bindPort 8888
  forkIO $ S.withClient recv $ \_ _ ->
    do
      l <- f
      S.send l
      return ()
  r' <- timeout 1000000 $ S.withServer "127.0.0.1" 8888 $
        do
          S.send txt
          t <- f
          if t == txt
            then return . Finished $ Pass
            else return . Finished . Fail $ "Strings differ: " -- ++ show txt ++ " <> " ++ show t
  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 <- bindPort 8888
  forkIO $ S.withClient recv $ \_ _ ->
    do
      f
      S.send "\n"
      return ()
  r' <- timeout 1000000 $ S.withServer "127.0.0.1" 8888 $
        do
          S.send txt
          S.recieveLine
          return . Finished $ Pass
  closePort recv
  case r' of
    Just r -> return r
    Nothing -> return . Finished . Fail $ "Execution blocked"