1{-# LANGUAGE CPP #-}
2{-# LANGUAGE ExistentialQuantification #-}
3{-# LANGUAGE Rank2Types #-}
4{-# LANGUAGE NoImplicitPrelude #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE OverloadedStrings #-}
7module Main where
8
9import           Imports
10import           Foundation.Check.Main
11import           Utils
12import           Data.Char                    (chr)
13import           Data.Word
14import qualified Data.ByteString         as BS
15import           Data.ByteArray               (Bytes, ScrubbedBytes, ByteArray)
16import qualified Data.ByteArray          as B
17import qualified Data.ByteArray.Encoding as B
18import qualified Data.ByteArray.Parse    as Parse
19
20import qualified SipHash
21
22#ifdef WITH_BASEMENT_SUPPORT
23import           Basement.Block (Block)
24import           Basement.UArray (UArray)
25#endif
26
27newtype Positive = Positive Word
28  deriving (Show, Eq, Ord)
29instance Arbitrary Positive where
30    arbitrary = Positive <$> between (0, 255)
31
32data Backend = BackendByte | BackendScrubbedBytes
33#ifdef WITH_BASEMENT_SUPPORT
34#if MIN_VERSION_basement(0,0,5)
35    | BackendBlock
36#endif
37    | BackendUArray
38#endif
39    deriving (Show,Eq,Bounded,Enum)
40
41allBackends :: NonEmpty [Backend]
42allBackends = nonEmpty_ $ enumFrom BackendByte
43
44data ArbitraryBS = forall a . ByteArray a => ArbitraryBS a
45
46arbitraryBS :: Word -> Gen ArbitraryBS
47arbitraryBS n = do
48    backend <- elements allBackends
49    case backend of
50        BackendByte          -> ArbitraryBS `fmap` ((B.pack `fmap` replicateM (fromIntegral n) arbitrary) :: Gen Bytes)
51        BackendScrubbedBytes -> ArbitraryBS `fmap` ((B.pack `fmap` replicateM (fromIntegral n) arbitrary) :: Gen ScrubbedBytes)
52#ifdef WITH_BASEMENT_SUPPORT
53#if MIN_VERSION_basement(0,0,5)
54        BackendBlock         -> ArbitraryBS `fmap` ((B.pack `fmap` replicateM (fromIntegral n) arbitrary) :: Gen (Block Word8))
55#endif
56        BackendUArray        -> ArbitraryBS `fmap` ((B.pack `fmap` replicateM (fromIntegral n) arbitrary) :: Gen (UArray Word8))
57#endif
58
59arbitraryBSof :: Word -> Word -> Gen ArbitraryBS
60arbitraryBSof minBytes maxBytes = between (minBytes, maxBytes) >>= arbitraryBS
61
62newtype SmallList a = SmallList [a]
63    deriving (Show,Eq)
64
65instance Arbitrary a => Arbitrary (SmallList a) where
66    arbitrary = between (0,8) >>= \n -> SmallList `fmap` replicateM (fromIntegral n) arbitrary
67
68instance Arbitrary ArbitraryBS where
69    arbitrary = arbitraryBSof 0 259
70
71newtype Words8 = Words8 { unWords8 :: [Word8] }
72    deriving (Show,Eq)
73
74instance Arbitrary Words8 where
75    arbitrary = between (0, 259) >>= \n -> Words8 <$> replicateM (fromIntegral n) arbitrary
76
77testGroupBackends :: String -> (forall ba . (Show ba, Eq ba, Typeable ba, ByteArray ba) => (ba -> ba) -> [Test]) -> Test
78testGroupBackends x l =
79    Group x
80        [ Group "Bytes" (l withBytesWitness)
81        , Group "ScrubbedBytes" (l withScrubbedBytesWitness)
82#ifdef WITH_BASEMENT_SUPPORT
83        , Group "Block" (l withBlockWitness)
84        , Group "UArray" (l withUArrayWitness)
85#endif
86        ]
87
88testShowProperty :: IsProperty a
89                 => String
90                 -> (forall ba . (Show ba, Eq ba, Typeable ba, ByteArray ba) => (ba -> ba) -> ([Word8] -> String) -> a)
91                 -> Test
92testShowProperty x p =
93    Group x
94        [ Property "Bytes" (p withBytesWitness showLikeString)
95        , Property "ScrubbedBytes" (p withScrubbedBytesWitness showLikeEmptySB)
96        ]
97  where
98    showLikeString  l = show $ (chr . fromIntegral) <$> l
99    showLikeEmptySB _ = show (withScrubbedBytesWitness B.empty)
100
101base64Kats =
102    [ ("pleasure.", "cGxlYXN1cmUu")
103    , ("leasure.", "bGVhc3VyZS4=")
104    , ("easure.", "ZWFzdXJlLg==")
105    , ("asure.", "YXN1cmUu")
106    , ("sure.", "c3VyZS4=")
107    , ("", "")
108    ]
109
110base64URLKats =
111    [ ("pleasure.", "cGxlYXN1cmUu")
112    , ("leasure.", "bGVhc3VyZS4")
113    , ("easure.", "ZWFzdXJlLg")
114    , ("asure.", "YXN1cmUu")
115    , ("sure.", "c3VyZS4")
116    , ("\DC4\251\156\ETX\217~", "FPucA9l-") -- From RFC4648
117    , ("\DC4\251\156\ETX\217\DEL", "FPucA9l_")
118    , ("", "")
119    ]
120
121base16Kats =
122    [ ("this is a string", "74686973206973206120737472696e67") ]
123
124base32Kats =
125    [ ("-pleasure.", "FVYGYZLBON2XEZJO")
126    , ("pleasure.",  "OBWGKYLTOVZGKLQ=")
127    , ("leasure.",   "NRSWC43VOJSS4===")
128    , ("easure.",    "MVQXG5LSMUXA====")
129    , ("asure.",     "MFZXK4TFFY======")
130    , ("sure.",      "ON2XEZJO")
131    , ("ure.",       "OVZGKLQ=")
132    , ("re.",        "OJSS4===")
133    , ("e.",         "MUXA====")
134    , (".",          "FY======")
135    , ("",           "")
136    ]
137
138encodingTests witnessID =
139    [ Group "BASE64"
140        [ Group "encode-KAT" encodeKats64
141        , Group "decode-KAT" decodeKats64
142        ]
143    , Group "BASE64URL"
144        [ Group "encode-KAT" encodeKats64URLUnpadded
145        , Group "decode-KAT" decodeKats64URLUnpadded
146        ]
147    , Group "BASE32"
148        [ Group "encode-KAT" encodeKats32
149        , Group "decode-KAT" decodeKats32
150        ]
151    , Group "BASE16"
152        [ Group "encode-KAT" encodeKats16
153        , Group "decode-KAT" decodeKats16
154        ]
155    ]
156  where
157        encodeKats64 = fmap (toTest B.Base64) $ zip [1..] base64Kats
158        decodeKats64 = fmap (toBackTest B.Base64) $ zip [1..] base64Kats
159        encodeKats32 = fmap (toTest B.Base32) $ zip [1..] base32Kats
160        decodeKats32 = fmap (toBackTest B.Base32) $ zip [1..] base32Kats
161        encodeKats16 = fmap (toTest B.Base16) $ zip [1..] base16Kats
162        decodeKats16 = fmap (toBackTest B.Base16) $ zip [1..] base16Kats
163        encodeKats64URLUnpadded = fmap (toTest B.Base64URLUnpadded) $ zip [1..] base64URLKats
164        decodeKats64URLUnpadded = fmap (toBackTest B.Base64URLUnpadded) $ zip [1..] base64URLKats
165
166        toTest :: B.Base -> (Int, (LString, LString)) -> Test
167        toTest base (i, (inp, out)) = Property (show i) $
168            let inpbs = witnessID $ B.convertToBase base $ witnessID $ B.pack $ unS inp
169                outbs = witnessID $ B.pack $ unS out
170             in outbs === inpbs
171        toBackTest :: B.Base -> (Int, (LString, LString)) -> Test
172        toBackTest base (i, (inp, out)) = Property (show i) $
173            let inpbs = witnessID $ B.pack $ unS inp
174                outbs = B.convertFromBase base $ witnessID $ B.pack $ unS out
175             in Right inpbs === outbs
176
177-- check not to touch internal null pointer of the empty ByteString
178bsNullEncodingTest =
179    Group "BS-null"
180      [ Group "BASE64"
181        [ Property "encode-KAT" $ toTest B.Base64
182        , Property "decode-KAT" $ toBackTest B.Base64
183        ]
184      , Group "BASE32"
185        [ Property "encode-KAT" $ toTest B.Base32
186        , Property "decode-KAT" $ toBackTest B.Base32
187        ]
188      , Group "BASE16"
189        [ Property "encode-KAT" $ toTest B.Base16
190        , Property "decode-KAT" $ toBackTest B.Base16
191        ]
192      ]
193  where
194    toTest base =
195      B.convertToBase base BS.empty === BS.empty
196    toBackTest base =
197      B.convertFromBase base BS.empty === Right BS.empty
198
199parsingTests witnessID =
200    [ CheckPlan "parse" $
201        let input = witnessID $ B.pack $ unS "xx abctest"
202            abc   = witnessID $ B.pack $ unS "abc"
203            est   = witnessID $ B.pack $ unS "est"
204            result = Parse.parse ((,,) <$> Parse.take 2 <*> Parse.byte 0x20 <*> (Parse.bytes abc *> Parse.anyByte)) input
205         in case result of
206                Parse.ParseOK remaining (_,_,_) -> validate "remaining" $ est === remaining
207                _                               -> validate "unexpected result" False
208    ]
209
210main = defaultMain $ Group "memory"
211    [ testGroupBackends "basic" basicProperties
212    , bsNullEncodingTest
213    , testGroupBackends "encoding" encodingTests
214    , testGroupBackends "parsing" parsingTests
215    , testGroupBackends "hashing" $ \witnessID ->
216        [ Group "SipHash" $ SipHash.tests witnessID
217        ]
218    , testShowProperty "showing" $ \witnessID expectedShow (Words8 l) ->
219          (show . witnessID . B.pack $ l) == expectedShow l
220#ifdef WITH_BASEMENT_SUPPORT
221    , testFoundationTypes
222#endif
223    ]
224  where
225    basicProperties witnessID =
226        [ Property "unpack . pack == id" $ \(Words8 l) -> l == (B.unpack . witnessID . B.pack $ l)
227        , Property "self-eq" $ \(Words8 l) -> let b = witnessID . B.pack $ l in b == b
228        , Property "add-empty-eq" $ \(Words8 l) ->
229            let b = witnessID $ B.pack l
230             in B.append b B.empty == b
231        , Property "zero" $ \(Positive n) ->
232            let expected = witnessID $ B.pack $ replicate (fromIntegral n) 0
233             in expected == B.zero (fromIntegral n)
234        , Property "Ord" $ \(Words8 l1) (Words8 l2) ->
235            compare l1 l2 == compare (witnessID $ B.pack l1) (B.pack l2)
236        , Property "Monoid(mappend)" $ \(Words8 l1) (Words8 l2) ->
237            mappend l1 l2 == (B.unpack $ mappend (witnessID $ B.pack l1) (B.pack l2))
238        , Property "Monoid(mconcat)" $ \(SmallList l) ->
239            mconcat (fmap unWords8 l) == (B.unpack $ mconcat $ fmap (witnessID . B.pack . unWords8) l)
240        , Property "append (append a b) c == append a (append b c)" $ \(Words8 la) (Words8 lb) (Words8 lc) ->
241            let a = witnessID $ B.pack la
242                b = witnessID $ B.pack lb
243                c = witnessID $ B.pack lc
244             in B.append (B.append a b) c == B.append a (B.append b c)
245        , Property "concat l" $ \(SmallList l) ->
246            let chunks   = fmap (witnessID . B.pack . unWords8) l
247                expected = concatMap unWords8 l
248             in B.pack expected == witnessID (B.concat chunks)
249        , Property "reverse" $ \(Words8 l) ->
250            let b = witnessID (B.pack l)
251             in reverse l == B.unpack (B.reverse b)
252        , Property "cons b (reverse bs) == reverse (snoc bs b)" $ \(Words8 l) b ->
253            let a = witnessID (B.pack l)
254             in B.cons b (B.reverse a) == B.reverse (B.snoc a b)
255        , Property "all == Prelude.all" $ \(Words8 l) b ->
256            let b1 = witnessID (B.pack l)
257                p  = (/= b)
258             in B.all p b1 == all p l
259        , Property "any == Prelude.any" $ \(Words8 l) b ->
260            let b1 = witnessID (B.pack l)
261                p  = (== b)
262             in B.any p b1 == any p l
263        , Property "singleton b == pack [b]" $ \b ->
264            witnessID (B.singleton b) == B.pack [b]
265        , Property "span" $ \x (Words8 l) ->
266            let c = witnessID (B.pack l)
267                (a, b) = B.span (== x) c
268             in c == B.append a b
269        , Property "span (const True)" $ \(Words8 l) ->
270            let a = witnessID (B.pack l)
271             in B.span (const True) a == (a, B.empty)
272        , Property "span (const False)" $ \(Words8 l) ->
273            let b = witnessID (B.pack l)
274             in B.span (const False) b == (B.empty, b)
275        ]
276
277#ifdef WITH_BASEMENT_SUPPORT
278testFoundationTypes = Group "Basement"
279  [ CheckPlan "allocRet 4 _ :: UArray Int8 === 4" $ do
280      x <- pick "allocateRet 4 _" $ (B.length :: UArray Int8 -> Int) . snd <$> B.allocRet 4 (const $ return ())
281      validate "4 === x" $ x === 4
282  , CheckPlan "allocRet 4 _ :: UArray Int16 === 4" $ do
283      x <- pick "allocateRet 4 _" $ (B.length :: UArray Int16 -> Int) . snd <$> B.allocRet 4 (const $ return ())
284      validate "4 === x" $ x === 4
285  , CheckPlan "allocRet 4 _ :: UArray Int32 === 4" $ do
286      x <- pick "allocateRet 4 _" $ (B.length :: UArray Int32 -> Int) . snd <$> B.allocRet 4 (const $ return ())
287      validate "4 === x" $ x === 4
288  , CheckPlan "allocRet 4 _ :: UArray Int64 === 8" $ do
289      x <- pick "allocateRet 4 _" $ (B.length :: UArray Int64 -> Int) . snd <$> B.allocRet 4 (const $ return ())
290      validate "8 === x" $ x === 8
291  ]
292#endif
293