Targets.hs 4.3 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160
  1. {-# LANGUAGE OverloadedStrings #-}
  2. module Targets (tests) where
  3. import Distribution.TestSuite
  4. import Base (simpleTest)
  5. import qualified System.IO as I
  6. import System.IO.Uniform
  7. import System.IO.Uniform.Network
  8. import System.IO.Uniform.File
  9. import System.IO.Uniform.ByteString
  10. import System.IO.Uniform.HandlePair
  11. import System.IO.Uniform.Timeout
  12. import System.Timeout (timeout)
  13. import Control.Concurrent
  14. import qualified Data.ByteString.Char8 as C8
  15. import Data.ByteString (ByteString)
  16. import qualified Data.ByteString as BS
  17. import System.IO.Error
  18. tests :: IO [Test]
  19. tests = do
  20. t <- newMVar 1000000
  21. return [
  22. simpleTest "network" testNetwork,
  23. simpleTest "file" testFile,
  24. simpleTest "network TLS" testTls,
  25. simpleTest "byte string" testBS,
  26. simpleTest "handle pair" testHandlePair,
  27. simpleTest "timeout success" $ tfixTimeouts (FixedTimeout 1000000) 1 False,
  28. simpleTest "timeout fails" $ tfixTimeouts (FixedTimeout 1000000) 10000 True,
  29. simpleTest "mvar timeout success" $ tfixTimeouts (MVarTimeout t) 1 False,
  30. simpleTest "mvar timeout fails" $ tfixTimeouts (MVarTimeout t) 10000 True
  31. ]
  32. testNetwork :: IO Progress
  33. testNetwork = do
  34. recv <- bindPort 8888
  35. forkIO $ do
  36. s <- accept recv
  37. l <- uRead s 100
  38. uPut s l
  39. uClose s
  40. return ()
  41. r' <- timeout 1000000 $ do
  42. s <- connectToHost "127.0.0.1" 8888
  43. let l = "abcdef\n"
  44. uPut s l
  45. l' <- uRead s 100
  46. uClose s
  47. if l == l'
  48. then return . Finished $ Pass
  49. else return . Finished . Fail . C8.unpack $ l'
  50. closePort recv
  51. case r' of
  52. Just r -> return r
  53. Nothing -> return . Finished . Fail $ "Execution blocked"
  54. testFile :: IO Progress
  55. testFile = do
  56. let file = "test/testFile"
  57. s <- openFile file
  58. let l = "abcde\n"
  59. uPut s l
  60. uClose s
  61. s' <- openFile file
  62. l' <- uRead s' 100
  63. uClose s'
  64. if l == l'
  65. then return . Finished $ Pass
  66. else return . Finished . Fail . C8.unpack $ l'
  67. testTls :: IO Progress
  68. testTls = do
  69. recv <- bindPort 8888
  70. let set = TlsSettings "test/key.pem" "test/cert.pem" "test/dh.pem"
  71. forkIO $ do
  72. s' <- accept recv
  73. s <- startTls set s'
  74. l <- uRead s 100
  75. uPut s l
  76. uClose s
  77. return ()
  78. r' <- timeout 1000000 $ do
  79. s' <- connectToHost "127.0.0.1" 8888
  80. s <- startTls set s'
  81. let l = "abcdef\n"
  82. uPut s l
  83. l' <- uRead s 100
  84. uClose s
  85. if l == l'
  86. then return . Finished $ Pass
  87. else return . Finished . Fail . C8.unpack $ l'
  88. closePort recv
  89. case r' of
  90. Just r -> return r
  91. Nothing -> return . Finished . Fail $ "Execution blocked"
  92. testBS :: IO Progress
  93. testBS = do
  94. let dt = "Some data to test ByteString"
  95. (len, echo) <- withByteStringIO dt (
  96. \io -> let
  97. count = countAndEcho io :: Int -> ByteString -> IO Int
  98. in mapOverInput io 2 count 0
  99. ) :: IO (Int, ByteString)
  100. if dt /= echo || BS.length dt /= len
  101. then return . Finished . Fail $ "Failure on ByteStringIO test"
  102. else return . Finished $ Pass
  103. where
  104. countAndEcho :: UniformIO io => io -> Int -> ByteString -> IO Int
  105. countAndEcho io initial dt = do
  106. uPut io dt
  107. return $ initial + BS.length dt
  108. testHandlePair :: IO Progress
  109. testHandlePair = do
  110. let l = "abcde\n"
  111. h <- I.openFile "test/testHandles" I.WriteMode
  112. let s = fromHandles h h
  113. uPut s l
  114. uClose s
  115. h' <- I.openFile "test/testHandles" I.ReadMode
  116. let s' = fromHandles h' h'
  117. l' <- uRead s' 100
  118. uClose s'
  119. if l == l'
  120. then return . Finished $ Pass
  121. else return . Finished . Fail . C8.unpack $ l'
  122. tfixTimeouts :: UniformIO a => (SocketIO -> a) -> Int -> Bool -> IO Progress
  123. tfixTimeouts mktimeout tm fails = do
  124. recv <- bindPort 8888
  125. r' <- tryIOError $ do
  126. forkIO $ do
  127. s <- accept recv
  128. threadDelay $ tm * 10000
  129. l <- uRead s 100
  130. threadDelay $ tm * 10000
  131. uPut s l
  132. uClose s
  133. return ()
  134. s <- mktimeout <$> connectToHost "127.0.0.1" 8888
  135. let l = "abcdef\n"
  136. uPut s l
  137. l' <- uRead s 100
  138. uClose s
  139. if l == l'
  140. then return . Finished $ Pass
  141. else return . Finished . Fail . C8.unpack $ l'
  142. closePort recv
  143. case r' of
  144. Left e -> if fails
  145. then return . Finished $ Pass
  146. else return . Finished . Fail . show $ e
  147. Right r -> if fails
  148. then return . Finished . Fail $ "Timeout didn't trigger!"
  149. else return r