{-# LANGUAGE OverloadedStrings #-} module Targets (tests) where import Distribution.TestSuite import Base import qualified System.IO as I import System.IO.Uniform import System.IO.Uniform.Network import System.IO.Uniform.File import System.IO.Uniform.ByteString import System.IO.Uniform.HandlePair import System.IO.Uniform.Timeout import System.Timeout (timeout) import Control.Concurrent import qualified Data.ByteString.Char8 as C8 import Data.ByteString (ByteString) import qualified Data.ByteString as BS import System.IO.Error tests :: IO [Test] tests = do t <- newMVar 1000000 return [ simpleTest "network" testNetwork, simpleTest "file" testFile, simpleTest "network TLS" testTls, simpleTest "byte string" testBS, simpleTest "handle pair" testHandlePair, noTimeoutTest "timeout success" $ tfixTimeouts (FixedTimeout 1000000) 1 False, noTimeoutTest "timeout fails" $ tfixTimeouts (FixedTimeout 10000) 10000 True, noTimeoutTest "mvar timeout success" $ tfixTimeouts (MVarTimeout t) 1 False, noTimeoutTest "mvar timeout fails" $ tfixTimeouts (MVarTimeout t) 10000 True ] testNetwork :: IO Progress testNetwork = do recv <- bindPort 8888 forkIO $ do s <- accept recv l <- uRead s 100 uPut s l uClose s return () r' <- timeout 1000000 $ do s <- connectToHost "127.0.0.1" 8888 let l = "abcdef\n" uPut s l l' <- uRead s 100 uClose s if l == l' then return . Finished $ Pass else return . Finished . Fail . C8.unpack $ l' closePort recv case r' of Just r -> return r Nothing -> return . Finished . Fail $ "Execution blocked" testFile :: IO Progress testFile = do let file = "test/testFile" s <- openFile file let l = "abcde\n" uPut s l uClose s s' <- openFile file l' <- uRead s' 100 uClose s' if l == l' then return . Finished $ Pass else return . Finished . Fail . C8.unpack $ l' testTls :: IO Progress testTls = do recv <- bindPort 8888 let set = TlsSettings "test/key.pem" "test/cert.pem" "test/dh.pem" forkIO $ do s' <- accept recv s <- startTls set s' l <- uRead s 100 uPut s l uClose s return () r' <- timeout 1000000 $ do s' <- connectToHost "127.0.0.1" 8888 s <- startTls set s' let l = "abcdef\n" uPut s l l' <- uRead s 100 uClose s if l == l' then return . Finished $ Pass else return . Finished . Fail . C8.unpack $ l' closePort recv case r' of Just r -> return r Nothing -> return . Finished . Fail $ "Execution blocked" testBS :: IO Progress testBS = do let dt = "Some data to test ByteString" (len, echo) <- withByteStringIO dt ( \io -> let count = countAndEcho io :: Int -> ByteString -> IO Int in foldOverInput io 2 count 0 ) :: IO (Int, ByteString) if dt /= echo || BS.length dt /= len then return . Finished . Fail $ "Failure on ByteStringIO test" else return . Finished $ Pass where countAndEcho :: UniformIO io => io -> Int -> ByteString -> IO Int countAndEcho io initial dt = do uPut io dt return $ initial + BS.length dt testHandlePair :: IO Progress testHandlePair = do let l = "abcde\n" h <- I.openFile "test/testHandles" I.WriteMode let s = fromHandles h h uPut s l uClose s h' <- I.openFile "test/testHandles" I.ReadMode let s' = fromHandles h' h' l' <- uRead s' 100 uClose s' if l == l' then return . Finished $ Pass else return . Finished . Fail . C8.unpack $ l' tfixTimeouts :: UniformIO a => (SocketIO -> a) -> Int -> Bool -> IO Progress tfixTimeouts mktimeout tm fails = do recv <- bindPort 8888 r' <- tryIOError $ do forkIO $ do s <- accept recv threadDelay $ tm * 10000 l <- uRead s 100 threadDelay $ tm * 10000 uPut s l uClose s return () s <- mktimeout <$> connectToHost "127.0.0.1" 8888 let l = "abcdef\n" uPut s l l' <- uRead s 100 uClose s if l == l' then return . Finished $ Pass else return . Finished . Fail . C8.unpack $ l' closePort recv case r' of Left e -> if fails then return . Finished $ Pass else return . Finished . Fail . show $ e Right r -> if fails then return . Finished . Fail $ "Timeout didn't trigger!" else return r