{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Monad (replicateM)
import Control.Monad.ST (runST)
import qualified Crypto.CSPRNG as CSPRNG
import qualified Crypto.PRNG as PRNG
import qualified Crypto.PRNG.Pure as Pure
import qualified Crypto.Range as Range
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import Data.Bits ((.<<.), (.|.))
import Data.Foldable (for_)
import qualified Data.List as L
import Data.Word (Word64)
import GHC.Exts (RealWorld)
import Test.Tasty
import qualified Test.Tasty.HUnit as H
import Vectors (chacha8rand_seed, chacha8rand_hex, chacha8rand_words)
main :: IO ()
main = defaultMain $ testGroup "ppad-random" [
testGroup "Crypto.PRNG" [
prng_reference
, prng_jump
, prng_long_jump
, prng_new
, prng_zero_state
, prng_copy
, prng_double
, prng_system
]
, testGroup "Crypto.PRNG.Pure" [
pure_reference
, pure_jumps
, pure_new
, pure_zero_state
, pure_agrees
]
, testGroup "ranges" [
mul_wide
, prng_word64_range
, prng_int_range_bounds
, prng_int_range_order
, prng_int_range_full
, prng_uniformity
, csprng_word64_range
]
, testGroup "Crypto.CSPRNG" [
csprng_words
, csprng_bytes
, csprng_chunks
, csprng_alignment
, csprng_seed_length
, csprng_split
, csprng_st
, csprng_system
]
]
-- utilities ------------------------------------------------------------------
hex :: BS.ByteString -> BS.ByteString
hex bs = case B16.decode bs of
Nothing -> error "ppad-random (test): invalid hex"
Just x -> x
prng_state
:: Word64 -> Word64 -> Word64 -> Word64 -> IO (PRNG.Gen RealWorld)
prng_state s0 s1 s2 s3 = do
mg <- PRNG.from_state s0 s1 s2 s3
case mg of
Nothing -> H.assertFailure "invalid state"
Just g -> pure g
csprng_seeded :: BS.ByteString -> IO (CSPRNG.Gen RealWorld)
csprng_seeded seed = do
mg <- CSPRNG.new seed
case mg of
Nothing -> H.assertFailure "invalid seed"
Just g -> pure g
-- little-endian word at the given index of a bytestring
le64_at :: BS.ByteString -> Int -> Word64
le64_at bs k =
BS.foldr (\b acc -> (acc .<<. 8) .|. fromIntegral b) 0
(BS.take 8 (BS.drop (8 * k) bs))
-- xoshiro256++ ---------------------------------------------------------------
-- the vectors below are from Blackman and Vigna's reference
-- implementation, as published by rand_xoshiro (reference outputs)
-- or generated with it (jumps and seeding)
prng_reference :: TestTree
prng_reference = H.testCase "reference output" $ do
g <- prng_state 1 2 3 4
out <- replicateM 10 (PRNG.word64 g)
H.assertEqual mempty [
41943041, 58720359, 3588806011781223, 3591011842654386
, 9228616714210784205, 9973669472204895162, 14011001112246962877
, 12406186145184390807, 15849039046786891736, 10450023813501588000
] out
prng_jump :: TestTree
prng_jump = H.testCase "jump" $ do
g <- prng_state 1 2 3 4
PRNG.jump g
out <- replicateM 4 (PRNG.word64 g)
H.assertEqual mempty [
0xec879073673df437, 0x20d212a39aca1eaa
, 0xc19d712a27e40f57, 0x6ff0e08dc71026a1
] out
prng_long_jump :: TestTree
prng_long_jump = H.testCase "long_jump" $ do
g <- prng_state 1 2 3 4
PRNG.long_jump g
out <- replicateM 4 (PRNG.word64 g)
H.assertEqual mempty [
0xb5c4ea370b330bf5, 0x5173cc693c0fa533
, 0x1dc5df0151f7b491, 0xe7b055cfeabc4661
] out
prng_new :: TestTree
prng_new = H.testCase "new (splitmix64 seeding)" $
for_ cases $ \(seed, expected) -> do
g <- PRNG.new seed
out <- replicateM 4 (PRNG.word64 g)
H.assertEqual (show seed) expected out
where
cases = [
(0, [ 0x53175d61490b23df, 0x61da6f3dc380d507
, 0x5c0fdf91ec9a7bfc, 0x02eebf8c3bbe5e1a ])
, (42, [ 0xd0764d4f4476689f, 0x519e4174576f3791
, 0xfbe07cfb0c24ed8c, 0xb37d9f600cd835b8 ])
, (maxBound, [ 0x56ccf8ce948e27b2, 0xe68588432e5a5b90
, 0xe3e9b5a48119ca8b, 0x460f19495532ae73 ])
]
prng_zero_state :: TestTree
prng_zero_state = H.testCase "from_state rejects the zero state" $ do
mg <- PRNG.from_state 0 0 0 0
case mg of
Nothing -> pure ()
Just _ -> H.assertFailure "accepted zero state"
prng_copy :: TestTree
prng_copy = H.testCase "copy" $ do
g <- PRNG.new 42
_ <- PRNG.word64 g
c <- PRNG.copy g
a <- replicateM 8 (PRNG.word64 g)
b <- replicateM 8 (PRNG.word64 c)
H.assertEqual "same stream" a b
-- jumping the copy leaves the original alone
PRNG.jump c
x <- replicateM 8 (PRNG.word64 g)
ref <- PRNG.new 42
y <- fmap (drop 9) (replicateM 17 (PRNG.word64 ref))
H.assertEqual "original unaffected" y x
prng_double :: TestTree
prng_double = H.testCase "double" $ do
g <- PRNG.new 42
c <- PRNG.copy g
ds <- replicateM 1000 (PRNG.double g)
ws <- replicateM 1000 (PRNG.word64 c)
H.assertBool "range" (all (\d -> d >= 0 && d < 1) ds)
H.assertEqual "upper 53 bits"
(fmap (\w -> fromIntegral (w `div` 2048) / 2 ^ (53 :: Int)) ws) ds
prng_system :: TestTree
prng_system = H.testCase "new_system" $ do
ma <- PRNG.new_system
mb <- PRNG.new_system
case (ma, mb) of
(Just a, Just b) -> do
xs <- replicateM 4 (PRNG.word64 a)
ys <- replicateM 4 (PRNG.word64 b)
H.assertBool "distinct" (xs /= ys)
_ -> H.assertFailure "no entropy"
-- chacha8rand ----------------------------------------------------------------
-- the vectors are the sample output from the C2SP specification
csprng_words :: TestTree
csprng_words = H.testCase "sample output (word64)" $ do
g <- csprng_seeded chacha8rand_seed
out <- replicateM (length chacha8rand_words) (CSPRNG.word64 g)
H.assertEqual mempty chacha8rand_words out
csprng_bytes :: TestTree
csprng_bytes = H.testCase "sample output (bytes)" $ do
g <- csprng_seeded chacha8rand_seed
out <- CSPRNG.bytes 2976 g
H.assertEqual mempty (hex chacha8rand_hex) out
-- requests of assorted sizes, straddling refills, concatenate to the
-- same stream
csprng_chunks :: TestTree
csprng_chunks = H.testCase "sample output (chunked bytes)" $ do
g <- csprng_seeded chacha8rand_seed
let sizes = [0, 1, 7, 13, 100, 900, 992, 1, 962, -3]
out <- traverse (\n -> CSPRNG.bytes n g) sizes
H.assertEqual mempty (hex chacha8rand_hex) (BS.concat out)
-- after an unaligned 'bytes', 'word64' skips to the next eight-byte
-- boundary, including across a refill
csprng_alignment :: TestTree
csprng_alignment = H.testCase "word64 alignment" $ do
let stream = hex chacha8rand_hex
g <- csprng_seeded chacha8rand_seed
_ <- CSPRNG.bytes 3 g
a <- CSPRNG.word64 g
H.assertEqual "within buffer" (le64_at stream 1) a
_ <- CSPRNG.bytes (992 - 16 - 1) g
b <- CSPRNG.word64 g
H.assertEqual "across refill" (le64_at stream 124) b
csprng_seed_length :: TestTree
csprng_seed_length = H.testCase "new rejects bad seed lengths" $
for_ [0, 31, 33] $ \l -> do
mg <- CSPRNG.new (BS.replicate l 0)
case mg of
Nothing -> pure ()
Just _ -> H.assertFailure ("accepted length " <> show l)
-- a child is seeded from the parent's next 32 bytes, which the parent
-- then skips
csprng_split :: TestTree
csprng_split = H.testCase "split" $ do
let stream = hex chacha8rand_hex
g <- csprng_seeded chacha8rand_seed
c <- CSPRNG.split g
r <- csprng_seeded (BS.take 32 stream)
x <- CSPRNG.bytes 2000 c
y <- CSPRNG.bytes 2000 r
H.assertEqual "child" y x
z <- CSPRNG.bytes 100 g
H.assertEqual "parent" (BS.take 100 (BS.drop 32 stream)) z
csprng_st :: TestTree
csprng_st = H.testCase "ST" $ do
let out = runST $ do
mg <- CSPRNG.new chacha8rand_seed
case mg of
Nothing -> pure []
Just g -> replicateM 200 (CSPRNG.word64 g)
H.assertEqual mempty (take 200 chacha8rand_words) out
csprng_system :: TestTree
csprng_system = H.testCase "new_system" $ do
ma <- CSPRNG.new_system
mb <- CSPRNG.new_system
case (ma, mb) of
(Just a, Just b) -> do
x <- CSPRNG.bytes 32 a
y <- CSPRNG.bytes 32 b
H.assertBool "distinct" (x /= y)
_ -> H.assertFailure "no entropy"
-- ranges ---------------------------------------------------------------------
-- reference model of Lemire's method over a stream of words, using
-- exact integer arithmetic: a draw w is accepted iff the low word of
-- w * s is at least 2 ^ 64 mod s, yielding the high word
ref_ranges :: [Word64] -> [Word64] -> Maybe [Word64]
ref_ranges [] _ = Just []
ref_ranges (n : ns) ws
| n == maxBound = case ws of
[] -> Nothing
(w : rest) -> fmap (w :) (ref_ranges ns rest)
| otherwise = draw ws
where
s = toInteger n + 1
t = 2 ^ (64 :: Int) `mod` s
draw [] = Nothing
draw (w : rest) =
let m = toInteger w * s
in if m `mod` 2 ^ (64 :: Int) >= t
then fmap (fromInteger (m `div` 2 ^ (64 :: Int)) :)
(ref_ranges ns rest)
else draw rest
-- bounds including some with rejection probabilities near 1 / 2
range_bounds :: [Word64]
range_bounds = concat . replicate 20 $ [
0, 1, 5, 6, 100, 2 ^ (32 :: Int), 2 ^ (63 :: Int)
, 2 ^ (63 :: Int) + 12345, maxBound - 1, maxBound
]
mul_wide :: TestTree
mul_wide = H.testCase "mul_wide (native and limbs)" $
for_ edges $ \a -> for_ edges $ \b -> do
let p = toInteger a * toInteger b
ex = Range.W2 (fromInteger (p `div` 2 ^ (64 :: Int)))
(fromInteger (p `mod` 2 ^ (64 :: Int)))
H.assertEqual (show (a, b)) ex (Range.mul_wide a b)
H.assertEqual (show (a, b)) ex (Range._mul_wide_limbs a b)
where
edges = [ 0, 1, 2, 0xffffffff, 0x100000000, 0x7fffffffffffffff
, 0x8000000000000000, 0xfffffffffffffffe, maxBound
, 0xd0764d4f4476689f, 0x519e4174576f3791 ]
prng_word64_range :: TestTree
prng_word64_range = H.testCase "PRNG word64_range (reference model)" $ do
g <- PRNG.new 42
c <- PRNG.copy g
out <- traverse (\n -> PRNG.word64_range 0 n g) range_bounds
ws <- replicateM 1000 (PRNG.word64 c)
H.assertEqual mempty (Just out) (ref_ranges range_bounds ws)
-- an offset range is the same draw, shifted
g1 <- PRNG.new 7
g2 <- PRNG.copy g1
x <- PRNG.word64_range 1000 1100 g1
y <- PRNG.word64_range 0 100 g2
H.assertEqual "offset" (y + 1000) x
prng_int_range_bounds :: TestTree
prng_int_range_bounds = H.testCase "PRNG int_range (bounds)" $ do
g <- PRNG.new 42
for_ cases $ \(lo, hi) -> do
xs <- replicateM 200 (PRNG.int_range lo hi g)
H.assertBool (show (lo, hi)) (all (\x -> x >= lo && x <= hi) xs)
where
cases = [ (-10, 10), (5, 5), (-1, 0), (minBound, minBound + 3)
, (maxBound - 3, maxBound), (minBound, -1), (0, maxBound) ]
prng_int_range_order :: TestTree
prng_int_range_order = H.testCase "PRNG int_range (bound order)" $ do
g <- PRNG.new 42
c <- PRNG.copy g
xs <- replicateM 100 (PRNG.int_range (-10) 10 g)
ys <- replicateM 100 (PRNG.int_range 10 (-10) c)
H.assertEqual mempty xs ys
prng_int_range_full :: TestTree
prng_int_range_full = H.testCase "PRNG int_range (full range)" $ do
g <- PRNG.new 42
c <- PRNG.copy g
xs <- replicateM 100 (PRNG.int_range minBound maxBound g)
ws <- replicateM 100 (PRNG.word64 c)
H.assertEqual mempty (fmap (\w -> minBound + fromIntegral w) ws) xs
-- chi-squared over six outcomes from a fixed seed; 20.5 is the 0.999
-- quantile for five degrees of freedom
prng_uniformity :: TestTree
prng_uniformity = H.testCase "PRNG int_range (uniformity)" $ do
g <- PRNG.new 42
xs <- replicateM 60000 (PRNG.int_range 1 6 g)
let counts = fmap length (L.group (L.sort xs))
chi = sum [ (fromIntegral k - 10000) ^ (2 :: Int) / 10000
| k <- counts ] :: Double
H.assertEqual "outcomes" 6 (length counts)
H.assertBool ("chi-squared " <> show chi) (chi < 20.5)
-- over the known C2SP stream
csprng_word64_range :: TestTree
csprng_word64_range = H.testCase "CSPRNG word64_range (reference model)" $ do
g <- csprng_seeded chacha8rand_seed
let bounds = take 60 range_bounds
out <- traverse (\n -> CSPRNG.word64_range 0 n g) bounds
H.assertEqual mempty (Just out) (ref_ranges bounds chacha8rand_words)
-- pure xoshiro256++ ----------------------------------------------------------
-- n draws from a pure generator
draws :: (Pure.Gen -> Pure.Draw a) -> Int -> Pure.Gen -> [a]
draws f = go where
go n g
| n <= 0 = []
| otherwise = case f g of
Pure.Draw x ng -> x : go (n - 1) ng
pure_state :: Word64 -> Word64 -> Word64 -> Word64 -> IO Pure.Gen
pure_state s0 s1 s2 s3 = case Pure.from_state s0 s1 s2 s3 of
Nothing -> H.assertFailure "invalid state"
Just g -> pure g
pure_reference :: TestTree
pure_reference = H.testCase "reference output" $ do
g <- pure_state 1 2 3 4
H.assertEqual mempty [
41943041, 58720359, 3588806011781223, 3591011842654386
, 9228616714210784205, 9973669472204895162, 14011001112246962877
, 12406186145184390807, 15849039046786891736, 10450023813501588000
] (draws Pure.word64 10 g)
pure_jumps :: TestTree
pure_jumps = H.testCase "jump and long_jump" $ do
g <- pure_state 1 2 3 4
H.assertEqual "jump" [
0xec879073673df437, 0x20d212a39aca1eaa
, 0xc19d712a27e40f57, 0x6ff0e08dc71026a1
] (draws Pure.word64 4 (Pure.jump g))
H.assertEqual "long_jump" [
0xb5c4ea370b330bf5, 0x5173cc693c0fa533
, 0x1dc5df0151f7b491, 0xe7b055cfeabc4661
] (draws Pure.word64 4 (Pure.long_jump g))
pure_new :: TestTree
pure_new = H.testCase "new (splitmix64 seeding)" $ do
H.assertEqual "0" [ 0x53175d61490b23df, 0x61da6f3dc380d507
, 0x5c0fdf91ec9a7bfc, 0x02eebf8c3bbe5e1a ]
(draws Pure.word64 4 (Pure.new 0))
H.assertEqual "42" [ 0xd0764d4f4476689f, 0x519e4174576f3791
, 0xfbe07cfb0c24ed8c, 0xb37d9f600cd835b8 ]
(draws Pure.word64 4 (Pure.new 42))
pure_zero_state :: TestTree
pure_zero_state = H.testCase "from_state rejects the zero state" $
case Pure.from_state 0 0 0 0 of
Nothing -> pure ()
Just _ -> H.assertFailure "accepted zero state"
data Op = OpWord | OpDouble | OpRange Word64 | OpInt Int Int
data Out = OutWord Word64 | OutDouble Double | OutInt Int
deriving (Eq, Show)
-- a mix of operations, including ranges with frequent rejection
ops :: [Op]
ops = concat . replicate 30 $ [
OpWord, OpDouble, OpRange 6, OpRange (2 ^ (63 :: Int))
, OpInt (-10) 10, OpInt minBound maxBound, OpRange maxBound
]
run_pure :: [Op] -> Pure.Gen -> [Out]
run_pure [] _ = []
run_pure (o : os) g = case o of
OpWord -> case Pure.word64 g of
Pure.Draw x ng -> OutWord x : run_pure os ng
OpDouble -> case Pure.double g of
Pure.Draw x ng -> OutDouble x : run_pure os ng
OpRange n -> case Pure.word64_range 0 n g of
Pure.Draw x ng -> OutWord x : run_pure os ng
OpInt a b -> case Pure.int_range a b g of
Pure.Draw x ng -> OutInt x : run_pure os ng
run_mutable :: [Op] -> PRNG.Gen RealWorld -> IO [Out]
run_mutable os g = traverse op os where
op o = case o of
OpWord -> fmap OutWord (PRNG.word64 g)
OpDouble -> fmap OutDouble (PRNG.double g)
OpRange n -> fmap OutWord (PRNG.word64_range 0 n g)
OpInt a b -> fmap OutInt (PRNG.int_range a b g)
-- the pure and mutable generators produce the same output
pure_agrees :: TestTree
pure_agrees = H.testCase "agrees with Crypto.PRNG" $
for_ [0, 42, maxBound] $ \seed -> do
m <- PRNG.new seed
out <- run_mutable ops m
H.assertEqual (show seed) out (run_pure ops (Pure.new seed))