uniform-io/test/Targets.hs

{-# LANGUAGE OverloadedStrings #-}

module Targets (tests) where

import Distribution.TestSuite
import Base (simpleTest)
import Control.Concurrent(forkIO) 
import System.IO.Uniform
import System.IO.Uniform.Network
import System.IO.Uniform.File
--import System.IO.Uniform.Std
import System.IO.Uniform.ByteString
import System.Timeout (timeout)
import qualified Data.ByteString.Char8 as C8
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS

tests :: IO [Test]
tests = return [
  simpleTest "network" testNetwork,
  simpleTest "file" testFile,
  simpleTest "network TLS" testTls,
  simpleTest "byte string" testBS
  ]

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 mapOverInput 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