{-# 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 "lazyRecieveLine" (successTimeout "Another test\n" (concatLine S.lazyRecieveLine)), simpleTest "lazyReceiveN" (failTimeout "abcde" (concatLine (S.lazyRecieveN 5))), 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"