io-streams-1.5.2.2: test/System/IO/Streams/Tests/Handle.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module System.IO.Streams.Tests.Handle (tests) where
------------------------------------------------------------------------------
import Control.Exception
import Control.Monad hiding (mapM)
import Data.ByteString.Builder (byteString)
import qualified Data.ByteString.Char8 as S
import Data.List
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.Marshal.Utils (copyBytes)
import Foreign.Ptr (castPtr)
import qualified GHC.IO.Buffer as HB
import qualified GHC.IO.BufferedIO as H
import qualified GHC.IO.Device as H
import Prelude hiding (mapM, read)
import System.Directory
import System.FilePath
import System.IO hiding (stderr, stdin, stdout)
import qualified System.IO as IO
import System.IO.Streams (OutputStream)
import qualified System.IO.Streams as Streams
import qualified System.IO.Streams.Internal as Streams
import Test.Framework
import Test.Framework.Providers.HUnit
import Test.HUnit hiding (Test)
------------------------------------------------------------------------------
import System.IO.Streams.Tests.Common
tests :: [Test]
tests = [ testHandle
, testStdHandles
, testRepeatedConnects
, testInputStreamToHandle
, testOutputStreamToHandle
, testStreamPairToHandle
, testHandleInstances
, testHandleBadnesses
]
------------------------------------------------------------------------------
testHandle :: Test
testHandle = testCase "handle/files" $ do
createDirectoryIfMissing False "tmp"
tst `finally` eatException (removeFile fn >> removeDirectory "tmp")
where
fn = "tmp" </> "data"
tst = do
withBinaryFile fn WriteMode $ \h -> do
let l = "" : (intersperse " " ["the", "quick", "brown", "fox"])
os <- Streams.handleToOutputStream h
Streams.fromList l >>= Streams.connectTo os
withBinaryFile fn ReadMode $ \h -> do
l <- liftM S.concat (Streams.handleToInputStream h >>=
Streams.toList)
assertEqual "testFiles" "the quick brown fox" l
------------------------------------------------------------------------------
testRepeatedConnects :: Test
testRepeatedConnects = testCase "handle/repeatedConnects" $ do
createDirectoryIfMissing False dirname
tst `finally` eatException (removeFile fn >> removeDirectory dirname)
where
dirname = "tmp_r_c"
fn = dirname </> "data"
tst = do
withBinaryFile fn WriteMode $ \h -> do
os0 <- Streams.handleToOutputStream h
os <- Streams.builderStream os0
let l1 = map byteString ["the ", "quick ", "brown "]
let l2 = map byteString ["fox ", "jumped"]
Streams.fromList l1 >>= Streams.connectTo os
Streams.fromList l2 >>= Streams.connectTo os
S.readFile fn >>= assertEqual "eof should close" "the quick brown "
------------------------------------------------------------------------------
testStdHandles :: Test
testStdHandles = testCase "handle/stdHandles" $ do
hClose IO.stdin
-- Should generate exception: handle is closed.
expectExceptionH (Streams.toList Streams.stdin)
Streams.write (Just "") Streams.stdout
Streams.write (Just "") Streams.stderr
return ()
------------------------------------------------------------------------------
testInputStreamToHandle :: Test
testInputStreamToHandle = testCase "handle/inputStreamToHandle" $ do
h <- Streams.fromList ["foo", "bar", "baz"] >>=
Streams.inputStreamToHandle
S.hGetContents h >>= assertEqual "inputStreamToHandle" "foobarbaz"
------------------------------------------------------------------------------
testOutputStreamToHandle :: Test
testOutputStreamToHandle = testCase "handle/outputStreamToHandle" $ do
(os, getInput) <- Streams.listOutputStream
h <- Streams.outputStreamToHandle os
S.hPutStrLn h "foo"
liftM S.concat getInput >>= assertEqual "outputStreamToHandle" "foo\n"
------------------------------------------------------------------------------
testStreamPairToHandle :: Test
testStreamPairToHandle = testCase "handle/streamPairToHandle" $ do
is <- Streams.fromList ["foo", "bar", "baz"]
(os, getInput) <- Streams.listOutputStream
h <- Streams.streamPairToHandle is os
S.hPutStrLn h "foo"
S.hGetContents h >>= assertEqual "input stream" "foobarbaz"
liftM S.concat getInput >>= assertEqual "output stream" "foo\n"
------------------------------------------------------------------------------
testHandleBadnesses :: Test
testHandleBadnesses = testCase "handle/badness" $ do
h <- Streams.fromList ["foo", "bar", "baz"] >>= Streams.inputStreamToHandle
_ <- S.hGetContents h
expectExceptionH $ S.hGetContents h
h' <- Streams.fromList ["foo", "bar", "baz"] >>= Streams.inputStreamToHandle
expectExceptionH $ S.hPutStrLn h' "foo"
(os, _) <- Streams.listOutputStream
h'' <- Streams.outputStreamToHandle os
expectExceptionH $ S.hGetContents h''
is <- Streams.fromList ["foo"]
h''' <- Streams.streamPairToHandle is os
_ <- S.hGetContents h'''
expectExceptionH $ S.hGetContents h'''
------------------------------------------------------------------------------
testHandleInstances :: Test
testHandleInstances = testCase "handle/ghc-instances" $ do
is <- Streams.fromList ["foo", "bar", "baz" :: S.ByteString]
(os, getList) <- Streams.listOutputStream
let sp = Streams.SP is (os :: OutputStream S.ByteString)
expectExceptionH $ withZeroOffset H.write is undefined undefined
expectExceptionH $ withZeroOffset H.writeNonBlocking is undefined undefined
expectExceptionH $ H.flushWriteBuffer is undefined
expectExceptionH $ H.flushWriteBuffer0 is undefined
expectExceptionH $ withZeroOffset H.read os undefined undefined
expectExceptionH $ withZeroOffset H.writeNonBlocking os undefined undefined
expectExceptionH $ H.fillReadBuffer0 is undefined
expectExceptionH $ H.fillReadBuffer0 os undefined
expectExceptionH $ H.fillReadBuffer0 sp undefined
H.ready is False 0 >>= assertEqual "ready input" True
H.ready os False 0 >>= assertEqual "ready output" True
H.ready sp False 0 >>= assertEqual "ready pair" True
H.devType is >>= assertBool "devtype input" . (== H.Stream)
H.devType os >>= assertBool "devtype output" . (== H.Stream)
H.devType sp >>= assertBool "devtype pair" . (== H.Stream)
expectExceptionH $ withZeroOffset H.readNonBlocking is undefined undefined
expectExceptionH $ withZeroOffset H.readNonBlocking os undefined undefined
expectExceptionH $ withZeroOffset H.readNonBlocking sp undefined undefined
expectExceptionH $ withZeroOffset H.writeNonBlocking is undefined undefined
expectExceptionH $ withZeroOffset H.writeNonBlocking os undefined undefined
expectExceptionH $ withZeroOffset H.writeNonBlocking sp undefined undefined
S.useAsCStringLen "foo" $ \(cstr, l) -> do
withZeroOffset H.write os (castPtr cstr) l
liftM S.concat getList >>= assertEqual "H.write 1" "foo"
withZeroOffset H.write sp (castPtr cstr) l
liftM S.concat getList >>= assertEqual "H.write 2" "foo"
buf <- H.newBuffer sp HB.WriteBuffer
HB.withBuffer buf $ \ptr -> copyBytes ptr (castPtr cstr) 3
(l', !buf') <- H.flushWriteBuffer0 sp $ buf { HB.bufR = 3 }
assertEqual "flushWriteBuffer0" 3 l'
assertEqual "bufR" 0 $ HB.bufR buf'
liftM S.concat getList >>= assertEqual "write 3" "foo"
allocaBytes 3 $ \buf -> do
l <- withZeroOffset H.read is buf 3
assertEqual "3 byte read" 3 l
S.packCStringLen (castPtr buf, l) >>= assertEqual "first read" "foo"
l' <- withZeroOffset H.read sp buf 3
assertEqual "3 byte read #2" 3 l'
S.packCStringLen (castPtr buf, l') >>= assertEqual "second read" "bar"
expectExceptionH $ withZeroOffset H.read os buf 3
where
#if MIN_VERSION_base(4,15,0)
withZeroOffset :: Num off => (a -> ptr -> off -> n -> ioint) -> a -> ptr -> n -> ioint
withZeroOffset f a ptr n = f a ptr 0 n
#else
withZeroOffset :: a -> a
withZeroOffset = id
#endif