1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
|
{-# LANGUAGE FlexibleContexts #-}
import Control.Exception.Base
import Control.Monad.Identity
import Control.Monad.Trans.Resource
import Test.HUnit
import qualified Data.Conduit as C
import qualified Data.Conduit.List as CL
import Data.Serialize
import qualified Data.ByteString as BS
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
a == b = True
twoItemGet :: Get Word8
twoItemGet = do
x <- getWord8
y <- getWord8
return $ x + y
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)
(runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [], BS.pack [1]]) C.$$ (sinkGet getWord8)))
sinktest2 :: Test
sinktest2 = TestCase (assertEqual "Handles empty bytestring in middle"
(Right [1, 3])
(runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [1], BS.pack [], BS.pack [3]]) C.$$ (sinkGet (do
x <- getWord8
y <- getWord8
return [x, y]))))
sinktest3 :: Test
sinktest3 = TestCase (assertBool "Handles no data"
(case runIdentity $ runExceptionT $ (CL.sourceList []) C.$$ (sinkGet getWord8) of
Right _ -> False
Left _ -> True))
sinktest4 :: Test
sinktest4 = TestCase (assertEqual "Consumes no data"
(Right ())
(runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [1]]) C.$$ (sinkGet $ return ())))
sinktest5 :: Test
sinktest5 = TestCase (assertEqual "Empty list"
(Right ())
(runIdentity $ runExceptionT $ (CL.sourceList []) C.$$ (sinkGet $ return ())))
sinktest6 :: Test
sinktest6 = TestCase (assertEqual "Leftover input works"
(Right (1, BS.pack [2, 3, 4, 5]))
(runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [1, 2, 3], BS.pack [4, 5]]) C.$$ (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 :: Monad m => Get output -> C.Sink BS.ByteString m (Maybe output)
sinkGetMaybe = mkSinkGet errorHandler terminationHandler . fmap Just
where errorHandler msg s = C.Done s Nothing
terminationHandler f s = C.Done s Nothing
sinktest7 :: Test
sinktest7 = TestCase (assertBool "Leftover input with failure works"
(case runIdentity $ do
(CL.sourceList [BS.pack [1, 2]]) C.$$ (do
output <- sinkGetMaybe (getWord8 >> fail "" :: Get Word8)
output' <- CL.consume
return (output, BS.concat output')) of
(Nothing, bs) -> bs == BS.pack [1, 2]
otherwise -> False))
conduittest1 :: Test
conduittest1 = TestCase (assertEqual "Handles starting with empty bytestring"
(Right [])
(runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [], BS.pack [1]]) C.$= conduitGet twoItemGet C.$$ CL.consume))
conduittest2 :: Test
conduittest2 = TestCase (assertEqual "Works when the get is split across items"
(Right [3])
(runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [1], BS.pack [2]]) C.$= conduitGet twoItemGet C.$$ CL.consume))
conduittest3 :: Test
conduittest3 = TestCase (assertEqual "Works when empty bytestring in middle of get"
(Right [3])
(runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [1], BS.pack [], BS.pack [2]]) C.$= conduitGet twoItemGet C.$$ CL.consume))
conduittest4 :: Test
conduittest4 = TestCase (assertEqual "Works when empty bytestring at end of get"
(Right [3])
(runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [1, 2], BS.pack []]) C.$= conduitGet twoItemGet C.$$ CL.consume))
conduittest5 :: Test
conduittest5 = TestCase (assertEqual "Works when multiple gets are in an item"
(Right [3, 7])
(runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [1, 2, 3, 4]]) C.$= conduitGet twoItemGet C.$$ CL.consume))
conduittest6 :: Test
conduittest6 = TestCase (assertEqual "Works with leftovers"
(Right [3])
(runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [1, 2, 3]]) C.$= conduitGet twoItemGet C.$$ CL.consume))
conduittest7 :: Test
conduittest7 = let c = 10 in TestCase (assertEqual "Works with infinite lists"
(Right $ L.replicate c ())
(runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [1, 2, 3]]) C.$= conduitGet (return ()) C.$$ CL.take c))
conduittest8 :: Test
conduittest8 = let c = 10 in TestCase (assertEqual "Works with empty source and infinite lists"
(Right $ L.replicate c ())
(runIdentity $ runExceptionT $ (CL.sourceList []) C.$= conduitGet (return ()) C.$$ CL.take c))
conduittest9 :: Test
conduittest9 = let c = 10 in TestCase (assertEqual "Works with two well-placed items"
(Right [3, 7])
(runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [1, 2], BS.pack [3, 4]]) C.$= conduitGet twoItemGet C.$$ CL.consume))
conduittest10 :: Test
conduittest10 = TestCase (assertBool "Failure works"
(case runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [1, 2], BS.pack [3, 4]]) C.$= conduitGet (getWord8 >> fail "omfg") C.$$ CL.consume of
Left _ -> True
Right _ -> False))
conduittest11 :: Test
conduittest11 = TestCase (assertBool "Immediate failure works"
(case runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [1, 2], BS.pack [3, 4]]) C.$= conduitGet (fail "omfg") C.$$ CL.consume of
Left _ -> True
Right _ -> False))
conduittest12 :: Test
conduittest12 = TestCase (assertBool "Immediate failure with empty input works"
(case runIdentity $ runExceptionT $ (CL.sourceList []) C.$= conduitGet (fail "omfg") C.$$ CL.consume of
Left _ -> True
Right _ -> False))
-- This test CAN'T work because of the type of HaveOutput.
conduittest13 :: Test
conduittest13 = TestCase (assertEqual "Leftover success conduit input works"
(Right ([12], BS.pack [3, 4, 5]))
(runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [10, 2, 3], BS.pack [4, 5]]) C.$$ (do
output <- (conduitGet twoItemGet) C.=$ (CL.take 1)
output' <- CL.consume
return (output, BS.concat output'))))
conduittest14 :: Test
conduittest14 = TestCase (assertEqual "Leftover failure conduit input works"
(Right ([], BS.singleton 1))
(runIdentity $ runExceptionT $ (CL.sourceList [BS.singleton 1]) C.$$ (do
output <- (conduitGet twoItemGet) C.=$ (CL.take 1)
output' <- CL.consume
return (output, BS.concat output'))))
puttest1 :: Test
puttest1 = TestCase (assertEqual "conduitPut works"
[BS.pack [0, 1]]
(runIdentity $ (CL.sourceList ['a']) C.$= (conduitPut putter) C.$$ CL.consume))
puttest2 :: Test
puttest2 = TestCase (assertEqual "multiple input conduitPut works"
[BS.pack [0, 1], BS.pack [1, 2], BS.pack [2, 3]]
(runIdentity $ (CL.sourceList ['a', 'b', 'c']) C.$= (conduitPut putter) C.$$ CL.consume))
puttest3 :: Test
puttest3 = TestCase (assertEqual "empty input conduitPut works"
[]
(runIdentity $ (CL.sourceList []) C.$= (conduitPut putter) C.$$ CL.consume))
sinktests = TestList [ sinktest1
, sinktest2
, sinktest3
, sinktest4
, sinktest5
, sinktest6
, sinktest7
]
conduittests = TestList [ conduittest1
, conduittest2
, conduittest3
, conduittest4
, conduittest5
, conduittest6
, conduittest7
, conduittest8
, conduittest9
, conduittest10
, conduittest11
, conduittest12
--, conduittest13
, conduittest14
]
puttests = TestList [ puttest1
, puttest2
, puttest3
]
hunittests = TestList [sinktests, conduittests, puttests]
--tests = hUnitTestToTests hunittests
main = do
counts <- runTestTT hunittests
if errors counts == 0 && failures counts == 0
then exitSuccess
else exitFailure
|
