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
|
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Tests for untrusted data.
module Data.Store.UntrustedSpec where
import Test.Hspec
spec :: Spec
spec = return ()
{- Untrusted data spec is disabled for now. See #122 / #123 for details
import Data.Bifunctor
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.Int
import Data.IntMap (IntMap)
import qualified Data.IntMap as IM
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Monoid
import Data.Proxy
import qualified Data.Sequence as Seq
import Data.Store
import Data.Store.Internal
import Data.String
import Data.Text (Text)
import qualified Data.Vector as V
-- | Test suite.
actualSpec :: Spec
actualSpec =
describe
"Untrusted input throws error"
(do describe
"Array-like length prefixes"
(do let sample
:: IsString s
=> s
sample = "abc"
list :: [Int]
list = [1, 2, 3]
it
"ByteString"
(shouldBeRightWrong huge (sample :: ByteString))
it
"Lazy ByteString"
(shouldBeRightWrong huge (sample :: L.ByteString))
it "Text" (shouldBeRightWrong huge (sample :: Text))
it "String" (shouldBeRightWrong huge (sample :: String))
it "Vector Int" (shouldBeRightWrong huge (V.fromList list))
it
"Vector Char"
(shouldBeRightWrong huge (V.fromList (sample :: [Char])))
it
"Vector unit"
(shouldBeRightWrong
huge
(V.fromList (replicate 1000 ())))
it "Seq Int" (shouldBeRightWrong huge (Seq.fromList (sample :: [Char]))))
describe
"Maps are consistent"
(do it
"Map Int Int: with duplicates"
(shouldBeFail
(DuplicatedMap
(M.fromList [(1, 2), (4, 5)] :: Map Int Int))
(Proxy :: Proxy (Map Int Int)))
it
"Map Int Int: wrong order"
(shouldBeFail
(ReversedMap
(M.fromList [(1, 2), (4, 5)] :: Map Int Int))
(Proxy :: Proxy (Map Int Int)))
it
"IntMap Int Int: with duplicates"
(shouldBeFail
(DuplicatedIntMap
(IM.fromList [(1, 2), (4, 5)] :: IntMap Int))
(Proxy :: Proxy (IntMap Int)))
it
"IntMap Int Int: wrong order"
(shouldBeFail
(ReversedIntMap
(IM.fromList [(1, 2), (4, 5)] :: IntMap Int))
(Proxy :: Proxy (IntMap Int))))
describe
"Constructor tags"
(do it
"Invalid constructor tag"
(shouldBe
(first
(const ())
(decode "\2" :: Either PeekException (Maybe ())))
(Left ()))
it
"Missing slots"
(shouldBe
(first
(const ())
(decode "\1" :: Either PeekException (Maybe Char)))
(Left ()))))
huge :: Int64
huge = 2^(62::Int)
-- | Check decode.encode==id and then check decode.badencode=>error.
shouldBeRightWrong
:: forall i.
(Store i, Eq i, Show i)
=> Int64 -> i -> IO ()
shouldBeRightWrong len input = do
shouldBe (decode (encode input) :: Either PeekException i) (Right input)
shouldBe
(first
(const ())
(decode (encodeWrongPrefix len input) :: Either PeekException i))
(Left ())
-- | Check decode.encode==id and then check decode.badencode=>error.
shouldBeFail
:: forall o i.
(Store i, Eq o, Show o, Store o)
=> i -> Proxy o -> IO ()
shouldBeFail input _ =
shouldBe
(first
(const ())
(decode (encode input) :: Either PeekException o))
(Left ())
-- | Encode a thing with the wrong length prefix.
encodeWrongPrefix :: Store thing => Int64 -> thing -> ByteString
encodeWrongPrefix len thing = encode len <> encodeThingNoPrefix thing
-- | Encode the thing and drop the length prefix.
encodeThingNoPrefix :: Store thing => thing -> ByteString
encodeThingNoPrefix = S.drop (S.length (encode (1 :: Int64))) . encode
--------------------------------------------------------------------------------
-- Map variants
newtype ReversedIntMap = ReversedIntMap (IntMap Int)
deriving (Show, Eq)
instance Store ReversedIntMap where
poke (ReversedIntMap m) = do
poke markMapPokedInAscendingOrder
poke (reverse (IM.toList m))
peek = error "ReversedIntMap.peek"
size = VarSize (\(ReversedIntMap m) -> getSize m)
newtype DuplicatedIntMap = DuplicatedIntMap (IntMap Int)
deriving (Show, Eq)
instance Store DuplicatedIntMap where
poke (DuplicatedIntMap m) = do
poke markMapPokedInAscendingOrder
poke (let xs = IM.toList m
in take (length xs) (cycle (take 1 xs)))
peek = error "DuplicatedIntMap.peek"
size = VarSize (\(DuplicatedIntMap m) -> getSize m)
newtype ReversedMap = ReversedMap (Map Int Int)
deriving (Show, Eq)
instance Store ReversedMap where
poke (ReversedMap m) = do
poke markMapPokedInAscendingOrder
poke (reverse (M.toList m))
peek = error "ReversedMap.peek"
size = VarSize (\(ReversedMap m) -> getSize m)
newtype DuplicatedMap = DuplicatedMap (Map Int Int)
deriving (Show, Eq)
instance Store DuplicatedMap where
poke (DuplicatedMap m) = do
poke markMapPokedInAscendingOrder
poke (let xs = M.toList m
in take (length xs) (cycle (take 1 xs)))
peek = error "DuplicatedMap.peek"
size = VarSize (\(DuplicatedMap m) -> getSize m)
-}
|
