~ubuntu-branches/ubuntu/trusty/haskell-cereal-conduit/trusty : revision 4

1

module Test.CerealConduit (tests) where

1

{-# LANGUAGE FlexibleContexts, RankNTypes #-}

2

3

module Test.CerealConduit where

2

4

3

5

import Control.Monad.Identity

6

import Control.Monad.Exception

7

import Control.Monad.Error

8

import Control.Monad.Trans.Maybe

4

9

import Test.HUnit

5

10

import qualified Data.Conduit as C

6

11

import Data.Conduit.Cereal

7

import Data.Conduit.List

12

import Data.Conduit.Cereal.Internal

13

import Data.Conduit.List as CL

8

14

import Data.Serialize

9

15

import qualified Data.ByteString as BS

10

import Test.Framework.Providers.HUnit

16

--import Test.Framework.Providers.HUnit

11

17

import System.Exit

12

18

import Data.Word

19

import qualified Data.List as L

20

import Prelude hiding (take)

21

22

-- For the sake of these tests, all SomeExceptions are equal

23

instance Eq SomeException where

24

a == b = True

25

26

twoItemGet :: Get Word8

27

twoItemGet = do

28

x <- getWord8

29

y <- getWord8

30

return $ x + y

13

31

14

32

sinktest1 :: Test

15

33

sinktest1 = TestCase (assertEqual "Handles starting with empty bytestring"

16

34

(Right 1)

17

(runIdentity $ (sourceList [BS.pack [], BS.pack [1]]) C.$$ (sinkGet getWord8)))

35

(runIdentity $ runExceptionT $ (sourceList [BS.pack [], BS.pack [1]]) C.$$ (sinkGet getWord8)))

18

36

19

37

sinktest2 :: Test

20

38

sinktest2 = TestCase (assertEqual "Handles empty bytestring in middle"

21

39

(Right [1, 3])

22

(runIdentity $ (sourceList [BS.pack [1], BS.pack [], BS.pack [3]]) C.$$ (sinkGet (do

40

(runIdentity $ runExceptionT $ (sourceList [BS.pack [1], BS.pack [], BS.pack [3]]) C.$$ (sinkGet (do

23

41

x <- getWord8

24

42

y <- getWord8

25

43

return [x, y]))))

26

44

27

45

sinktest3 :: Test

28

46

sinktest3 = TestCase (assertBool "Handles no data"

29

(case (runIdentity $ (sourceList []) C.$$ (sinkGet getWord8)) of

47

(case runIdentity $ runExceptionT $ (sourceList []) C.$$ (sinkGet getWord8) of

30

48

Right _ -> False

31

49

Left _ -> True))

32

50

33

51

sinktest4 :: Test

34

52

sinktest4 = TestCase (assertEqual "Consumes no data"

35

53

(Right ())

36

(runIdentity $ (sourceList [BS.pack [1]]) C.$$ (sinkGet $ return ())))

37

38

twoItemGet :: Get Word8

39

twoItemGet = do

40

x <- getWord8

41

y <- getWord8

42

return $ x + y

54

(runIdentity $ runExceptionT $ (sourceList [BS.pack [1]]) C.$$ (sinkGet $ return ())))

55

56

sinktest5 :: Test

57

sinktest5 = TestCase (assertEqual "Empty list"

58

(Right ())

59

(runIdentity $ runExceptionT $ (sourceList []) C.$$ (sinkGet $ return ())))

60

61

sinktest6 :: Test

62

sinktest6 = TestCase (assertEqual "Leftover input works"

63

(Right (1, BS.pack [2, 3, 4, 5]))

64

(runIdentity $ runExceptionT $ (sourceList [BS.pack [1, 2, 3], BS.pack [4, 5]]) C.$$ (do

65

output <- sinkGet getWord8

66

output' <- CL.consume

67

return (output, BS.concat output'))))

68

69

-- Current sink implementation will terminate the pipe in case of error.

70

-- One may need non-terminating version like one defined below to get access to Leftovers

71

72

sinkGetMaybe :: Monad m => Get output -> C.Sink BS.ByteString m (Maybe output)

73

sinkGetMaybe = mkSinkGet errorHandler terminationHandler . fmap Just

74

where errorHandler msg s = C.Done s Nothing

75

terminationHandler f s = C.Done s Nothing

76

77

sinktest7 :: Test

78

sinktest7 = TestCase (assertBool "Leftover input with failure works"

79

(case runIdentity $ do

80

(sourceList [BS.pack [1, 2]]) C.$$ (do

81

output <- sinkGetMaybe (getWord8 >> fail "" :: Get Word8)

82

output' <- CL.consume

83

return (output, BS.concat output')) of

84

(Nothing, bs) -> bs == BS.pack [1, 2]

85

otherwise -> False))

43

86

44

87

conduittest1 :: Test

45

88

conduittest1 = TestCase (assertEqual "Handles starting with empty bytestring"

46

[]

47

(runIdentity $ (sourceList [BS.pack [], BS.pack [1]]) C.$= conduitGet twoItemGet C.$$ consume))

89

(Right [])

90

(runIdentity $ runExceptionT $ (sourceList [BS.pack [], BS.pack [1]]) C.$= conduitGet twoItemGet C.$$ CL.consume))

48

91

49

92

conduittest2 :: Test

50

93

conduittest2 = TestCase (assertEqual "Works when the get is split across items"

51

[3]

52

(runIdentity $ (sourceList [BS.pack [1], BS.pack [2]]) C.$= conduitGet twoItemGet C.$$ consume))

94

(Right [3])

95

(runIdentity $ runExceptionT $ (sourceList [BS.pack [1], BS.pack [2]]) C.$= conduitGet twoItemGet C.$$ CL.consume))

53

96

54

97

conduittest3 :: Test

55

98

conduittest3 = TestCase (assertEqual "Works when empty bytestring in middle of get"

56

[3]

57

(runIdentity $ (sourceList [BS.pack [1], BS.pack [], BS.pack [2]]) C.$= conduitGet twoItemGet C.$$ consume))

99

(Right [3])

100

(runIdentity $ runExceptionT $ (sourceList [BS.pack [1], BS.pack [], BS.pack [2]]) C.$= conduitGet twoItemGet C.$$ CL.consume))

58

101

59

102

conduittest4 :: Test

60

103

conduittest4 = TestCase (assertEqual "Works when empty bytestring at end of get"

61

[3, 7]

62

(runIdentity $ (sourceList [BS.pack [1, 2], BS.pack [], BS.pack [3, 4]]) C.$= conduitGet twoItemGet C.$$ consume))

104

(Right [3])

105

(runIdentity $ runExceptionT $ (sourceList [BS.pack [1, 2], BS.pack []]) C.$= conduitGet twoItemGet C.$$ CL.consume))

63

106

64

107

conduittest5 :: Test

65

108

conduittest5 = TestCase (assertEqual "Works when multiple gets are in an item"

66

[3, 7]

67

(runIdentity $ (sourceList [BS.pack [1, 2, 3, 4]]) C.$= conduitGet twoItemGet C.$$ consume))

109

(Right [3, 7])

110

(runIdentity $ runExceptionT $ (sourceList [BS.pack [1, 2, 3, 4]]) C.$= conduitGet twoItemGet C.$$ CL.consume))

68

111

69

112

conduittest6 :: Test

70

113

conduittest6 = TestCase (assertEqual "Works with leftovers"

71

[3]

72

(runIdentity $ (sourceList [BS.pack [1, 2, 3]]) C.$= conduitGet twoItemGet C.$$ consume))

73

74

sinktests = TestList [sinktest1, sinktest2, sinktest3, sinktest4]

75

76

conduittests = TestList [conduittest1, conduittest2, conduittest3, conduittest4, conduittest5, conduittest6]

114

(Right [3])

115

(runIdentity $ runExceptionT $ (sourceList [BS.pack [1, 2, 3]]) C.$= conduitGet twoItemGet C.$$ CL.consume))

116

117

conduittest7 :: Test

118

conduittest7 = let c = 10 in TestCase (assertEqual "Works with infinite lists"

119

(Right $ L.replicate c ())

120

(runIdentity $ runExceptionT $ (sourceList [BS.pack [1, 2, 3]]) C.$= conduitGet (return ()) C.$$ take c))

121

122

conduittest8 :: Test

123

conduittest8 = let c = 10 in TestCase (assertEqual "Works with empty source and infinite lists"

124

(Right $ L.replicate c ())

125

(runIdentity $ runExceptionT $ (sourceList []) C.$= conduitGet (return ()) C.$$ take c))

126

127

conduittest9 :: Test

128

conduittest9 = let c = 10 in TestCase (assertEqual "Works with two well-placed items"

129

(Right [3, 7])

130

(runIdentity $ runExceptionT $ (sourceList [BS.pack [1, 2], BS.pack [3, 4]]) C.$= conduitGet twoItemGet C.$$ CL.consume))

131

132

conduittest10 :: Test

133

conduittest10 = TestCase (assertBool "Failure works"

134

(case runIdentity $ runExceptionT $ (sourceList [BS.pack [1, 2], BS.pack [3, 4]]) C.$= conduitGet (getWord8 >> fail "omfg") C.$$ CL.consume of

135

Left _ -> True

136

Right _ -> False))

137

138

conduittest11 :: Test

139

conduittest11 = TestCase (assertBool "Immediate failure works"

140

(case runIdentity $ runExceptionT $ (sourceList [BS.pack [1, 2], BS.pack [3, 4]]) C.$= conduitGet (fail "omfg") C.$$ CL.consume of

141

Left _ -> True

142

Right _ -> False))

143

144

conduittest12 :: Test

145

conduittest12 = TestCase (assertBool "Immediate failure with empty input works"

146

(case runIdentity $ runExceptionT $ (sourceList []) C.$= conduitGet (fail "omfg") C.$$ CL.consume of

147

Left _ -> True

148

Right _ -> False))

149

150

{-

151

-- This test CAN'T work because of the type of HaveOutput.

152

conduittest13 :: Test

153

conduittest13 = TestCase (assertEqual "Leftover success conduit input works"

154

([12], BS.pack [3, 4, 5])

155

(runIdentity $ (sourceList [BS.pack [10, 2, 3], BS.pack [4, 5]]) C.$$ (do

156

output <- (conduitGet twoItemGet) C.=$ (CL.take 1)

157

output' <- CL.consume

158

return (output, BS.concat output'))))

159

-}

160

161

conduittest14 :: Test

162

conduittest14 = TestCase (assertEqual "Leftover failure conduit input works"

163

(Right ([], BS.singleton 1))

164

(runIdentity $ runExceptionT $ (sourceList [BS.singleton 1]) C.$$ (do

165

output <- (conduitGet twoItemGet) C.=$ (CL.take 1)

166

output' <- CL.consume

167

return (output, BS.concat output'))))

168

169

sinktests = TestList [ sinktest1

170

, sinktest2

171

, sinktest3

172

, sinktest4

173

, sinktest5

174

, sinktest6

175

, sinktest7

176

]

177

178

conduittests = TestList [ conduittest1

179

, conduittest2

180

, conduittest3

181

, conduittest4

182

, conduittest5

183

, conduittest6

184

, conduittest7

185

, conduittest8

186

, conduittest9

187

, conduittest10

188

, conduittest11

189

, conduittest12

190

--, conduittest13

191

, conduittest14

192

]

77

193

78

194

hunittests = TestList [sinktests, conduittests]

79

195

80

tests = hUnitTestToTests hunittests

196

--tests = hUnitTestToTests hunittests

81

197

82

198

main = do

83

199

counts <- runTestTT hunittests