{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# 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,

  -- * 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),
  decodeFullDecoder,
  encodedSizeExpr,
  hi,
  lo,
  serialize,
  szGreedy,
  szSimplify,
 )
import Cardano.Crypto.DirectSerialise
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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestSeed] -> ShowS
$cshowList :: [TestSeed] -> ShowS
show :: TestSeed -> String
$cshow :: TestSeed -> String
showsPrec :: Int -> TestSeed -> ShowS
$cshowsPrec :: Int -> TestSeed -> ShowS
Show, TestSeed -> TestSeed -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TestSeed -> TestSeed -> Bool
$c/= :: TestSeed -> TestSeed -> Bool
== :: TestSeed -> TestSeed -> Bool
$c== :: TestSeed -> TestSeed -> Bool
Eq, Eq 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
min :: TestSeed -> TestSeed -> TestSeed
$cmin :: TestSeed -> TestSeed -> TestSeed
max :: TestSeed -> TestSeed -> TestSeed
$cmax :: TestSeed -> TestSeed -> TestSeed
>= :: TestSeed -> TestSeed -> Bool
$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
compare :: TestSeed -> TestSeed -> Ordering
$ccompare :: TestSeed -> TestSeed -> Ordering
Ord, Typeable TestSeed
Proxy TestSeed -> Text
forall s. Decoder s TestSeed
forall a.
Typeable a
-> (forall s. Decoder s a) -> (Proxy a -> Text) -> FromCBOR a
label :: Proxy TestSeed -> Text
$clabel :: Proxy TestSeed -> Text
fromCBOR :: forall s. Decoder s TestSeed
$cfromCBOR :: forall s. Decoder s TestSeed
FromCBOR, Typeable 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
encodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size) -> Proxy [TestSeed] -> Size
$cencodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size) -> Proxy [TestSeed] -> Size
encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size) -> Proxy TestSeed -> Size
$cencodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size) -> Proxy TestSeed -> Size
toCBOR :: TestSeed -> Encoding
$ctoCBOR :: TestSeed -> Encoding
ToCBOR)

withTestSeed :: TestSeed -> MonadPseudoRandom ChaChaDRG a -> a
withTestSeed :: forall a. TestSeed -> MonadPseudoRandom ChaChaDRG a -> a
withTestSeed TestSeed
s = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall gen a. DRG gen => gen -> MonadPseudoRandom gen a -> (a, gen)
withDRG ((Word64, Word64, Word64, Word64, Word64) -> ChaChaDRG
drgNewTest 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 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((,,,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word64
gen forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Word64
gen forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Word64
gen forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Word64
gen forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Word64
gen)
    where
      gen :: Gen Word64
      gen :: Gen Word64
gen = forall a. (Bounded a, Integral a) => Gen a
arbitraryBoundedIntegral
  shrink :: TestSeed -> [TestSeed]
shrink = 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
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
showList :: [SizedSeed n] -> ShowS
$cshowList :: forall (n :: Nat). [SizedSeed n] -> ShowS
show :: SizedSeed n -> String
$cshow :: forall (n :: Nat). SizedSeed n -> String
showsPrec :: Int -> SizedSeed n -> ShowS
$cshowsPrec :: forall (n :: Nat). Int -> SizedSeed n -> ShowS
Show)

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

arbitrarySeedOfSize :: Word -> Gen Seed
arbitrarySeedOfSize :: Word -> Gen Seed
arbitrarySeedOfSize Word
sz =
  ByteString -> Seed
mkSeedFromBytes 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Int -> Gen [a]
vector (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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Message -> Message -> Bool
$c/= :: Message -> Message -> Bool
== :: Message -> Message -> Bool
$c== :: Message -> Message -> Bool
Eq, Int -> Message -> ShowS
[Message] -> ShowS
Message -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Message] -> ShowS
$cshowList :: [Message] -> ShowS
show :: Message -> String
$cshow :: Message -> String
showsPrec :: Int -> Message -> ShowS
$cshowsPrec :: Int -> Message -> ShowS
Show, Message -> ByteString
forall a. (a -> ByteString) -> SignableRepresentation a
getSignableRepresentation :: Message -> ByteString
$cgetSignableRepresentation :: Message -> ByteString
SignableRepresentation)

instance Arbitrary Message where
  arbitrary :: Gen Message
arbitrary = ByteString -> Message
Message forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
BS.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  shrink :: Message -> [Message]
shrink = forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> Message
Message forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
BS.pack) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Arbitrary a => a -> [a]
shrink forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack 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 = forall a.
(Eq a, Show a) =>
(a -> Encoding) -> (forall s. Decoder s a) -> a -> Property
prop_cbor_with forall a. ToCBOR a => a -> Encoding
toCBOR 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 =
  forall prop. Testable prop => String -> prop -> Property
counterexample (forall a. Show a => a -> String
show Nat
lo forall a. [a] -> [a] -> [a]
++ String
" ≰ " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Nat
len) (Nat
lo forall a. Ord a => a -> a -> Bool
<= Nat
len)
    forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. forall prop. Testable prop => String -> prop -> Property
counterexample (forall a. Show a => a -> String
show Nat
len forall a. [a] -> [a] -> [a]
++ String
" ≰ " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Nat
hi) (Nat
len forall a. Ord a => a -> a -> Bool
<= Nat
hi)
  where
    len, lo, hi :: Natural
    len :: Nat
len = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length (Encoding -> ByteString
toStrictByteString (forall a. ToCBOR a => a -> Encoding
toCBOR a
a))
    Range {Nat
lo :: Nat
lo :: forall b. Range b -> b
lo, Nat
hi :: Nat
hi :: forall b. Range b -> b
hi} =
      case Size -> Either Size (Range Nat)
szSimplify forall a b. (a -> b) -> a -> b
$ forall a.
ToCBOR a =>
(forall t. ToCBOR t => Proxy t -> Size) -> Proxy a -> Size
encodedSizeExpr forall t. ToCBOR t => Proxy t -> Size
szGreedy (forall {k} (t :: k). Proxy t
Proxy :: Proxy a) of
        Right Range Nat
x -> Range Nat
x
        Left Size
err -> forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. Buildable p => p -> Builder
build 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 =
  forall a. (a -> Encoding) -> a -> Property
prop_cbor_valid a -> Encoding
encoder a
x
    forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. 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

prop_cbor_valid :: (a -> Encoding) -> a -> Property
prop_cbor_valid :: forall a. (a -> Encoding) -> a -> Property
prop_cbor_valid a -> Encoding
encoder a
x =
  forall prop. Testable prop => String -> prop -> Property
counterexample String
errmsg 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 "
        forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FlatTerm
term
        forall a. [a] -> [a] -> [a]
++ String
" from encoding "
        forall a. [a] -> [a] -> [a]
++ 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 forall a.
Text
-> (forall s. Decoder s a) -> ByteString -> Either DecoderError a
decodeFullDecoder Text
"" forall s. Decoder s a
decoder (forall a. ToCBOR a => a -> ByteString
serialize (a -> Encoding
encoder a
x)) of
    Right a
y -> a
y forall a. (Eq a, Show a) => a -> a -> Property
=== a
x
    Left DecoderError
err -> forall prop. Testable prop => String -> prop -> Property
counterexample (forall a. Show a => a -> String
show DecoderError
err) (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 forall a. (Eq a, Show a) => a -> a -> Property
=== a
x
    Maybe a
Nothing -> 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)) =
  forall prop. Testable prop => prop -> Property
checkCoverage
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
50.0 (ByteString -> Int
BS.length ByteString
bs forall a. Ord a => a -> a -> Bool
> Int
forbiddenLen) String
"too long"
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
50.0 (ByteString -> Int
BS.length ByteString
bs forall a. Ord a => a -> a -> Bool
< Int
forbiddenLen) String
"too short"
    forall a b. (a -> b) -> a -> b
$ case ByteString -> Maybe a
deserialise ByteString
bs of
      Maybe a
Nothing -> forall prop. Testable prop => prop -> Property
property Bool
True
      Just a
x -> forall prop. Testable prop => String -> prop -> Property
counterexample (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) forall a. (Eq a, Show a) => a -> a -> Property
=== Encoding -> FlatTerm
toFlatTerm (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) forall a. (Eq a, Show a) => a -> a -> Property
=== 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 forall a. NoThunks a => a -> Maybe ThunkInfo
unsafeNoThunks a
a of
  Maybe ThunkInfo
Nothing -> forall prop. Testable prop => prop -> Property
property Bool
True
  Just ThunkInfo
msg -> forall prop. Testable prop => String -> prop -> Property
counterexample (forall a. Show a => a -> String
show ThunkInfo
msg) (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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks [] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe ThunkInfo
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall prop. Testable prop => prop -> Property
property Bool
True
    Just ThunkInfo
msg -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall prop. Testable prop => String -> prop -> Property
counterexample (forall a. Show a => a -> String
show ThunkInfo
msg) forall a b. (a -> b) -> a -> b
$! (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 = forall prop. Testable prop => IO prop -> Property
ioProperty forall a b. (a -> b) -> a -> b
$ do
  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 =
  forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (IO a)
mkX (forall prop. Testable prop => IO prop -> Property
ioProperty forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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.
newtype BadInputFor (a :: Type) = BadInputFor (Int, ByteString)
  deriving (BadInputFor a -> BadInputFor a -> Bool
forall a. BadInputFor a -> BadInputFor a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BadInputFor a -> BadInputFor a -> Bool
$c/= :: forall a. BadInputFor a -> BadInputFor a -> Bool
== :: BadInputFor a -> BadInputFor a -> Bool
$c== :: forall a. BadInputFor a -> BadInputFor a -> Bool
Eq, Int -> BadInputFor a -> ShowS
forall a. Int -> BadInputFor a -> ShowS
forall a. [BadInputFor a] -> ShowS
forall a. BadInputFor a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BadInputFor a] -> ShowS
$cshowList :: forall a. [BadInputFor a] -> ShowS
show :: BadInputFor a -> String
$cshow :: forall a. BadInputFor a -> String
showsPrec :: Int -> BadInputFor a -> ShowS
$cshowsPrec :: forall a. Int -> BadInputFor a -> ShowS
Show)

-- 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 =
  forall a. (Int, ByteString) -> BadInputFor a
BadInputFor forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) Int
forbiddenLen forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall a. Num a => a -> a -> a
- Int
1)
      forall l. IsList l => Int -> [Item l] -> l
fromListN Int
len forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Int -> Gen a -> Gen [a]
Gen.vectorOf Int
len 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 forall a. Num a => a -> a -> a
+ Int
1, Int
forbiddenLen forall a. Num a => a -> a -> a
* Int
2)
      forall l. IsList l => Int -> [Item l] -> l
fromListN Int
len forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Int -> Gen a -> Gen [a]
Gen.vectorOf Int
len 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)) =
  forall a. (Int, ByteString) -> BadInputFor a
BadInputFor forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
len,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    ByteString
bs' <- forall l. IsList l => [Item l] -> l
fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => a -> [a]
shrink (forall l. IsList l => l -> [Item l]
toList ByteString
bs)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
BS.length ByteString
bs forall a. Ord a => a -> a -> Bool
> Int
len) (forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString -> Int
BS.length ByteString
bs' forall a. Ord a => a -> a -> Bool
> Int
len))
    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
_, ByteString
bs)) =
  ByteString -> String
hexBS ByteString
bs

hexBS :: ByteString -> String
hexBS :: ByteString -> String
hexBS ByteString
bs =
  String
"0x" forall a. Semigroup a => a -> a -> a
<> ByteString -> String
BS8.unpack (ByteString -> ByteString
Base16.encode ByteString
bs) forall a. Semigroup a => a -> a -> a
<> String
" (length " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (ByteString -> Int
BS.length ByteString
bs) 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 = (forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> 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) = forall (m :: * -> *) a b.
MonadMVar m =>
MVar m a -> (a -> m b) -> m b
withMVar MVar IO ()
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const

mkLock :: IO Lock
mkLock :: IO Lock
mkLock = MVar IO () -> Lock
Lock forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) = forall a. HasCallStack => String -> a
error (forall a. Show a => a -> String
show e
e)
eitherShowError (Right a
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
  forall (m :: * -> *) a b.
(MonadThrow m, MonadST m) =>
Int -> (Ptr a -> m b) -> m b
allocaBytes Int
dstsize forall a b. (a -> b) -> a -> b
$ \Ptr CChar
dst -> do
    forall (m :: * -> *) a.
(DirectSerialise a, MonadST m, MonadThrow m) =>
Ptr CChar -> Int -> a -> m ()
directSerialiseBufChecked Ptr CChar
dst Int
dstsize a
val
    forall (m :: * -> *). MonadST m => CStringLen -> m ByteString
packByteStringCStringLen (Ptr CChar
dst, 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
  forall (m :: * -> *) a.
(MonadThrow m, MonadST m) =>
ByteString -> (CStringLen -> m a) -> m a
unpackByteStringCStringLen ByteString
bs forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
src, Int
srcsize) -> do
    forall (m :: * -> *) a.
(DirectDeserialise a, MonadST m, MonadThrow m) =>
Ptr CChar -> Int -> m a
directDeserialiseBufChecked Ptr CChar
src Int
srcsize