Util.hs

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# 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,
    ReadBox (..),
    JsonBox (..),
    MarshalJsonBox (..),
    SerialBox (..),
    MarshalBox (..),
    IdentityTests (..),
    testIdentity,
    testSerial,
    testRead,
    testJson,
  )
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 Data.ByteString.Lazy (fromStrict, toStrict)
import qualified Data.ByteString.Short as BSS
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
import Data.Default
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.Crypto (Ctx)
import Haskoin.Network.Constants
import Haskoin.Network.Data
import Haskoin.Util
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

instance Show Ctx where
  show _ = "Ctx"

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 MarshalJsonBox
  = forall s a.
    (Show a, Show s, Eq a, T.Typeable a, MarshalJSON s a) =>
    MarshalJsonBox (Gen (s, a))

data SerialBox
  = forall a.
    (Show a, Eq a, T.Typeable a, Serial a) =>
    SerialBox (Gen a)

data MarshalBox
  = forall s a.
    (Show a, Show s, Eq a, T.Typeable a, Marshal s a) =>
    MarshalBox (Gen (s, a))

data IdentityTests = IdentityTests
  { readTests :: [ReadBox],
    jsonTests :: [JsonBox],
    marshalJsonTests :: [MarshalJsonBox],
    serialTests :: [SerialBox],
    marshalTests :: [MarshalBox]
  }

instance Default IdentityTests where
  def =
    IdentityTests
      { readTests = [],
        jsonTests = [],
        marshalJsonTests = [],
        serialTests = [],
        marshalTests = []
      }

testIdentity :: IdentityTests -> Spec
testIdentity t = do
  describe "Read/Show Encoding" $
    forM_ t.readTests $
      \(ReadBox g) -> testRead g
  describe "Data.Aeson Encoding" $
    forM_ t.jsonTests $
      \(JsonBox g) -> testJson g
  describe "MarshalJSON Encoding" $
    forM_ t.marshalJsonTests $
      \(MarshalJsonBox g) -> testMarshalJson g
  describe "Binary Encoding" $
    forM_ t.serialTests $
      \(SerialBox g) -> testSerial g
  describe "Marshal Encoding" $
    forM_ t.marshalTests $
      \(MarshalBox g) -> testMarshal g

-- | 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 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 -> do
      (runGetL deserialize . runPutL . serialize) x `shouldBe` x
      (runGetL deserialize . fromStrict . runPutS . serialize) x `shouldBe` x
      (runGetS deserialize . runPutS . serialize) x `shouldBe` Right x
      (runGetS deserialize . toStrict . runPutL . serialize) x `shouldBe` Right x
  where
    name = show $ T.typeRep $ proxy gen
    proxy :: Gen a -> Proxy a
    proxy = const Proxy

-- | Generate Marshal identity tests
testMarshal ::
  (Eq a, Show a, Show s, T.Typeable a, Marshal s a) =>
  Gen (s, a) ->
  Spec
testMarshal gen = do
  prop ("Marshal marshalPut/marshalGet identity for " <> name) $
    forAll gen $ \(s, a) -> do
      (unmarshal s . marshal s) a `shouldBe` Right a
      (unmarshalLazy s . marshalLazy s) a `shouldBe` a
  where
    name = show $ T.typeRep $ proxy gen
    proxy :: Gen (s, 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 MarshalJSON identity tests
testMarshalJson ::
  (Eq a, Show a, Show s, T.Typeable a, MarshalJSON s a) =>
  Gen (s, a) ->
  Spec
testMarshalJson gen = do
  prop ("MarshalJSON marshalValue/unmarshalValue identity for " <> name) $
    forAll gen $
      \(s, a) -> a `shouldSatisfy` marshalJsonID s
  prop ("MarshalJSON marshalEncoding/unmarshalValue identity for " <> name) $
    forAll gen $
      \(s, a) -> a `shouldSatisfy` marshalEncodingID s
  where
    name = show $ T.typeRep $ proxy gen
    proxy :: Gen (s, a) -> Proxy a
    proxy = const Proxy
    marshalJsonID s a =
      A.parseMaybe (unmarshalValue s) (marshalValue s a) == Just a
    marshalEncodingID s a = unmarshalJSON s (marshalJSON s a) == Just a

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")