Util.hs

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings         #-}
{-|
Module      : Haskoin.Test.Util
Copyright   : No rights reserved
License     : UNLICENSE
Maintainer  : jprupp@protonmail.ch
Stability   : experimental
Portability : POSIX
-}
module Haskoin.Util.Arbitrary.Util
( arbitraryBS
, arbitraryBS1
, arbitraryBSn
, arbitraryBSS
, arbitraryBSS1
, arbitraryBSSn
, arbitraryMaybe
, arbitraryNetwork
, 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 qualified Data.Map.Strict       as Map
import           Data.Proxy
import qualified Data.Serialize        as S
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, S.Serialize 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 "Data.Serialize 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 Data.Serialize identity tests
testSerial ::
       (Eq a, Show a, T.Typeable a, S.Serialize a) => Gen a -> Spec
testSerial gen = do
    prop ("Data.Serialize encoding/decoding identity for " <> name) $
        forAll gen $ \x -> (S.decode . S.encode) 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 = do
    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")