Blocking.hs 3.1 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788
  1. {-# LANGUAGE OverloadedStrings #-}
  2. module Blocking (tests) where
  3. import Distribution.TestSuite
  4. import Base (simpleTest)
  5. import Control.Concurrent(forkIO)
  6. import qualified System.IO.Uniform as U
  7. import qualified System.IO.Uniform.Streamline as S
  8. import System.Timeout (timeout)
  9. import Data.ByteString (ByteString)
  10. import qualified Data.ByteString as BS
  11. import qualified Data.ByteString.Char8 as C8
  12. import qualified Data.Attoparsec.ByteString as A
  13. --import Control.Monad.IO.Class (liftIO)
  14. tests :: IO [Test]
  15. tests = return [
  16. simpleTest "recieveLine"
  17. (successTimeout "A test\n" (restoreLine S.receiveLine)),
  18. simpleTest "runAttoparsec with successful parser"
  19. (successTimeout "abcde" (parseBS (A.string "abcde"))),
  20. simpleTest "runAttoparsec with failed parser"
  21. (failTimeout "abcde" (parseBS (A.string "c"))),
  22. simpleTest "lazyRecieveLine"
  23. (successTimeout "Another test\n" (concatLine S.lazyRecieveLine)),
  24. simpleTest "lazyReceiveN"
  25. (failTimeout "abcde" (concatLine (S.lazyReceiveN 5)))
  26. ]
  27. parseBS :: A.Parser ByteString -> S.Streamline IO ByteString
  28. parseBS p = do
  29. t <- S.runAttoparsec p
  30. case t of
  31. Left e -> return . C8.pack $ e
  32. Right s -> return s
  33. restoreLine :: S.Streamline IO ByteString -> S.Streamline IO ByteString
  34. restoreLine f = do
  35. l <- f
  36. return $ BS.concat [l, "\n"]
  37. concatLine :: S.Streamline IO [ByteString] -> S.Streamline IO ByteString
  38. concatLine f = do
  39. l <- f
  40. return . BS.concat $ l
  41. -- | Tests the given command, by sending a string to an echo and running the command.
  42. -- the command must not block.
  43. successTimeout :: ByteString -> S.Streamline IO ByteString -> IO Progress
  44. successTimeout txt f = do
  45. recv <- U.bindPort 8888
  46. forkIO $ S.withClient (\_ _ -> do
  47. l <- f
  48. S.send l
  49. return ()
  50. ) recv
  51. r' <- timeout 1000000 $ S.withServer (do
  52. S.send txt
  53. t <- f
  54. if t == txt
  55. then return . Finished $ Pass
  56. else return . Finished . Fail . C8.unpack $ t
  57. ) "127.0.0.1" 8888
  58. U.closePort recv
  59. case r' of
  60. Just r -> return r
  61. Nothing -> return . Finished . Fail $ "Execution blocked"
  62. -- | Tests the given command, by sending text trough the network and running it.
  63. -- Does not care about the result of the command, just wether it blocks.
  64. failTimeout :: ByteString -> S.Streamline IO ByteString -> IO Progress
  65. failTimeout txt f = do
  66. recv <- U.bindPort 8888
  67. forkIO $ S.withClient (\_ _ -> do
  68. f
  69. S.send "\n"
  70. return ()
  71. ) recv
  72. r' <- timeout 1000000 $ S.withServer (do
  73. S.send txt
  74. S.receiveLine
  75. return . Finished $ Pass
  76. ) "127.0.0.1" 8888
  77. U.closePort recv
  78. case r' of
  79. Just r -> return r
  80. Nothing -> return . Finished . Fail $ "Execution blocked"