Main.hs (6998B)
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.Hash.SHA256 as SHA256 9 import qualified Crypto.Hash.SHA512 as SHA512 10 import qualified Crypto.DRBG.HMAC as DRBG 11 import qualified Data.Attoparsec.ByteString.Char8 as A 12 import qualified Data.ByteString as BS 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 hmac_sha256 :: BS.ByteString -> BS.ByteString -> BS.ByteString 41 hmac_sha256 k b = case SHA256.hmac k b of 42 SHA256.MAC m -> m 43 44 hmac_sha512 :: BS.ByteString -> BS.ByteString -> BS.ByteString 45 hmac_sha512 k b = case SHA512.hmac k b of 46 SHA512.MAC m -> m 47 48 cavp_14_3 :: [CaseBlock] -> [CaseBlock] -> TestTree 49 cavp_14_3 cs ds = testGroup "CAVP 14.3" [ 50 testGroup "HMAC-SHA256" (fmap (execute_caseblock hmac_sha256) cs) 51 , testGroup "HMAC-SHA512" (fmap (execute_caseblock hmac_sha512) ds) 52 ] 53 54 data CaseBlock = CaseBlock { 55 cb_blockHeader :: !BlockHeader 56 , cb_cases :: ![Case] 57 } deriving Show 58 59 data BlockHeader = BlockHeader { 60 bh_EntropyInputLen :: !Int 61 , bh_NonceLen :: !Int 62 , bh_PersonalizationStringLen :: !Int 63 , bh_AdditionalInputLen :: !Int 64 , bh_ReturnedBitsLen :: !Int 65 } deriving Show 66 67 -- test case spec 68 data Case = Case { 69 caseCount :: !Int 70 -- instantiate 71 , caseEntropy0 :: !BS.ByteString 72 , caseNonce :: !BS.ByteString 73 , casePs :: !BS.ByteString 74 , caseV0 :: !BS.ByteString 75 , caseK0 :: !BS.ByteString 76 -- first generate 77 , caseAddl1 :: !BS.ByteString 78 , caseEntropy1 :: !BS.ByteString 79 , caseV1 :: !BS.ByteString 80 , caseK1 :: !BS.ByteString 81 -- second generate 82 , caseAddl2 :: !BS.ByteString 83 , caseEntropy2 :: !BS.ByteString 84 , caseV2 :: !BS.ByteString 85 , caseK2 :: !BS.ByteString 86 , caseReturned :: !BS.ByteString 87 } deriving Show 88 89 execute_caseblock :: DRBG.HMAC -> CaseBlock -> TestTree 90 execute_caseblock hmac CaseBlock {..} = 91 testGroup msg (fmap (execute hmac) cb_cases) 92 where 93 BlockHeader {..} = cb_blockHeader 94 msg = "bitlens: " <> 95 "ent " <> show bh_EntropyInputLen <> " " <> 96 "non " <> show bh_NonceLen <> " " <> 97 "per " <> show bh_PersonalizationStringLen <> " " <> 98 "add " <> show bh_AdditionalInputLen <> " " <> 99 "ret " <> show bh_ReturnedBitsLen 100 101 -- execute test case 102 execute :: DRBG.HMAC -> Case -> TestTree 103 execute hmac Case {..} = testCase ("count " <> show caseCount) $ do 104 let bytes = fromIntegral (BS.length caseReturned) 105 106 drbg <- DRBG.new hmac caseEntropy0 caseNonce casePs 107 v0 <- DRBG._read_v drbg 108 k0 <- DRBG._read_k drbg 109 110 assertEqual "v0" v0 caseV0 111 assertEqual "k0" k0 caseK0 112 113 DRBG.reseed caseEntropy1 caseAddl1 drbg 114 Right _ <- DRBG.gen mempty bytes drbg 115 v1 <- DRBG._read_v drbg 116 k1 <- DRBG._read_k drbg 117 118 assertEqual "v1" v1 caseV1 119 assertEqual "k1" k1 caseK1 120 121 DRBG.reseed caseEntropy2 caseAddl2 drbg 122 Right returned <- DRBG.gen mempty bytes drbg 123 v2 <- DRBG._read_v drbg 124 k2 <- DRBG._read_k drbg 125 126 assertEqual "returned_bytes" returned caseReturned 127 assertEqual "v2" v2 caseV2 128 assertEqual "k2" k2 caseK2 129 130 -- CAVP vector parsers 131 132 hex_digit :: A.Parser Char 133 hex_digit = A.satisfy hd where 134 hd c = 135 (c >= '0' && c <= '9') 136 || (c >= 'a' && c <= 'f') 137 || (c >= 'A' && c <= 'F') 138 139 parse_hex :: A.Parser BS.ByteString 140 parse_hex = (decodeLenient . B8.pack) <$> A.many1 hex_digit where 141 decodeLenient bs = case B16.decode bs of 142 Nothing -> error "bang" 143 Just v -> v 144 145 parse_kv :: BS.ByteString -> A.Parser BS.ByteString 146 parse_kv k = 147 A.string k 148 *> A.skipSpace 149 *> A.char '=' 150 *> parse_v 151 where 152 parse_v = 153 (A.endOfLine *> pure mempty) 154 <|> (A.skipSpace *> parse_hex <* A.endOfLine) 155 156 parse_case :: A.Parser Case 157 parse_case = do 158 caseCount <- A.string "COUNT = " *> A.decimal <* A.endOfLine 159 caseEntropy0 <- parse_kv "EntropyInput" 160 caseNonce <- parse_kv "Nonce" 161 casePs <- parse_kv "PersonalizationString" 162 A.string "** INSTANTIATE:" *> A.endOfLine 163 caseV0 <- parse_kv "\tV" 164 caseK0 <- parse_kv "\tKey" 165 caseAddl1 <- parse_kv "AdditionalInput" 166 caseEntropy1 <- parse_kv "EntropyInputPR" 167 A.string "** GENERATE (FIRST CALL):" *> A.endOfLine 168 caseV1 <- parse_kv "\tV" 169 caseK1 <- parse_kv "\tKey" 170 caseAddl2 <- parse_kv "AdditionalInput" 171 caseEntropy2 <- parse_kv "EntropyInputPR" 172 caseReturned <- parse_kv "ReturnedBits" 173 A.string "** GENERATE (SECOND CALL):" *> A.endOfLine 174 caseV2 <- parse_kv "\tV" 175 caseK2 <- parse_kv "\tKey" 176 return Case {..} 177 178 parse_cases :: A.Parser [Case] 179 parse_cases = parse_case `A.sepBy` A.endOfLine 180 181 parse_header :: BS.ByteString -> A.Parser BlockHeader 182 parse_header sha = do 183 A.string ("[" <> sha <> "]") *> A.endOfLine 184 A.string "[PredictionResistance = True]" *> A.endOfLine 185 bh_EntropyInputLen <- 186 A.string "[EntropyInputLen = " *> A.decimal <* A.string "]" <* A.endOfLine 187 bh_NonceLen <- 188 A.string "[NonceLen = " *> A.decimal <* A.string "]" <* A.endOfLine 189 bh_PersonalizationStringLen <- 190 A.string "[PersonalizationStringLen = " *> A.decimal <* A.string "]" 191 <* A.endOfLine 192 bh_AdditionalInputLen <- 193 A.string "[AdditionalInputLen = " *> A.decimal <* A.string "]" 194 <* A.endOfLine 195 bh_ReturnedBitsLen <- 196 A.string "[ReturnedBitsLen = " *> A.decimal <* A.string "]" 197 <* A.endOfLine 198 A.endOfLine 199 pure BlockHeader {..} 200 201 parse_sha256_block :: A.Parser CaseBlock 202 parse_sha256_block = do 203 cb_blockHeader <- parse_header "SHA-256" 204 cb_cases <- parse_cases 205 A.endOfLine 206 pure CaseBlock {..} 207 208 parse_sha256_blocks :: A.Parser [CaseBlock] 209 parse_sha256_blocks = A.many1 parse_sha256_block 210 211 parse_sha512_block :: A.Parser CaseBlock 212 parse_sha512_block = do 213 cb_blockHeader <- parse_header "SHA-512" 214 cb_cases <- parse_cases 215 A.endOfLine 216 pure CaseBlock {..} 217 218 parse_sha512_blocks :: A.Parser [CaseBlock] 219 parse_sha512_blocks = A.many1 parse_sha512_block 220