newhope-0.1.0.0: test/Crypto/NewHope/Test/RNG.hs
{-# LANGUAGE Trustworthy #-}
{-|
Module : Crypto.NewHope.Test.RNG
Description : Testing code for RNG
Copyright : © Jeremy Bornstein 2019
License : Apache 2.0
Maintainer : jeremy@bornstein.org
Stability : experimental
Portability : portable
-}
module Crypto.NewHope.Test.RNG where
import Codec.Crypto.AES
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Data.Map
import Test.QuickCheck (Arbitrary, arbitrary)
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck as QC
import ConfigFile
import Crypto.NewHope.Internal.RNG
import StringUtils
configFile :: IO Config
configFile = fromFile "RNG.cfg"
newtype WrapKey = WrapKey Key
instance Show WrapKey
where
show (WrapKey (Key bs)) = "Key: " ++ byteStringToHexString bs
newtype WrapV = WrapV V deriving Eq
instance Show WrapV
where
show (WrapV (V bs)) = "V: " ++ byteStringToHexString bs
newtype WrapContext = WrapContext Context
instance Show WrapContext where
show (WrapContext (Context key v reseedCounter)) = "Context {"
++ "ctxKey = " ++ show (WrapKey key) ++ ", "
++ "ctxV = " ++ show (WrapV v) ++ ", "
++ "ctxReseedCounter = " ++ show reseedCounter ++ "}"
instance Arbitrary WrapKey where
arbitrary = do
key <- sequence [ arbitrary | _ <- [1 .. keyBytes]]
return $ WrapKey $ createKey $ BSC.pack key
instance Arbitrary WrapV where
arbitrary = do
v <- sequence [ arbitrary | _ <- [1 .. vBytes]]
return $ WrapV $ createV $ BSC.pack v
instance Arbitrary WrapContext
where
arbitrary = do
wrappedKey <- arbitrary
wrappedV <- arbitrary
reseedCounter <- arbitrary
let WrapKey key = wrappedKey
let WrapV v = wrappedV
return $ WrapContext Context { ctxKey = key
, ctxV = v
, ctxReseedCounter = abs reseedCounter
}
data RNGValidationParams = RNGValidationParams { rngEntropy :: BS.ByteString
, rngKey :: BS.ByteString
, rngV :: BS.ByteString
, rngBlock0 :: BS.ByteString
, rngBlock1 :: BS.ByteString
, rngBlock2 :: BS.ByteString
} deriving Show
rngFromConfig :: Assignments -> RNGValidationParams
rngFromConfig section = RNGValidationParams { rngEntropy = hexStringToByteString $ section ! "entropy_input"
, rngKey = hexStringToByteString $ section ! "key"
, rngV = hexStringToByteString $ section ! "v"
, rngBlock0 = hexStringToByteString $ section ! "block0"
, rngBlock1 = hexStringToByteString $ section ! "block1"
, rngBlock2 = hexStringToByteString $ section ! "block2"
}
keyAndVCheck :: RNGValidationParams -> TestTree
keyAndVCheck params = testCase "rng key and v generation"
$ assertBool "broken" allIsWell
where
entropy = makeRandomSeed $ rngEntropy params
ctx = randomBytesInit entropy Nothing 256 -- note that the 256 is ignored!
keyVerified = rngKey params
Key keyActual = ctxKey ctx
keyIsOK = keyVerified == keyActual
vVerified = rngV params
V vActual = ctxV ctx
vIsOK = vVerified == vActual
allIsWell = keyIsOK && vIsOK
blocksCheck :: RNGValidationParams -> TestTree
blocksCheck params = testCase "rng block generation"
$ assertBool "broken" allIsWell
where
entropy = makeRandomSeed $ rngEntropy params
ctx = randomBytesInit entropy Nothing 256 -- note that the 256 is ignored!
block0Verified = rngBlock0 params
(block0, ctx0) = randomBytes ctx $ BS.length block0Verified
block0IsOK = block0Verified == block0
block1Verified = rngBlock1 params
(block1, ctx1) = randomBytes ctx0 $ BS.length block1Verified
block1IsOK = block1Verified == block1
block2Verified = rngBlock2 params
(block2, _ctx2) = randomBytes ctx1 $ BS.length block2Verified
block2IsOK = block2Verified == block2
allIsWell = block0IsOK && block1IsOK && block2IsOK
blocksCheck' :: RNGValidationParams -> TestTree
blocksCheck' params = testCaseSteps "rng block generation" $ \ step -> do
step "Making seed"
let entropy = makeRandomSeed $ rngEntropy params
let ctx = randomBytesInit entropy Nothing 256 -- note that the 256 is ignored!
step "Generating block 0"
let block0Verified = rngBlock0 params
let (block0, ctx0) = randomBytes ctx $ BS.length block0Verified
block0Verified == block0 @? "Block 0 not generated properly"
step "Generating block 1"
let block1Verified = rngBlock1 params
let (block1, ctx1) = randomBytes ctx0 $ BS.length block1Verified
block1Verified == block1 @? "Block 1 not generated properly"
step "Generating block 2"
let block2Verified = rngBlock2 params
let (block2, _ctx2) = randomBytes ctx1 $ BS.length block2Verified
block2Verified == block2 @? "Block 2 not generated properly"
testIncrementV :: TestTree
testIncrementV = testGroup "Incrementing a V" [ incrementCheckBasic
, incrementCheckTwoWraps
, incrementCheckFifteenWraps
, incrementCheckWrapAround
]
incrementCheckBasic :: TestTree
incrementCheckBasic = testCase "Incrementing a v - final byte"
(assertEqual "increment failed" (WrapV firstIncremented) (WrapV second)) where
first = createV $ BS.pack [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15]
firstIncremented = incrementV first
second = createV $ BS.pack [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,16]
incrementCheckTwoWraps :: TestTree
incrementCheckTwoWraps = testCase "Incrementing a v - two wraps"
(assertEqual "increment failed" (WrapV firstIncremented) (WrapV second)) where
first = createV $ BS.pack [0,1,2,3,4,5,6,7,8,9,10,11,12,13,255,255]
firstIncremented = incrementV first
second = createV $ BS.pack [0,1,2,3,4,5,6,7,8,9,10,11,12,14,0,0]
incrementCheckFifteenWraps :: TestTree
incrementCheckFifteenWraps = testCase "Incrementing a v - 15 wraps"
(assertEqual "increment failed" (WrapV firstIncremented) (WrapV second)) where
first = createV $ BS.pack [254,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255]
firstIncremented = incrementV first
second = createV $ BS.pack [255,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]
incrementCheckWrapAround :: TestTree
incrementCheckWrapAround = testCase "Incrementing a v - wraparound"
(assertEqual "increment failed" (WrapV firstIncremented) (WrapV second)) where
first = createV $ BS.pack [255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255]
firstIncremented = incrementV first
second = createV $ BS.pack [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]
-- AES tests are here because RNG is where we use AES.
newtype TestPlaintext = TestPlaintext { getText :: BS.ByteString } deriving (Eq, Show)
instance Arbitrary TestPlaintext where
arbitrary = sized $ \ n -> do
a <- sequence [ arbitrary | _ <- [1 .. n]]
return $ TestPlaintext (BSC.pack a)
newtype AES256IV = AES256IV BS.ByteString deriving Show
aes256IVLength :: Int
aes256IVLength = 16
instance Arbitrary AES256IV
where
arbitrary = do
a <- sequence [ arbitrary | _ <- [1 .. aes256IVLength]]
return $ AES256IV $ BSC.pack a
-- using two different IVs to the crypt' function because ECB doesn't use the IV.
propCryptDecrypt :: WrapKey -> AES256IV -> AES256IV -> TestPlaintext -> Bool
propCryptDecrypt key iv iv2 plaintext = let
WrapKey (Key key') = key
AES256IV iv' = iv
AES256IV iv2' = iv2
TestPlaintext plaintext' = plaintext
plaintext'' = pad ' ' 16 plaintext'
encrypted = crypt' ECB key' iv' Encrypt plaintext''
decrypted = crypt' ECB key' iv2' Decrypt encrypted
decrypted' = BSC.take (BS.length plaintext') decrypted
in plaintext' == decrypted'
-------------------
-- for manual investigation, not part of test suite
encryptionRoundtrip :: String -> IO BS.ByteString
encryptionRoundtrip plaintext = do
WrapV (V iv') <- generate (arbitrary :: Gen WrapV)
WrapKey (Key key') <- generate (arbitrary :: Gen WrapKey)
let plaintext' = pad ' ' 16 (BSC.pack plaintext)
let encrypted = crypt' ECB key' iv' Encrypt plaintext'
let decrypted = crypt' ECB key' iv' Decrypt encrypted
let decrypted' = BSC.take (Prelude.length plaintext) decrypted
return decrypted'
tests :: IO TestTree
tests = do
config <- configFile
let rngParams :: RNGValidationParams
rngParams = rngFromConfig $ config `sectionNamed` "rng"
return $ testGroup "RNG Tests" [ QC.testProperty "round trip AES encryption" propCryptDecrypt
, QC.testProperty "round trip AES encryption (plaintext size 100)" (mapSize (const 100) propCryptDecrypt)
, QC.testProperty "round trip AES encryption (plaintext size 1025)" (mapSize (const 1025) propCryptDecrypt)
, testIncrementV
, blocksCheck' rngParams]