haskoin-core-0.20.0: src/Haskoin/Util/Arbitrary/Util.hs
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
Module : Haskoin.Test.Util
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
-}
module Haskoin.Util.Arbitrary.Util
( arbitraryBS
, arbitraryBS1
, arbitraryBSn
, arbitraryBSS
, arbitraryBSS1
, arbitraryBSSn
, arbitraryMaybe
, arbitraryNetwork
, arbitraryUTCTime
, SerialBox(..)
, JsonBox(..)
, NetBox(..)
, ReadBox(..)
, testIdentity
, testSerial
, testRead
, testJson
, testNetJson
, arbitraryNetData
, genNetData
)
where
import Control.Monad (forM_, (<=<))
import qualified Data.Aeson as A
import qualified Data.Aeson.Encoding as A
import qualified Data.Aeson.Types as A
import Data.ByteString (ByteString, pack)
import qualified Data.ByteString.Short as BSS
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
import qualified Data.Map.Strict as Map
import Data.Proxy
import Data.Time.Clock (UTCTime (..))
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import qualified Data.Typeable as T
import Data.Word (Word32)
import Haskoin.Constants
import Test.Hspec (Spec, describe, shouldBe, shouldSatisfy)
import Test.Hspec.QuickCheck (prop)
import Test.QuickCheck
-- | Arbitrary strict 'ByteString'.
arbitraryBS :: Gen ByteString
arbitraryBS = pack <$> arbitrary
-- | Arbitrary non-empty strict 'ByteString'
arbitraryBS1 :: Gen ByteString
arbitraryBS1 = pack <$> listOf1 arbitrary
-- | Arbitrary strict 'ByteString' of a given length
arbitraryBSn :: Int -> Gen ByteString
arbitraryBSn n = pack <$> vectorOf n arbitrary
-- | Arbitrary 'ShortByteString'.
arbitraryBSS :: Gen BSS.ShortByteString
arbitraryBSS = BSS.pack <$> arbitrary
-- | Arbitrary non-empty 'ShortByteString'
arbitraryBSS1 :: Gen BSS.ShortByteString
arbitraryBSS1 = BSS.pack <$> listOf1 arbitrary
-- | Arbitrary 'ShortByteString' of a given length
arbitraryBSSn :: Int -> Gen BSS.ShortByteString
arbitraryBSSn n = BSS.pack <$> vectorOf n arbitrary
-- | Arbitrary UTCTime that generates dates after 01 Jan 1970 01:00:00 CET
arbitraryUTCTime :: Gen UTCTime
arbitraryUTCTime = do
w <- arbitrary :: Gen Word32
return $ posixSecondsToUTCTime $ realToFrac w
-- | Generate a Maybe from a Gen a
arbitraryMaybe :: Gen a -> Gen (Maybe a)
arbitraryMaybe g = frequency [ (1, return Nothing)
, (5, Just <$> g)
]
-- | Generate an Network
arbitraryNetwork :: Gen Network
arbitraryNetwork = elements allNets
-- Helpers for creating Serial and JSON Identity tests
data SerialBox =
forall a. (Show a, Eq a, T.Typeable a, Serial a) =>
SerialBox (Gen a)
data ReadBox =
forall a. (Read a, Show a, Eq a, T.Typeable a) =>
ReadBox (Gen a)
data JsonBox =
forall a. (Show a, Eq a, T.Typeable a, A.ToJSON a, A.FromJSON a) =>
JsonBox (Gen a)
data NetBox =
forall a. (Show a, Eq a, T.Typeable a) =>
NetBox
( Network -> a -> A.Value
, Network -> a -> A.Encoding
, Network -> A.Value -> A.Parser a
, Gen (Network, a))
testIdentity :: [SerialBox] -> [ReadBox] -> [JsonBox] -> [NetBox] -> Spec
testIdentity serialVals readVals jsonVals netVals = do
describe "Binary Encoding" $
forM_ serialVals $ \(SerialBox g) -> testSerial g
describe "Read/Show Encoding" $
forM_ readVals $ \(ReadBox g) -> testRead g
describe "Data.Aeson Encoding" $
forM_ jsonVals $ \(JsonBox g) -> testJson g
describe "Data.Aeson Encoding with Network" $
forM_ netVals $ \(NetBox (j,e,p,g)) -> testNetJson j e p g
-- | Generate binary identity tests
testSerial ::
(Eq a, Show a, T.Typeable a, Serial a) => Gen a -> Spec
testSerial gen =
prop ("Binary encoding/decoding identity for " <> name) $
forAll gen $ \x ->
(runGetS deserialize . runPutS . serialize) x `shouldBe` Right x
where
name = show $ T.typeRep $ proxy gen
proxy :: Gen a -> Proxy a
proxy = const Proxy
-- | Generate Read/Show identity tests
testRead ::
(Eq a, Read a, Show a, T.Typeable a) => Gen a -> Spec
testRead gen =
prop ("read/show identity for " <> name) $
forAll gen $ \x -> (read . show) x `shouldBe` x
where
name = show $ T.typeRep $ proxy gen
proxy :: Gen a -> Proxy a
proxy = const Proxy
-- | Generate Data.Aeson identity tests
testJson ::
(Eq a, Show a, T.Typeable a, A.ToJSON a, A.FromJSON a) => Gen a -> Spec
testJson gen = do
prop ("Data.Aeson toJSON/fromJSON identity for " <> name) $
forAll gen (`shouldSatisfy` jsonID)
prop ("Data.Aeson toEncoding/fromJSON identity for " <> name) $
forAll gen (`shouldSatisfy` encodingID)
where
name = show $ T.typeRep $ proxy gen
proxy :: Gen a -> Proxy a
proxy = const Proxy
jsonID x = (A.fromJSON . A.toJSON) (toMap x) == A.Success (toMap x)
encodingID x =
(A.decode . A.encodingToLazyByteString . A.toEncoding) (toMap x) ==
Just (toMap x)
-- | Generate Data.Aeson identity tests for type that need the @Network@
testNetJson ::
(Eq a, Show a, T.Typeable a)
=> (Network -> a -> A.Value)
-> (Network -> a -> A.Encoding)
-> (Network -> A.Value -> A.Parser a)
-> Gen (Network, a)
-> Spec
testNetJson j e p g = do
prop ("Data.Aeson toJSON/fromJSON identity (with network) for " <> name) $
forAll g $ \(net, x) -> dec net (encVal net x) `shouldBe` Just x
prop ("Data.Aeson toEncoding/fromJSON identity (with network) for " <> name) $
forAll g $ \(net, x) -> dec net (encEnc net x) `shouldBe` Just x
where
encVal net = A.encode . toMap . j net
encEnc net = A.encodingToLazyByteString . toMapE . e net
dec net = A.parseMaybe (p net) . fromMap <=< A.decode
name = show $ T.typeRep $ proxy j
proxy :: (Network -> a -> A.Value) -> Proxy a
proxy = const Proxy
arbitraryNetData :: Arbitrary a => Gen (Network, a)
arbitraryNetData = do
net <- arbitraryNetwork
x <- arbitrary
return (net, x)
genNetData :: Gen a -> Gen (Network, a)
genNetData gen = do
net <- arbitraryNetwork
x <- gen
return (net, x)
toMap :: a -> Map.Map String a
toMap = Map.singleton "object"
toMapE :: A.Encoding -> A.Encoding
toMapE = A.pairs . (A.pair "object")
fromMap :: Map.Map String a -> a
fromMap = (Map.! "object")