{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- Due to usage of conduitGet below
import Control.Applicative (many, optional)
import Control.Exception.Base
import Test.HUnit
import Data.Conduit (ConduitT, (.|), runConduit, yield, await, runConduitPure)
import qualified Data.Conduit.List as CL
import Data.Serialize
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as S8
import qualified Data.List as L
import Data.Word
import System.Exit
--import Test.Framework.Providers.HUnit
import Data.Conduit.Cereal
import Data.Conduit.Cereal.Internal
-- For the sake of these tests, all SomeExceptions are equal
{-
instance Eq SomeException where
_ == _ = True
-}
twoItemGet :: Get Word8
twoItemGet = do
x <- getWord8
y <- getWord8
return $ x + y
threeItemGet :: Get Word8
threeItemGet = do
x <- getWord8
y <- getWord8
z <- getWord8
return $ x + y + z
putter :: Putter Char
putter c = put x >> put (x + 1)
where x = (fromIntegral $ (fromEnum c) - (fromEnum 'a') :: Word8)
sinktest1 :: Test
sinktest1 = TestCase (assertEqual "Handles starting with empty bytestring"
(Right 1)
(showLeft (runConduit ((CL.sourceList [BS.pack [], BS.pack [1]]) .| (sinkGet getWord8)))))
sinktest2 :: Test
sinktest2 = TestCase (assertEqual "Handles empty bytestring in middle"
(Right [1, 3])
(showLeft (runConduit (CL.sourceList [BS.pack [1], BS.pack [], BS.pack [3]] .| (sinkGet (do
x <- getWord8
y <- getWord8
return [x, y]))))))
sinktest3 :: Test
sinktest3 = TestCase (assertBool "Handles no data"
(case runConduit $ return () .| sinkGet getWord8 of
Right _ -> False
Left _ -> True))
sinktest4 :: Test
sinktest4 = TestCase (assertEqual "Consumes no data"
(Right ())
(showLeft $ runConduit (CL.sourceList [BS.pack [1]] .| (sinkGet $ return ()))))
sinktest5 :: Test
sinktest5 = TestCase (assertEqual "Empty list"
(Right ())
(showLeft $ runConduit ((CL.sourceList []) .| (sinkGet $ return ()))))
sinktest6 :: Test
sinktest6 = TestCase (assertEqual "Leftover input works"
(Right (1, BS.pack [2, 3, 4, 5]))
(showLeft $ runConduit ((CL.sourceList [BS.pack [1, 2, 3], BS.pack [4, 5]]) .| (do
output <- sinkGet getWord8
output' <- CL.consume
return (output, BS.concat output')))))
-- Current sink implementation will terminate the pipe in case of error.
-- One may need non-terminating version like one defined below to get access to Leftovers
sinkGetMaybe :: Get Word8 -> ConduitT BS.ByteString o (Either SomeException) Word8
sinkGetMaybe = mkSinkGet errorHandler terminationHandler
where errorHandler _ = return 34
terminationHandler _ = return 114
sinktest7 :: Test
sinktest7 = TestCase (assertEqual "Leftover input with failure works"
(Right (34, BS.pack [1, 2]))
(showLeft $ runConduit ((CL.sourceList [BS.pack [1, 2]]) .| (do
output <- sinkGetMaybe (getWord8 >> fail "" :: Get Word8)
output' <- CL.consume
return (output, BS.concat output')))))
sinktest8 :: Test
sinktest8 = TestCase (assertEqual "Leftover with incomplete input works"
(Right (114, BS.singleton 1))
(showLeft $ runConduit ((CL.sourceList [BS.singleton 1]) .| (do
output <- sinkGetMaybe twoItemGet
output' <- CL.consume
return (output, BS.concat output')))))
sinktest9 :: Test
sinktest9 = TestCase (assertEqual "Properly terminate Partials"
(Right [0..255])
(showLeft (runConduit (mapM_ (yield . BS.singleton) [0..255] .| sinkGet (many getWord8)))))
conduittest1 :: Test
conduittest1 = TestCase (assertEqual "Handles starting with empty bytestring"
(Right [])
(showLeft (runConduit ((CL.sourceList [BS.pack [], BS.pack [1]]) .| conduitGet twoItemGet .| CL.consume))))
conduittest2 :: Test
conduittest2 = TestCase (assertEqual "Works when the get is split across items"
(Right [3])
(showLeft (runConduit ((CL.sourceList [BS.pack [1], BS.pack [2]]) .| conduitGet twoItemGet .| CL.consume))))
conduittest3 :: Test
conduittest3 = TestCase (assertEqual "Works when empty bytestring in middle of get"
(Right [3])
(showLeft (runConduit ((CL.sourceList [BS.pack [1], BS.pack [], BS.pack [2]]) .| conduitGet twoItemGet .| CL.consume))))
conduittest4 :: Test
conduittest4 = TestCase (assertEqual "Works when empty bytestring at end of get"
(Right [3])
(showLeft (runConduit ((CL.sourceList [BS.pack [1, 2], BS.pack []]) .| conduitGet twoItemGet .| CL.consume))))
conduittest5 :: Test
conduittest5 = TestCase (assertEqual "Works when multiple gets are in an item"
(Right [3, 7])
(showLeft (runConduit ((CL.sourceList [BS.pack [1, 2, 3, 4]]) .| conduitGet twoItemGet .| CL.consume))))
conduittest6 :: Test
conduittest6 = TestCase (assertEqual "Works with leftovers"
(Right [3])
(showLeft (runConduit ((CL.sourceList [BS.pack [1, 2, 3]]) .| conduitGet twoItemGet .| CL.consume))))
conduittest7 :: Test
conduittest7 = let c = 10 in TestCase (assertEqual "Works with infinite lists"
(Right $ L.replicate c ())
(showLeft (runConduit ((CL.sourceList [BS.pack [1, 2, 3]]) .| conduitGet (return ()) .| CL.take c))))
conduittest8 :: Test
conduittest8 = let c = 10 in TestCase (assertEqual "Works with empty source and infinite lists"
(Right $ L.replicate c ())
(showLeft (runConduit ((CL.sourceList []) .| conduitGet (return ()) .| CL.take c))))
conduittest9 :: Test
conduittest9 = TestCase (assertEqual "Works with two well-placed items"
(Right [3, 7])
(showLeft (runConduit ((CL.sourceList [BS.pack [1, 2], BS.pack [3, 4]]) .| conduitGet twoItemGet .| CL.consume))))
conduittest10 :: Test
conduittest10 = TestCase (assertBool "Failure works"
(case runConduit $ (CL.sourceList [BS.pack [1, 2], BS.pack [3, 4]]) .| conduitGet (getWord8 >> fail "omfg") .| CL.consume of
Left _ -> True
Right _ -> False))
conduittest11 :: Test
conduittest11 = TestCase (assertBool "Immediate failure works"
(case runConduit $ (CL.sourceList [BS.pack [1, 2], BS.pack [3, 4]]) .| conduitGet (fail "omfg") .| CL.consume of
Left _ -> True
Right _ -> False))
conduittest12 :: Test
conduittest12 = TestCase (assertBool "Immediate failure with empty input works"
(case runConduit $ (CL.sourceList []) .| conduitGet (fail "omfg") .| CL.consume of
Left _ -> True
Right _ -> False))
conduittest13 :: Test
conduittest13 = TestCase (assertEqual "Leftover success conduit input works"
(Right [Right 12, Right 7, Left (BS.pack [5])])
(showLeft (runConduit ((CL.sourceList [BS.pack [10, 2, 3], BS.pack [4, 5]]) .| fancyConduit .| CL.consume))))
where fancyConduit = do
conduitGet twoItemGet .| CL.map (\ x -> Right x)
recurse
where recurse = await >>= maybe (return ()) (\ x -> yield (Left x) >> recurse)
showLeft :: Either SomeException a -> Either String a
showLeft (Left e) = Left (show e)
showLeft (Right x) = Right x
conduittest14 :: Test
conduittest14 = TestCase (assertEqual "Leftover coercing works"
(Right [Left (BS.pack [10, 2])])
(showLeft (runConduit ((CL.sourceList [BS.pack [10], BS.pack [2]]) .| fancyConduit .| CL.consume))))
where fancyConduit = do
conduitGet threeItemGet .| CL.map (\ x -> Right x)
recurse
where recurse = await >>= maybe (return ()) (\ x -> yield (Left x) >> recurse)
conduittest15 :: Test
conduittest15 = TestCase (assertEqual "Leftover premature end conduit input works"
(Right ([], BS.singleton 1))
(showLeft (runConduit ((CL.sourceList [BS.singleton 1]) .| (do
output <- (conduitGet twoItemGet) .| (CL.take 1)
output' <- CL.consume
return (output, BS.concat output'))))))
conduittest16 :: Test
conduittest16 = TestCase (assertEqual "Leftover failure conduit input works"
(Right [Left $ BS.pack [10, 11], Left $ BS.singleton 2]
:: Either String [Either BS.ByteString Word8])
(showLeft (runConduit ((CL.sourceList [BS.pack [10, 11], BS.pack [2]]) .| fancyConduit .| CL.consume))))
where fancyConduit = do
mkConduitGet (const $ return ()) (getWord8 >> fail "asdf" :: Get Word8) .| CL.map (\ x -> Right x)
recurse
where recurse = await >>= maybe (return ()) (\ x -> yield (Left x) >> recurse)
conduittest17 :: Test
conduittest17 = TestCase (assertEqual "Leftover failure conduit with broken input works"
(Right [Left $ BS.pack [10, 11], Left $ BS.singleton 12]
:: Either String [Either BS.ByteString Word8])
(runConduit ((CL.sourceList [BS.singleton 10, BS.singleton 11, BS.singleton 12]) .| fancyConduit .| CL.consume)))
where fancyConduit = do
mkConduitGet (const $ return ()) (twoItemGet >> fail "asdf" :: Get Word8) .| CL.map (\ x -> Right x)
recurse
where recurse = await >>= maybe (return ()) (\ x -> yield (Left x) >> recurse)
-- see https://github.com/snoyberg/conduit/issues/246
conduittest18 :: Test
conduittest18 = TestCase $ assertEqual "Deals with Get that consumes everything"
(Right [S8.pack "hello"])
( showLeft $ runConduit $
(yield "hello"
.| conduitGet2 slurp
.| CL.consume))
slurp :: Get BS.ByteString
slurp =
loop id
where
loop front = do
x <- remaining
if x == 0
then do
mbs <- optional $ lookAhead $ getBytes 1
case mbs of
Nothing -> do
let bs = BS.concat $ front []
if BS.null bs
then fail "no bytes remaining"
else return bs
Just _ -> loop front
else do
bs <- getBytes $ fromIntegral x
loop (front . (bs:))
puttest1 :: Test
puttest1 = TestCase (assertEqual "conduitPut works"
[BS.pack [0, 1]]
(runConduitPure $ (CL.sourceList ['a']) .| (conduitPut putter) .| CL.consume))
puttest2 :: Test
puttest2 = TestCase (assertEqual "multiple input conduitPut works"
[BS.pack [0, 1], BS.pack [1, 2], BS.pack [2, 3]]
(runConduitPure $ (CL.sourceList ['a', 'b', 'c']) .| (conduitPut putter) .| CL.consume))
puttest3 :: Test
puttest3 = TestCase (assertEqual "empty input conduitPut works"
[]
(runConduitPure ((CL.sourceList []) .| (conduitPut putter) .| CL.consume)))
sinktests :: Test
sinktests = TestList [ sinktest1
, sinktest2
, sinktest3
, sinktest4
, sinktest5
, sinktest6
, sinktest7
, sinktest8
, sinktest9
]
conduittests :: Test
conduittests = TestList [ conduittest1
, conduittest2
, conduittest3
, conduittest4
, conduittest5
, conduittest6
, conduittest7
, conduittest8
, conduittest9
, conduittest10
, conduittest11
, conduittest12
, conduittest13
, conduittest14
, conduittest15
, conduittest16
, conduittest17
, conduittest18
]
puttests :: Test
puttests = TestList [ puttest1
, puttest2
, puttest3
]
hunittests :: Test
hunittests = TestList [sinktests, conduittests, puttests]
--tests = hUnitTestToTests hunittests
main :: IO ()
main = do
counts' <- runTestTT hunittests
if errors counts' == 0 && failures counts' == 0
then exitSuccess
else exitFailure