uniform-io/test/Targets.hs

{-# 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