Main.hs (7432B)
1 {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 {-# LANGUAGE OverloadedStrings #-} 3 {-# LANGUAGE RecordWildCards #-} 4 5 module Main where 6 7 import Control.Applicative ((<|>)) 8 import qualified Crypto.DRBG.HMAC.SHA256 as DRBG256 9 import qualified Crypto.DRBG.HMAC.SHA512 as DRBG512 10 import qualified Data.Attoparsec.ByteString.Char8 as A 11 import qualified Data.ByteString as BS 12 import Data.Word (Word64) 13 import qualified Data.ByteString.Char8 as B8 14 import qualified Data.ByteString.Base16 as B16 15 import Test.Tasty 16 import Test.Tasty.HUnit 17 18 -- CAVP source: 19 -- 20 -- https://raw.githubusercontent.com/coruus/nist-testvectors/refs/heads/master/csrc.nist.gov/groups/STM/cavp/documents/drbg/drbgtestvectors/drbgvectors_pr_true/HMAC_DRBG.txt 21 -- 22 -- spec: 23 -- 24 -- https://csrc.nist.gov/CSRC/media/Projects/Cryptographic-Algorithm-Validation-Program/documents/drbg/DRBGVS.pdf 25 26 main :: IO () 27 main = do 28 sha256_vectors <- BS.readFile "etc/HMAC_DRBG_SHA256.txt" 29 sha512_vectors <- BS.readFile "etc/HMAC_DRBG_SHA512.txt" 30 let sha256_cases = case A.parseOnly parse_sha256_blocks sha256_vectors of 31 Left _ -> error "ppad-hmac-drbg (test): parse error" 32 Right cs -> cs 33 34 sha512_cases = case A.parseOnly parse_sha512_blocks sha512_vectors of 35 Left _ -> error "ppad-hmac-drbg (test): parse error" 36 Right cs -> cs 37 38 defaultMain (cavp_14_3 sha256_cases sha512_cases) 39 40 cavp_14_3 :: [CaseBlock] -> [CaseBlock] -> TestTree 41 cavp_14_3 cs ds = testGroup "CAVP 14.3" [ 42 testGroup "HMAC-SHA256" (fmap (execute_caseblock DRBG256.new DRBG256.reseed DRBG256.gen DRBG256._read_v DRBG256._read_k) cs) 43 , testGroup "HMAC-SHA512" (fmap (execute_caseblock DRBG512.new DRBG512.reseed DRBG512.gen DRBG512._read_v DRBG512._read_k) ds) 44 ] 45 46 data CaseBlock = CaseBlock { 47 cb_blockHeader :: !BlockHeader 48 , cb_cases :: ![Case] 49 } deriving Show 50 51 data BlockHeader = BlockHeader { 52 bh_EntropyInputLen :: !Int 53 , bh_NonceLen :: !Int 54 , bh_PersonalizationStringLen :: !Int 55 , bh_AdditionalInputLen :: !Int 56 , bh_ReturnedBitsLen :: !Int 57 } deriving Show 58 59 -- test case spec 60 data Case = Case { 61 caseCount :: !Int 62 -- instantiate 63 , caseEntropy0 :: !BS.ByteString 64 , caseNonce :: !BS.ByteString 65 , casePs :: !BS.ByteString 66 , caseV0 :: !BS.ByteString 67 , caseK0 :: !BS.ByteString 68 -- first generate 69 , caseAddl1 :: !BS.ByteString 70 , caseEntropy1 :: !BS.ByteString 71 , caseV1 :: !BS.ByteString 72 , caseK1 :: !BS.ByteString 73 -- second generate 74 , caseAddl2 :: !BS.ByteString 75 , caseEntropy2 :: !BS.ByteString 76 , caseV2 :: !BS.ByteString 77 , caseK2 :: !BS.ByteString 78 , caseReturned :: !BS.ByteString 79 } deriving Show 80 81 execute_caseblock 82 :: (BS.ByteString -> BS.ByteString -> BS.ByteString -> IO drbg) 83 -> (drbg -> BS.ByteString -> BS.ByteString -> IO ()) 84 -> (drbg -> BS.ByteString -> Word64 -> IO (Either e BS.ByteString)) 85 -> (drbg -> IO BS.ByteString) 86 -> (drbg -> IO BS.ByteString) 87 -> CaseBlock 88 -> TestTree 89 execute_caseblock drbg_new drbg_reseed drbg_gen read_v read_k CaseBlock {..} = 90 testGroup msg (fmap (execute drbg_new drbg_reseed drbg_gen read_v read_k) cb_cases) 91 where 92 BlockHeader {..} = cb_blockHeader 93 msg = "bitlens: " <> 94 "ent " <> show bh_EntropyInputLen <> " " <> 95 "non " <> show bh_NonceLen <> " " <> 96 "per " <> show bh_PersonalizationStringLen <> " " <> 97 "add " <> show bh_AdditionalInputLen <> " " <> 98 "ret " <> show bh_ReturnedBitsLen 99 100 -- execute test case 101 execute 102 :: (BS.ByteString -> BS.ByteString -> BS.ByteString -> IO drbg) 103 -> (drbg -> BS.ByteString -> BS.ByteString -> IO ()) 104 -> (drbg -> BS.ByteString -> Word64 -> IO (Either e BS.ByteString)) 105 -> (drbg -> IO BS.ByteString) 106 -> (drbg -> IO BS.ByteString) 107 -> Case 108 -> TestTree 109 execute drbg_new drbg_reseed drbg_gen read_v read_k Case {..} = 110 testCase ("count " <> show caseCount) $ do 111 let bytes = fromIntegral (BS.length caseReturned) 112 113 drbg <- drbg_new caseEntropy0 caseNonce casePs 114 v0 <- read_v drbg 115 k0 <- read_k drbg 116 117 assertEqual "v0" v0 caseV0 118 assertEqual "k0" k0 caseK0 119 120 drbg_reseed drbg caseEntropy1 caseAddl1 121 Right _ <- drbg_gen drbg mempty bytes 122 v1 <- read_v drbg 123 k1 <- read_k drbg 124 125 assertEqual "v1" v1 caseV1 126 assertEqual "k1" k1 caseK1 127 128 drbg_reseed drbg caseEntropy2 caseAddl2 129 Right returned <- drbg_gen drbg mempty bytes 130 v2 <- read_v drbg 131 k2 <- read_k drbg 132 133 assertEqual "returned_bytes" returned caseReturned 134 assertEqual "v2" v2 caseV2 135 assertEqual "k2" k2 caseK2 136 137 -- CAVP vector parsers 138 139 hex_digit :: A.Parser Char 140 hex_digit = A.satisfy hd where 141 hd c = 142 (c >= '0' && c <= '9') 143 || (c >= 'a' && c <= 'f') 144 || (c >= 'A' && c <= 'F') 145 146 parse_hex :: A.Parser BS.ByteString 147 parse_hex = (decodeLenient . B8.pack) <$> A.many1 hex_digit where 148 decodeLenient bs = case B16.decode bs of 149 Nothing -> error "bang" 150 Just v -> v 151 152 parse_kv :: BS.ByteString -> A.Parser BS.ByteString 153 parse_kv k = 154 A.string k 155 *> A.skipSpace 156 *> A.char '=' 157 *> parse_v 158 where 159 parse_v = 160 (A.endOfLine *> pure mempty) 161 <|> (A.skipSpace *> parse_hex <* A.endOfLine) 162 163 parse_case :: A.Parser Case 164 parse_case = do 165 caseCount <- A.string "COUNT = " *> A.decimal <* A.endOfLine 166 caseEntropy0 <- parse_kv "EntropyInput" 167 caseNonce <- parse_kv "Nonce" 168 casePs <- parse_kv "PersonalizationString" 169 A.string "** INSTANTIATE:" *> A.endOfLine 170 caseV0 <- parse_kv "\tV" 171 caseK0 <- parse_kv "\tKey" 172 caseAddl1 <- parse_kv "AdditionalInput" 173 caseEntropy1 <- parse_kv "EntropyInputPR" 174 A.string "** GENERATE (FIRST CALL):" *> A.endOfLine 175 caseV1 <- parse_kv "\tV" 176 caseK1 <- parse_kv "\tKey" 177 caseAddl2 <- parse_kv "AdditionalInput" 178 caseEntropy2 <- parse_kv "EntropyInputPR" 179 caseReturned <- parse_kv "ReturnedBits" 180 A.string "** GENERATE (SECOND CALL):" *> A.endOfLine 181 caseV2 <- parse_kv "\tV" 182 caseK2 <- parse_kv "\tKey" 183 return Case {..} 184 185 parse_cases :: A.Parser [Case] 186 parse_cases = parse_case `A.sepBy` A.endOfLine 187 188 parse_header :: BS.ByteString -> A.Parser BlockHeader 189 parse_header sha = do 190 A.string ("[" <> sha <> "]") *> A.endOfLine 191 A.string "[PredictionResistance = True]" *> A.endOfLine 192 bh_EntropyInputLen <- 193 A.string "[EntropyInputLen = " *> A.decimal <* A.string "]" <* A.endOfLine 194 bh_NonceLen <- 195 A.string "[NonceLen = " *> A.decimal <* A.string "]" <* A.endOfLine 196 bh_PersonalizationStringLen <- 197 A.string "[PersonalizationStringLen = " *> A.decimal <* A.string "]" 198 <* A.endOfLine 199 bh_AdditionalInputLen <- 200 A.string "[AdditionalInputLen = " *> A.decimal <* A.string "]" 201 <* A.endOfLine 202 bh_ReturnedBitsLen <- 203 A.string "[ReturnedBitsLen = " *> A.decimal <* A.string "]" 204 <* A.endOfLine 205 A.endOfLine 206 pure BlockHeader {..} 207 208 parse_sha256_block :: A.Parser CaseBlock 209 parse_sha256_block = do 210 cb_blockHeader <- parse_header "SHA-256" 211 cb_cases <- parse_cases 212 A.endOfLine 213 pure CaseBlock {..} 214 215 parse_sha256_blocks :: A.Parser [CaseBlock] 216 parse_sha256_blocks = A.many1 parse_sha256_block 217 218 parse_sha512_block :: A.Parser CaseBlock 219 parse_sha512_block = do 220 cb_blockHeader <- parse_header "SHA-512" 221 cb_cases <- parse_cases 222 A.endOfLine 223 pure CaseBlock {..} 224 225 parse_sha512_blocks :: A.Parser [CaseBlock] 226 parse_sha512_blocks = A.many1 parse_sha512_block 227