{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}

module Test.Crypto.Util (
  -- * CBOR
  FromCBOR (..),
  ToCBOR (..),
  prop_cbor,
  prop_cbor_size,
  prop_cbor_with,
  prop_cbor_valid,
  prop_cbor_roundtrip,
  prop_raw_serialise,
  prop_raw_deserialise,
  prop_size_serialise,
  prop_cbor_direct_vs_class,
  prop_bad_cbor_bytes,

  -- * NoThunks
  prop_no_thunks,
  prop_no_thunks_IO,
  prop_no_thunks_IO_from,
  prop_no_thunks_IO_with,

  -- * Test Seed
  TestSeed (..),
  withTestSeed,
  testSeedToChaCha,
  nullTestSeed,

  -- * Seeds
  SizedSeed,
  unSizedSeed,
  arbitrarySeedOfSize,
  arbitrarySeedBytesOfSize,

  -- * test messages for signings
  Message (..),

  -- * Test generation and shrinker helpers
  BadInputFor,
  genBadInputFor,
  shrinkBadInputFor,
  showBadInputFor,

  -- * Formatting
  hexBS,

  -- * Helpers for testing IO actions
  noExceptionsThrown,
  doesNotThrow,

  -- * Direct ser/deser helpers
  directSerialiseToBS,
  directDeserialiseFromBS,

  -- * Error handling
  eitherShowError,

  -- * Locking
  Lock,
  withLock,
  mkLock,
)
where

import Cardano.Binary (
  Decoder,
  Encoding,
  FromCBOR (fromCBOR),
  Range (Range),
  ToCBOR (toCBOR),
  decodeFull,
  decodeFullDecoder,
  encodedSizeExpr,
  hi,
  lo,
  serialize,
  szGreedy,
  szSimplify,
 )
import Cardano.Crypto.DSIGN.Class (
  DSIGNAlgorithm (SigDSIGN, SignKeyDSIGN, VerKeyDSIGN),
  sizeSigDSIGN,
  sizeSignKeyDSIGN,
  sizeVerKeyDSIGN,
 )
import Cardano.Crypto.DirectSerialise
import Cardano.Crypto.Hash.Class (Hash, HashAlgorithm, sizeHash)
import Cardano.Crypto.Libsodium.Memory (
  allocaBytes,
  packByteStringCStringLen,
  unpackByteStringCStringLen,
 )
import Cardano.Crypto.Seed (Seed, mkSeedFromBytes)
import Cardano.Crypto.Util (SignableRepresentation (..))
import Codec.CBOR.FlatTerm (
  toFlatTerm,
  validFlatTerm,
 )
import Codec.CBOR.Write (
  toStrictByteString,
 )
import Control.Concurrent.Class.MonadMVar (
  MVar,
  newMVar,
  withMVar,
 )
import Control.Monad (guard, when)
import Control.Monad.Class.MonadST (MonadST)
import Control.Monad.Class.MonadThrow (MonadThrow)
import Crypto.Random (
  ChaChaDRG,
  MonadPseudoRandom,
  drgNewTest,
  withDRG,
 )
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Char8 as BS8
import Data.Kind (Type)
import Data.Proxy (Proxy (Proxy))
import Data.Word (Word64)
import Formatting.Buildable (Buildable (..), build)
import GHC.Exts (fromList, fromListN, toList)
import GHC.Stack (HasCallStack)
import GHC.TypeLits (KnownNat, Nat, natVal)
import NoThunks.Class (NoThunks, noThunks, unsafeNoThunks)
import Numeric.Natural (Natural)
import Test.QuickCheck (
  Arbitrary,
  Gen,
  Property,
  arbitrary,
  arbitraryBoundedIntegral,
  checkCoverage,
  counterexample,
  cover,
  forAllBlind,
  ioProperty,
  property,
  shrink,
  vector,
  (.&&.),
  (===),
 )
import qualified Test.QuickCheck.Gen as Gen
import Text.Show.Pretty (ppShow)

--------------------------------------------------------------------------------
-- Connecting MonadRandom to Gen
--------------------------------------------------------------------------------
newtype TestSeed
  = TestSeed
  { TestSeed -> (Word64, Word64, Word64, Word64, Word64)
getTestSeed :: (Word64, Word64, Word64, Word64, Word64)
  }
  deriving (Int -> TestSeed -> ShowS
[TestSeed] -> ShowS
TestSeed -> String
(Int -> TestSeed -> ShowS)
-> (TestSeed -> String) -> ([TestSeed] -> ShowS) -> Show TestSeed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestSeed -> ShowS
showsPrec :: Int -> TestSeed -> ShowS
$cshow :: TestSeed -> String
show :: TestSeed -> String
$cshowList :: [TestSeed] -> ShowS
showList :: [TestSeed] -> ShowS
Show, TestSeed -> TestSeed -> Bool
(TestSeed -> TestSeed -> Bool)
-> (TestSeed -> TestSeed -> Bool) -> Eq TestSeed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestSeed -> TestSeed -> Bool
== :: TestSeed -> TestSeed -> Bool
$c/= :: TestSeed -> TestSeed -> Bool
/= :: TestSeed -> TestSeed -> Bool
Eq, Eq TestSeed
Eq TestSeed =>
(TestSeed -> TestSeed -> Ordering)
-> (TestSeed -> TestSeed -> Bool)
-> (TestSeed -> TestSeed -> Bool)
-> (TestSeed -> TestSeed -> Bool)
-> (TestSeed -> TestSeed -> Bool)
-> (TestSeed -> TestSeed -> TestSeed)
-> (TestSeed -> TestSeed -> TestSeed)
-> Ord TestSeed
TestSeed -> TestSeed -> Bool
TestSeed -> TestSeed -> Ordering
TestSeed -> TestSeed -> TestSeed
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TestSeed -> TestSeed -> Ordering
compare :: TestSeed -> TestSeed -> Ordering
$c< :: TestSeed -> TestSeed -> Bool
< :: TestSeed -> TestSeed -> Bool
$c<= :: TestSeed -> TestSeed -> Bool
<= :: TestSeed -> TestSeed -> Bool
$c> :: TestSeed -> TestSeed -> Bool
> :: TestSeed -> TestSeed -> Bool
$c>= :: TestSeed -> TestSeed -> Bool
>= :: TestSeed -> TestSeed -> Bool
$cmax :: TestSeed -> TestSeed -> TestSeed
max :: TestSeed -> TestSeed -> TestSeed
$cmin :: TestSeed -> TestSeed -> TestSeed
min :: TestSeed -> TestSeed -> TestSeed
Ord, Typeable TestSeed
Typeable TestSeed =>
(forall s. Decoder s TestSeed)
-> (Proxy TestSeed -> Text) -> FromCBOR TestSeed
Proxy TestSeed -> Text
forall s. Decoder s TestSeed
forall a.
Typeable a =>
(forall s. Decoder s a) -> (Proxy a -> Text) -> FromCBOR a
$cfromCBOR :: forall s. Decoder s TestSeed
fromCBOR :: forall s. Decoder s TestSeed
$clabel :: Proxy TestSeed -> Text
label :: Proxy TestSeed -> Text
FromCBOR, Typeable TestSeed
Typeable TestSeed =>
(TestSeed -> Encoding)
-> ((forall t. ToCBOR t => Proxy t -> Size)
    -> Proxy TestSeed -> Size)
-> ((forall t. ToCBOR t => Proxy t -> Size)
    -> Proxy [TestSeed] -> Size)
-> ToCBOR TestSeed
TestSeed -> Encoding
(forall t. ToCBOR t => Proxy t -> Size) -> Proxy [TestSeed] -> Size
(forall t. ToCBOR t => Proxy t -> Size) -> Proxy TestSeed -> Size
forall a.
Typeable a =>
(a -> Encoding)
-> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy a -> Size)
-> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy [a] -> Size)
-> ToCBOR a
$ctoCBOR :: TestSeed -> Encoding
toCBOR :: TestSeed -> Encoding
$cencodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size) -> Proxy TestSeed -> Size
encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size) -> Proxy TestSeed -> Size
$cencodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size) -> Proxy [TestSeed] -> Size
encodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size) -> Proxy [TestSeed] -> Size
ToCBOR)

withTestSeed :: TestSeed -> MonadPseudoRandom ChaChaDRG a -> a
withTestSeed :: forall a. TestSeed -> MonadPseudoRandom ChaChaDRG a -> a
withTestSeed TestSeed
s = (a, ChaChaDRG) -> a
forall a b. (a, b) -> a
fst ((a, ChaChaDRG) -> a)
-> (MonadPseudoRandom ChaChaDRG a -> (a, ChaChaDRG))
-> MonadPseudoRandom ChaChaDRG a
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChaChaDRG -> MonadPseudoRandom ChaChaDRG a -> (a, ChaChaDRG)
forall gen a. DRG gen => gen -> MonadPseudoRandom gen a -> (a, gen)
withDRG ((Word64, Word64, Word64, Word64, Word64) -> ChaChaDRG
drgNewTest ((Word64, Word64, Word64, Word64, Word64) -> ChaChaDRG)
-> (Word64, Word64, Word64, Word64, Word64) -> ChaChaDRG
forall a b. (a -> b) -> a -> b
$ TestSeed -> (Word64, Word64, Word64, Word64, Word64)
getTestSeed TestSeed
s)

testSeedToChaCha :: TestSeed -> ChaChaDRG
testSeedToChaCha :: TestSeed -> ChaChaDRG
testSeedToChaCha = (Word64, Word64, Word64, Word64, Word64) -> ChaChaDRG
drgNewTest ((Word64, Word64, Word64, Word64, Word64) -> ChaChaDRG)
-> (TestSeed -> (Word64, Word64, Word64, Word64, Word64))
-> TestSeed
-> ChaChaDRG
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSeed -> (Word64, Word64, Word64, Word64, Word64)
getTestSeed

nullTestSeed :: TestSeed
nullTestSeed :: TestSeed
nullTestSeed = (Word64, Word64, Word64, Word64, Word64) -> TestSeed
TestSeed (Word64
0, Word64
0, Word64
0, Word64
0, Word64
0)

instance Arbitrary TestSeed where
  arbitrary :: Gen TestSeed
arbitrary =
    (Word64, Word64, Word64, Word64, Word64) -> TestSeed
TestSeed ((Word64, Word64, Word64, Word64, Word64) -> TestSeed)
-> Gen (Word64, Word64, Word64, Word64, Word64) -> Gen TestSeed
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((,,,,) (Word64
 -> Word64
 -> Word64
 -> Word64
 -> Word64
 -> (Word64, Word64, Word64, Word64, Word64))
-> Gen Word64
-> Gen
     (Word64
      -> Word64
      -> Word64
      -> Word64
      -> (Word64, Word64, Word64, Word64, Word64))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word64
gen Gen
  (Word64
   -> Word64
   -> Word64
   -> Word64
   -> (Word64, Word64, Word64, Word64, Word64))
-> Gen Word64
-> Gen
     (Word64
      -> Word64 -> Word64 -> (Word64, Word64, Word64, Word64, Word64))
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Word64
gen Gen
  (Word64
   -> Word64 -> Word64 -> (Word64, Word64, Word64, Word64, Word64))
-> Gen Word64
-> Gen
     (Word64 -> Word64 -> (Word64, Word64, Word64, Word64, Word64))
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Word64
gen Gen (Word64 -> Word64 -> (Word64, Word64, Word64, Word64, Word64))
-> Gen Word64
-> Gen (Word64 -> (Word64, Word64, Word64, Word64, Word64))
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Word64
gen Gen (Word64 -> (Word64, Word64, Word64, Word64, Word64))
-> Gen Word64 -> Gen (Word64, Word64, Word64, Word64, Word64)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Word64
gen)
    where
      gen :: Gen Word64
      gen :: Gen Word64
gen = Gen Word64
forall a. (Bounded a, Integral a) => Gen a
arbitraryBoundedIntegral
  shrink :: TestSeed -> [TestSeed]
shrink = [TestSeed] -> TestSeed -> [TestSeed]
forall a b. a -> b -> a
const []

--------------------------------------------------------------------------------
-- Seeds
--------------------------------------------------------------------------------

newtype SizedSeed (n :: Nat) = SizedSeed {forall (n :: Nat). SizedSeed n -> Seed
unSizedSeed :: Seed} deriving (Int -> SizedSeed n -> ShowS
[SizedSeed n] -> ShowS
SizedSeed n -> String
(Int -> SizedSeed n -> ShowS)
-> (SizedSeed n -> String)
-> ([SizedSeed n] -> ShowS)
-> Show (SizedSeed n)
forall (n :: Nat). Int -> SizedSeed n -> ShowS
forall (n :: Nat). [SizedSeed n] -> ShowS
forall (n :: Nat). SizedSeed n -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall (n :: Nat). Int -> SizedSeed n -> ShowS
showsPrec :: Int -> SizedSeed n -> ShowS
$cshow :: forall (n :: Nat). SizedSeed n -> String
show :: SizedSeed n -> String
$cshowList :: forall (n :: Nat). [SizedSeed n] -> ShowS
showList :: [SizedSeed n] -> ShowS
Show)

instance KnownNat n => Arbitrary (SizedSeed n) where
  arbitrary :: Gen (SizedSeed n)
arbitrary = Seed -> SizedSeed n
forall (n :: Nat). Seed -> SizedSeed n
SizedSeed (Seed -> SizedSeed n) -> Gen Seed -> Gen (SizedSeed n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word -> Gen Seed
arbitrarySeedOfSize (Integer -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word) -> Integer -> Word
forall a b. (a -> b) -> a -> b
$ Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n
forall {k} (t :: k). Proxy t
Proxy :: Proxy n))

arbitrarySeedOfSize :: Word -> Gen Seed
arbitrarySeedOfSize :: Word -> Gen Seed
arbitrarySeedOfSize Word
sz =
  ByteString -> Seed
mkSeedFromBytes (ByteString -> Seed) -> Gen ByteString -> Gen Seed
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word -> Gen ByteString
arbitrarySeedBytesOfSize Word
sz

arbitrarySeedBytesOfSize :: Word -> Gen ByteString
arbitrarySeedBytesOfSize :: Word -> Gen ByteString
arbitrarySeedBytesOfSize Word
sz =
  [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> Gen [Word8] -> Gen ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen [Word8]
forall a. Arbitrary a => Int -> Gen [a]
vector (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
sz)

--------------------------------------------------------------------------------
-- Messages to sign
--------------------------------------------------------------------------------

newtype Message = Message {Message -> ByteString
messageBytes :: ByteString}
  deriving (Message -> Message -> Bool
(Message -> Message -> Bool)
-> (Message -> Message -> Bool) -> Eq Message
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Message -> Message -> Bool
== :: Message -> Message -> Bool
$c/= :: Message -> Message -> Bool
/= :: Message -> Message -> Bool
Eq, Int -> Message -> ShowS
[Message] -> ShowS
Message -> String
(Int -> Message -> ShowS)
-> (Message -> String) -> ([Message] -> ShowS) -> Show Message
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Message -> ShowS
showsPrec :: Int -> Message -> ShowS
$cshow :: Message -> String
show :: Message -> String
$cshowList :: [Message] -> ShowS
showList :: [Message] -> ShowS
Show, Message -> ByteString
(Message -> ByteString) -> SignableRepresentation Message
forall a. (a -> ByteString) -> SignableRepresentation a
$cgetSignableRepresentation :: Message -> ByteString
getSignableRepresentation :: Message -> ByteString
SignableRepresentation)

instance Arbitrary Message where
  arbitrary :: Gen Message
arbitrary = ByteString -> Message
Message (ByteString -> Message)
-> ([Word8] -> ByteString) -> [Word8] -> Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
BS.pack ([Word8] -> Message) -> Gen [Word8] -> Gen Message
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [Word8]
forall a. Arbitrary a => Gen a
arbitrary
  shrink :: Message -> [Message]
shrink = ([Word8] -> Message) -> [[Word8]] -> [Message]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> Message
Message (ByteString -> Message)
-> ([Word8] -> ByteString) -> [Word8] -> Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
BS.pack) ([[Word8]] -> [Message])
-> (Message -> [[Word8]]) -> Message -> [Message]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> [[Word8]]
forall a. Arbitrary a => a -> [a]
shrink ([Word8] -> [[Word8]])
-> (Message -> [Word8]) -> Message -> [[Word8]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack (ByteString -> [Word8])
-> (Message -> ByteString) -> Message -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> ByteString
messageBytes

--------------------------------------------------------------------------------
-- Serialisation properties
--------------------------------------------------------------------------------

prop_cbor ::
  (ToCBOR a, FromCBOR a, Eq a, Show a) =>
  a -> Property
prop_cbor :: forall a. (ToCBOR a, FromCBOR a, Eq a, Show a) => a -> Property
prop_cbor = (a -> Encoding) -> (forall s. Decoder s a) -> a -> Property
forall a.
(Eq a, Show a) =>
(a -> Encoding) -> (forall s. Decoder s a) -> a -> Property
prop_cbor_with a -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Decoder s a
forall s. Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR

prop_cbor_size :: forall a. ToCBOR a => a -> Property
prop_cbor_size :: forall a. ToCBOR a => a -> Property
prop_cbor_size a
a =
  String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (Nat -> String
forall a. Show a => a -> String
show Nat
lo String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ≰ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Nat -> String
forall a. Show a => a -> String
show Nat
len) (Nat
lo Nat -> Nat -> Bool
forall a. Ord a => a -> a -> Bool
<= Nat
len)
    Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (Nat -> String
forall a. Show a => a -> String
show Nat
len String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ≰ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Nat -> String
forall a. Show a => a -> String
show Nat
hi) (Nat
len Nat -> Nat -> Bool
forall a. Ord a => a -> a -> Bool
<= Nat
hi)
  where
    len, lo, hi :: Natural
    len :: Nat
len = Int -> Nat
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Nat) -> Int -> Nat
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length (Encoding -> ByteString
toStrictByteString (a -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR a
a))
    Range {Nat
lo :: forall b. Range b -> b
lo :: Nat
lo, Nat
hi :: forall b. Range b -> b
hi :: Nat
hi} =
      case Size -> Either Size (Range Nat)
szSimplify (Size -> Either Size (Range Nat))
-> Size -> Either Size (Range Nat)
forall a b. (a -> b) -> a -> b
$ (forall t. ToCBOR t => Proxy t -> Size) -> Proxy a -> Size
forall a.
ToCBOR a =>
(forall t. ToCBOR t => Proxy t -> Size) -> Proxy a -> Size
encodedSizeExpr Proxy t -> Size
forall t. ToCBOR t => Proxy t -> Size
szGreedy (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a) of
        Right Range Nat
x -> Range Nat
x
        Left Size
err -> String -> Range Nat
forall a. HasCallStack => String -> a
error (String -> Range Nat) -> (Size -> String) -> Size -> Range Nat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> String
forall a. Show a => a -> String
show (Builder -> String) -> (Size -> Builder) -> Size -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Size -> Builder
forall p. Buildable p => p -> Builder
build (Size -> Range Nat) -> Size -> Range Nat
forall a b. (a -> b) -> a -> b
$ Size
err

prop_cbor_with ::
  (Eq a, Show a) =>
  (a -> Encoding) ->
  (forall s. Decoder s a) ->
  a ->
  Property
prop_cbor_with :: forall a.
(Eq a, Show a) =>
(a -> Encoding) -> (forall s. Decoder s a) -> a -> Property
prop_cbor_with a -> Encoding
encoder forall s. Decoder s a
decoder a
x =
  (a -> Encoding) -> a -> Property
forall a. (a -> Encoding) -> a -> Property
prop_cbor_valid a -> Encoding
encoder a
x
    Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. (a -> Encoding) -> (forall s. Decoder s a) -> a -> Property
forall a.
(Eq a, Show a) =>
(a -> Encoding) -> (forall s. Decoder s a) -> a -> Property
prop_cbor_roundtrip a -> Encoding
encoder Decoder s a
forall s. Decoder s a
decoder a
x

prop_cbor_valid :: (a -> Encoding) -> a -> Property
prop_cbor_valid :: forall a. (a -> Encoding) -> a -> Property
prop_cbor_valid a -> Encoding
encoder a
x =
  String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
errmsg (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
    FlatTerm -> Bool
validFlatTerm FlatTerm
term
  where
    term :: FlatTerm
term = Encoding -> FlatTerm
toFlatTerm Encoding
encoding
    encoding :: Encoding
encoding = a -> Encoding
encoder a
x
    errmsg :: String
errmsg =
      String
"invalid flat term "
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ FlatTerm -> String
forall a. Show a => a -> String
show FlatTerm
term
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" from encoding "
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ Encoding -> String
forall a. Show a => a -> String
show Encoding
encoding

-- Written like this so that an Eq DeserialiseFailure is not required.
prop_cbor_roundtrip ::
  (Eq a, Show a) =>
  (a -> Encoding) ->
  (forall s. Decoder s a) ->
  a ->
  Property
prop_cbor_roundtrip :: forall a.
(Eq a, Show a) =>
(a -> Encoding) -> (forall s. Decoder s a) -> a -> Property
prop_cbor_roundtrip a -> Encoding
encoder forall s. Decoder s a
decoder a
x =
  case Text
-> (forall s. Decoder s a) -> ByteString -> Either DecoderError a
forall a.
Text
-> (forall s. Decoder s a) -> ByteString -> Either DecoderError a
decodeFullDecoder Text
"" Decoder s a
forall s. Decoder s a
decoder (Encoding -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize (a -> Encoding
encoder a
x)) of
    Right a
y -> a
y a -> a -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== a
x
    Left DecoderError
err -> String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (DecoderError -> String
forall a. Show a => a -> String
show DecoderError
err) (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False)

prop_raw_serialise ::
  (Eq a, Show a) =>
  (a -> ByteString) ->
  (ByteString -> Maybe a) ->
  a ->
  Property
prop_raw_serialise :: forall a.
(Eq a, Show a) =>
(a -> ByteString) -> (ByteString -> Maybe a) -> a -> Property
prop_raw_serialise a -> ByteString
serialise ByteString -> Maybe a
deserialise a
x =
  case ByteString -> Maybe a
deserialise (a -> ByteString
serialise a
x) of
    Just a
y -> a
y a -> a -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== a
x
    Maybe a
Nothing -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False

prop_raw_deserialise ::
  forall (a :: Type).
  Show a =>
  (ByteString -> Maybe a) ->
  BadInputFor a ->
  Property
prop_raw_deserialise :: forall a.
Show a =>
(ByteString -> Maybe a) -> BadInputFor a -> Property
prop_raw_deserialise ByteString -> Maybe a
deserialise (BadInputFor Int
forbiddenLen ByteString
bs) =
  Property -> Property
forall prop. Testable prop => prop -> Property
checkCoverage
    (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
50.0 (ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
forbiddenLen) String
"too long"
    (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
50.0 (ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
forbiddenLen) String
"too short"
    (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ case ByteString -> Maybe a
deserialise ByteString
bs of
      Maybe a
Nothing -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
      Just a
x -> String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (a -> String
forall a. Show a => a -> String
ppShow a
x) Bool
False

prop_bad_cbor_bytes ::
  forall (a :: Type).
  (Show a, FromCBOR a) =>
  BadInputFor a ->
  Property
prop_bad_cbor_bytes :: forall a. (Show a, FromCBOR a) => BadInputFor a -> Property
prop_bad_cbor_bytes (BadInputFor Int
forbiddenLen ByteString
bs) =
  Property -> Property
forall prop. Testable prop => prop -> Property
checkCoverage
    (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
50.0 (ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
forbiddenLen) String
"too long"
    (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
50.0 (ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
forbiddenLen) String
"too short"
    (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ case ByteString -> Either DecoderError a
forall a. FromCBOR a => ByteString -> Either DecoderError a
decodeFull (ByteString -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize ByteString
bs) of
      Left DecoderError
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
      Right (a
x :: a) -> String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"FromCBOR: \n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
ppShow a
x) Bool
False

-- | The crypto algorithm classes have direct encoding functions, and the key
-- types are also typically a member of the 'ToCBOR' class. Where a 'ToCBOR'
-- instance is provided then these should match.
prop_cbor_direct_vs_class ::
  ToCBOR a =>
  (a -> Encoding) ->
  a ->
  Property
prop_cbor_direct_vs_class :: forall a. ToCBOR a => (a -> Encoding) -> a -> Property
prop_cbor_direct_vs_class a -> Encoding
encoder a
x =
  Encoding -> FlatTerm
toFlatTerm (a -> Encoding
encoder a
x) FlatTerm -> FlatTerm -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Encoding -> FlatTerm
toFlatTerm (a -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR a
x)

prop_size_serialise :: (a -> ByteString) -> Word -> a -> Property
prop_size_serialise :: forall a. (a -> ByteString) -> Word -> a -> Property
prop_size_serialise a -> ByteString
serialise Word
size a
x =
  ByteString -> Int
BS.length (a -> ByteString
serialise a
x) Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
size

--------------------------------------------------------------------------------
-- NoThunks
--------------------------------------------------------------------------------

-- | When forcing the given value to WHNF, it may no longer contain thunks.
prop_no_thunks :: NoThunks a => a -> Property
prop_no_thunks :: forall a. NoThunks a => a -> Property
prop_no_thunks !a
a = case a -> Maybe ThunkInfo
forall a. NoThunks a => a -> Maybe ThunkInfo
unsafeNoThunks a
a of
  Maybe ThunkInfo
Nothing -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
  Just ThunkInfo
msg -> String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (ThunkInfo -> String
forall a. Show a => a -> String
show ThunkInfo
msg) (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False)

prop_no_thunks_IO :: NoThunks a => IO a -> IO Property
prop_no_thunks_IO :: forall a. NoThunks a => IO a -> IO Property
prop_no_thunks_IO IO a
a =
  IO a
a IO a -> (a -> IO (Maybe ThunkInfo)) -> IO (Maybe ThunkInfo)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Context -> a -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks [] IO (Maybe ThunkInfo)
-> (Maybe ThunkInfo -> IO Property) -> IO Property
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe ThunkInfo
Nothing -> Property -> IO Property
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
    Just ThunkInfo
msg -> Property -> IO Property
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$! String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (ThunkInfo -> String
forall a. Show a => a -> String
show ThunkInfo
msg) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$! Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False

prop_no_thunks_IO_from :: NoThunks a => (b -> IO a) -> b -> Property
prop_no_thunks_IO_from :: forall a b. NoThunks a => (b -> IO a) -> b -> Property
prop_no_thunks_IO_from b -> IO a
mkX b
y = IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
  IO a -> IO Property
forall a. NoThunks a => IO a -> IO Property
prop_no_thunks_IO (b -> IO a
mkX b
y)

prop_no_thunks_IO_with :: NoThunks a => Gen (IO a) -> Property
prop_no_thunks_IO_with :: forall a. NoThunks a => Gen (IO a) -> Property
prop_no_thunks_IO_with Gen (IO a)
mkX =
  Gen (IO a) -> (IO a -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (IO a)
mkX (IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property)
-> (IO a -> IO Property) -> IO a -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO Property
forall a. NoThunks a => IO a -> IO Property
prop_no_thunks_IO)

--------------------------------------------------------------------------------
-- Helpers for property testing
--------------------------------------------------------------------------------

-- Essentially a ByteString carrying around the length it's not allowed to be.
-- This is annoying, but so's QuickCheck sometimes.
data BadInputFor (a :: Type) = BadInputFor
  { forall a. BadInputFor a -> Int
_badInputExpectedLength :: Int
  , forall a. BadInputFor a -> ByteString
_badInputBytes :: ByteString
  }
  deriving (BadInputFor a -> BadInputFor a -> Bool
(BadInputFor a -> BadInputFor a -> Bool)
-> (BadInputFor a -> BadInputFor a -> Bool) -> Eq (BadInputFor a)
forall a. BadInputFor a -> BadInputFor a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. BadInputFor a -> BadInputFor a -> Bool
== :: BadInputFor a -> BadInputFor a -> Bool
$c/= :: forall a. BadInputFor a -> BadInputFor a -> Bool
/= :: BadInputFor a -> BadInputFor a -> Bool
Eq)

instance Show (BadInputFor a) where
  show :: BadInputFor a -> String
show = BadInputFor a -> String
forall a. BadInputFor a -> String
showBadInputFor

instance HashAlgorithm h => Arbitrary (BadInputFor (Hash h a)) where
  arbitrary :: Gen (BadInputFor (Hash h a))
arbitrary = Int -> Gen (BadInputFor (Hash h a))
forall a. Int -> Gen (BadInputFor a)
genBadInputFor (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy h -> Word
forall h (proxy :: * -> *). HashAlgorithm h => proxy h -> Word
sizeHash (Proxy h
forall {k} (t :: k). Proxy t
Proxy :: Proxy h)))
  shrink :: BadInputFor (Hash h a) -> [BadInputFor (Hash h a)]
shrink = BadInputFor (Hash h a) -> [BadInputFor (Hash h a)]
forall a. BadInputFor a -> [BadInputFor a]
shrinkBadInputFor

instance DSIGNAlgorithm v => Arbitrary (BadInputFor (VerKeyDSIGN v)) where
  arbitrary :: Gen (BadInputFor (VerKeyDSIGN v))
arbitrary = Int -> Gen (BadInputFor (VerKeyDSIGN v))
forall a. Int -> Gen (BadInputFor a)
genBadInputFor (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy v -> Word
forall v (proxy :: * -> *). DSIGNAlgorithm v => proxy v -> Word
sizeVerKeyDSIGN (Proxy v
forall {k} (t :: k). Proxy t
Proxy :: Proxy v)))
  shrink :: BadInputFor (VerKeyDSIGN v) -> [BadInputFor (VerKeyDSIGN v)]
shrink = BadInputFor (VerKeyDSIGN v) -> [BadInputFor (VerKeyDSIGN v)]
forall a. BadInputFor a -> [BadInputFor a]
shrinkBadInputFor

instance DSIGNAlgorithm v => Arbitrary (BadInputFor (SignKeyDSIGN v)) where
  arbitrary :: Gen (BadInputFor (SignKeyDSIGN v))
arbitrary = Int -> Gen (BadInputFor (SignKeyDSIGN v))
forall a. Int -> Gen (BadInputFor a)
genBadInputFor (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy v -> Word
forall v (proxy :: * -> *). DSIGNAlgorithm v => proxy v -> Word
sizeSignKeyDSIGN (Proxy v
forall {k} (t :: k). Proxy t
Proxy :: Proxy v)))
  shrink :: BadInputFor (SignKeyDSIGN v) -> [BadInputFor (SignKeyDSIGN v)]
shrink = BadInputFor (SignKeyDSIGN v) -> [BadInputFor (SignKeyDSIGN v)]
forall a. BadInputFor a -> [BadInputFor a]
shrinkBadInputFor

instance DSIGNAlgorithm v => Arbitrary (BadInputFor (SigDSIGN v)) where
  arbitrary :: Gen (BadInputFor (SigDSIGN v))
arbitrary = Int -> Gen (BadInputFor (SigDSIGN v))
forall a. Int -> Gen (BadInputFor a)
genBadInputFor (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy v -> Word
forall v (proxy :: * -> *). DSIGNAlgorithm v => proxy v -> Word
sizeSigDSIGN (Proxy v
forall {k} (t :: k). Proxy t
Proxy :: Proxy v)))
  shrink :: BadInputFor (SigDSIGN v) -> [BadInputFor (SigDSIGN v)]
shrink = BadInputFor (SigDSIGN v) -> [BadInputFor (SigDSIGN v)]
forall a. BadInputFor a -> [BadInputFor a]
shrinkBadInputFor

-- Coercion around a phantom parameter here is dangerous, as there's an implicit
-- relation between it and the forbidden length. We ensure this is impossible.
type role BadInputFor nominal

-- Needed instead of an Arbitrary instance, as there's no (good) way of knowing
-- what our forbidden (i.e. correct) length is.
genBadInputFor ::
  forall (a :: Type).
  Int ->
  Gen (BadInputFor a)
genBadInputFor :: forall a. Int -> Gen (BadInputFor a)
genBadInputFor Int
forbiddenLen =
  Int -> ByteString -> BadInputFor a
forall a. Int -> ByteString -> BadInputFor a
BadInputFor Int
forbiddenLen (ByteString -> BadInputFor a)
-> Gen ByteString -> Gen (BadInputFor a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Gen ByteString] -> Gen ByteString
forall a. HasCallStack => [Gen a] -> Gen a
Gen.oneof [Gen ByteString
tooLow, Gen ByteString
tooHigh]
  where
    tooLow :: Gen ByteString
    tooLow :: Gen ByteString
tooLow = do
      Int
len <- (Int, Int) -> Gen Int
Gen.chooseInt (Int
0, Int
forbiddenLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      Int -> [Item ByteString] -> ByteString
forall l. IsList l => Int -> [Item l] -> l
fromListN Int
len ([Word8] -> ByteString) -> Gen [Word8] -> Gen ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen Word8 -> Gen [Word8]
forall a. Int -> Gen a -> Gen [a]
Gen.vectorOf Int
len Gen Word8
forall a. Arbitrary a => Gen a
arbitrary
    tooHigh :: Gen ByteString
    tooHigh :: Gen ByteString
tooHigh = do
      Int
len <- (Int, Int) -> Gen Int
Gen.chooseInt (Int
forbiddenLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
forbiddenLen Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2)
      Int -> [Item ByteString] -> ByteString
forall l. IsList l => Int -> [Item l] -> l
fromListN Int
len ([Word8] -> ByteString) -> Gen [Word8] -> Gen ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen Word8 -> Gen [Word8]
forall a. Int -> Gen a -> Gen [a]
Gen.vectorOf Int
len Gen Word8
forall a. Arbitrary a => Gen a
arbitrary

-- This ensures we don't \'shrink out of case\': we shrink too-longs to
-- (smaller) too-longs, and too-shorts to (smaller) too-shorts.
shrinkBadInputFor ::
  forall (a :: Type).
  BadInputFor a ->
  [BadInputFor a]
shrinkBadInputFor :: forall a. BadInputFor a -> [BadInputFor a]
shrinkBadInputFor (BadInputFor Int
len ByteString
bs) =
  Int -> ByteString -> BadInputFor a
forall a. Int -> ByteString -> BadInputFor a
BadInputFor Int
len (ByteString -> BadInputFor a) -> [ByteString] -> [BadInputFor a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    ByteString
bs' <- [Word8] -> ByteString
[Item ByteString] -> ByteString
forall l. IsList l => [Item l] -> l
fromList ([Word8] -> ByteString) -> [[Word8]] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Word8] -> [[Word8]]
forall a. Arbitrary a => a -> [a]
shrink (ByteString -> [Item ByteString]
forall l. IsList l => l -> [Item l]
toList ByteString
bs)
    Bool -> [()] -> [()]
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
len) (Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString -> Int
BS.length ByteString
bs' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
len))
    ByteString -> [ByteString]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs'

-- This shows only the ByteString, in hex.
showBadInputFor ::
  forall (a :: Type).
  BadInputFor a ->
  String
showBadInputFor :: forall a. BadInputFor a -> String
showBadInputFor (BadInputFor Int
len ByteString
bs) =
  String
"BadInputFor [Expected length: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
len String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", Bytes: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
hexBS ByteString
bs String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"]"

hexBS :: ByteString -> String
hexBS :: ByteString -> String
hexBS ByteString
bs =
  String
"0x" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
BS8.unpack (ByteString -> ByteString
Base16.encode ByteString
bs) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" (length " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (ByteString -> Int
BS.length ByteString
bs) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"

-- | Return a property that always succeeds in some monad (typically 'IO').
-- This is useful to express that we are only interested in whether the side
-- effects of the preceding actions caused any exceptions or not - if they
-- did, then the test will fail because of it, but if they did not, then
-- 'noExceptionsThrown' will be reached, and the test will succeed.
noExceptionsThrown :: Applicative m => m Property
noExceptionsThrown :: forall (m :: * -> *). Applicative m => m Property
noExceptionsThrown = Property -> m Property
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True)

-- | Chain monadic action with 'noExceptionsThrown' to express that we only
-- want to make sure that the action does not throw any exceptions, but we are
-- not interested in its result.
doesNotThrow :: Applicative m => m a -> m Property
doesNotThrow :: forall (m :: * -> *) a. Applicative m => m a -> m Property
doesNotThrow = (m a -> m Property -> m Property
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m Property
forall (m :: * -> *). Applicative m => m Property
noExceptionsThrown)

newtype Lock = Lock (MVar IO ())

withLock :: Lock -> IO a -> IO a
withLock :: forall a. Lock -> IO a -> IO a
withLock (Lock MVar IO ()
v) = MVar IO () -> (() -> IO a) -> IO a
forall a b. MVar IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b.
MonadMVar m =>
MVar m a -> (a -> m b) -> m b
withMVar MVar IO ()
v ((() -> IO a) -> IO a) -> (IO a -> () -> IO a) -> IO a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> () -> IO a
forall a b. a -> b -> a
const

mkLock :: IO Lock
mkLock :: IO Lock
mkLock = MVar () -> Lock
MVar IO () -> Lock
Lock (MVar () -> Lock) -> IO (MVar ()) -> IO Lock
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> () -> IO (MVar IO ())
forall a. a -> IO (MVar IO a)
forall (m :: * -> *) a. MonadMVar m => a -> m (MVar m a)
newMVar ()

eitherShowError :: (HasCallStack, Show e) => Either e a -> IO a
eitherShowError :: forall e a. (HasCallStack, Show e) => Either e a -> IO a
eitherShowError (Left e
e) = String -> IO a
forall a. HasCallStack => String -> a
error (e -> String
forall a. Show a => a -> String
show e
e)
eitherShowError (Right a
a) = a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

--------------------------------------------------------------------------------
-- Helpers for direct ser/deser
--------------------------------------------------------------------------------

directSerialiseToBS ::
  forall m a.
  DirectSerialise a =>
  MonadST m =>
  MonadThrow m =>
  Int ->
  a ->
  m ByteString
directSerialiseToBS :: forall (m :: * -> *) a.
(DirectSerialise a, MonadST m, MonadThrow m) =>
Int -> a -> m ByteString
directSerialiseToBS Int
dstsize a
val = do
  Int -> (Ptr CChar -> m ByteString) -> m ByteString
forall (m :: * -> *) a b.
(MonadThrow m, MonadST m) =>
Int -> (Ptr a -> m b) -> m b
allocaBytes Int
dstsize ((Ptr CChar -> m ByteString) -> m ByteString)
-> (Ptr CChar -> m ByteString) -> m ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
dst -> do
    Ptr CChar -> Int -> a -> m ()
forall (m :: * -> *) a.
(DirectSerialise a, MonadST m, MonadThrow m) =>
Ptr CChar -> Int -> a -> m ()
directSerialiseBufChecked Ptr CChar
dst Int
dstsize a
val
    CStringLen -> m ByteString
forall (m :: * -> *). MonadST m => CStringLen -> m ByteString
packByteStringCStringLen (Ptr CChar
dst, Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
dstsize)

directDeserialiseFromBS ::
  forall m a.
  DirectDeserialise a =>
  MonadST m =>
  MonadThrow m =>
  ByteString ->
  m a
directDeserialiseFromBS :: forall (m :: * -> *) a.
(DirectDeserialise a, MonadST m, MonadThrow m) =>
ByteString -> m a
directDeserialiseFromBS ByteString
bs = do
  ByteString -> (CStringLen -> m a) -> m a
forall (m :: * -> *) a.
(MonadThrow m, MonadST m) =>
ByteString -> (CStringLen -> m a) -> m a
unpackByteStringCStringLen ByteString
bs ((CStringLen -> m a) -> m a) -> (CStringLen -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
src, Int
srcsize) -> do
    Ptr CChar -> Int -> m a
forall (m :: * -> *) a.
(DirectDeserialise a, MonadST m, MonadThrow m) =>
Ptr CChar -> Int -> m a
directDeserialiseBufChecked Ptr CChar
src Int
srcsize