{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Crypto.Store.CMS.Algorithms
( DigestAlgorithm(..)
, DigestProxy(..)
, digest
, MessageAuthenticationCode
, MACAlgorithm(..)
, mac
, HasKeySize(..)
, getMaximumKeySize
, validateKeySize
, generateKey
, ContentEncryptionCipher(..)
, ContentEncryptionAlg(..)
, ContentEncryptionParams(..)
, generateEncryptionParams
, generateRC2EncryptionParams
, getContentEncryptionAlg
, proxyBlockSize
, contentEncrypt
, contentDecrypt
, AuthContentEncryptionAlg(..)
, AuthContentEncryptionParams
, generateAuthEnc128Params
, generateAuthEnc256Params
, generateChaChaPoly1305Params
, generateCCMParams
, generateGCMParams
, authContentEncrypt
, authContentDecrypt
, PBKDF2_PRF(..)
, prf
, Salt
, generateSalt
, KeyDerivationFunc(..)
, kdfKeyLength
, kdfDerive
, KeyEncryptionParams(..)
, keyEncrypt
, keyDecrypt
, OAEPParams(..)
, KeyTransportParams(..)
, transportEncrypt
, transportDecrypt
, KeyAgreementParams(..)
, ecdhGenerate
, ecdhEncrypt
, ecdhDecrypt
, MaskGenerationFunc(..)
, mgf
, SignatureValue
, PSSParams(..)
, SignatureAlg(..)
, signatureResolveHash
, signatureCheckHash
, signatureGenerate
, signatureVerify
) where
import Control.Applicative
import Control.Monad (guard, when)
import Data.ASN1.BinaryEncoding
import Data.ASN1.OID
import Data.ASN1.Encoding
import Data.ASN1.Types
import Data.Bits
import Data.ByteArray (ByteArray, ByteArrayAccess)
import qualified Data.ByteArray as B
import Data.ByteString (ByteString)
import Data.Maybe (fromMaybe)
import Data.Word
import qualified Data.X509 as X509
import Data.X509.EC
import qualified Crypto.Cipher.AES as Cipher
import qualified Crypto.Cipher.CAST5 as Cipher
import qualified Crypto.Cipher.Camellia as Cipher
import qualified Crypto.Cipher.ChaChaPoly1305 as ChaChaPoly1305
import qualified Crypto.Cipher.DES as Cipher
import qualified Crypto.Cipher.TripleDES as Cipher
import Crypto.Cipher.Types
import Crypto.Data.Padding
import Crypto.Error
import qualified Crypto.Hash as Hash
import qualified Crypto.KDF.PBKDF2 as PBKDF2
import qualified Crypto.KDF.Scrypt as Scrypt
import qualified Crypto.MAC.HMAC as HMAC
import qualified Crypto.MAC.Poly1305 as Poly1305
import Crypto.Number.Serialize
import qualified Crypto.PubKey.DSA as DSA
import qualified Crypto.PubKey.ECC.DH as ECDH
import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
import qualified Crypto.PubKey.ECC.Types as ECC
import qualified Crypto.PubKey.MaskGenFunction as MGF
import qualified Crypto.PubKey.RSA.PSS as RSAPSS
import qualified Crypto.PubKey.RSA.OAEP as RSAOAEP
import qualified Crypto.PubKey.RSA.PKCS15 as RSA
import Crypto.Random
import Foreign.Ptr (Ptr)
import Foreign.Storable
import Crypto.Store.ASN1.Generate
import Crypto.Store.ASN1.Parse
import Crypto.Store.CMS.Util
import Crypto.Store.Cipher.RC2
import Crypto.Store.Error
import qualified Crypto.Store.KeyWrap.AES as AES_KW
import qualified Crypto.Store.KeyWrap.TripleDES as TripleDES_KW
import qualified Crypto.Store.KeyWrap.RC2 as RC2_KW
import Crypto.Store.Util
data DigestProxy hashAlg where
MD2 :: DigestProxy Hash.MD2
MD4 :: DigestProxy Hash.MD4
MD5 :: DigestProxy Hash.MD5
SHA1 :: DigestProxy Hash.SHA1
SHA224 :: DigestProxy Hash.SHA224
SHA256 :: DigestProxy Hash.SHA256
SHA384 :: DigestProxy Hash.SHA384
SHA512 :: DigestProxy Hash.SHA512
deriving instance Show (DigestProxy hashAlg)
deriving instance Eq (DigestProxy hashAlg)
data DigestAlgorithm =
forall hashAlg . Hash.HashAlgorithm hashAlg
=> DigestAlgorithm (DigestProxy hashAlg)
instance Show DigestAlgorithm where
show (DigestAlgorithm a) = show a
instance Eq DigestAlgorithm where
DigestAlgorithm MD2 == DigestAlgorithm MD2 = True
DigestAlgorithm MD4 == DigestAlgorithm MD4 = True
DigestAlgorithm MD5 == DigestAlgorithm MD5 = True
DigestAlgorithm SHA1 == DigestAlgorithm SHA1 = True
DigestAlgorithm SHA224 == DigestAlgorithm SHA224 = True
DigestAlgorithm SHA256 == DigestAlgorithm SHA256 = True
DigestAlgorithm SHA384 == DigestAlgorithm SHA384 = True
DigestAlgorithm SHA512 == DigestAlgorithm SHA512 = True
_ == _ = False
instance Enumerable DigestAlgorithm where
values = [ DigestAlgorithm MD2
, DigestAlgorithm MD4
, DigestAlgorithm MD5
, DigestAlgorithm SHA1
, DigestAlgorithm SHA224
, DigestAlgorithm SHA256
, DigestAlgorithm SHA384
, DigestAlgorithm SHA512
]
instance OIDable DigestAlgorithm where
getObjectID (DigestAlgorithm MD2) = [1,2,840,113549,2,2]
getObjectID (DigestAlgorithm MD4) = [1,2,840,113549,2,4]
getObjectID (DigestAlgorithm MD5) = [1,2,840,113549,2,5]
getObjectID (DigestAlgorithm SHA1) = [1,3,14,3,2,26]
getObjectID (DigestAlgorithm SHA224) = [2,16,840,1,101,3,4,2,4]
getObjectID (DigestAlgorithm SHA256) = [2,16,840,1,101,3,4,2,1]
getObjectID (DigestAlgorithm SHA384) = [2,16,840,1,101,3,4,2,2]
getObjectID (DigestAlgorithm SHA512) = [2,16,840,1,101,3,4,2,3]
instance OIDNameable DigestAlgorithm where
fromObjectID oid = unOIDNW <$> fromObjectID oid
instance AlgorithmId DigestAlgorithm where
type AlgorithmType DigestAlgorithm = DigestAlgorithm
algorithmName _ = "digest algorithm"
algorithmType = id
parameterASN1S (DigestAlgorithm MD5) = gNull
parameterASN1S _ = id
parseParameter p = getNextMaybe nullOrNothing >> return p
digest :: ByteArrayAccess message => DigestAlgorithm -> message -> ByteString
digest (DigestAlgorithm hashAlg) message = B.convert (doHash hashAlg message)
doHash :: (Hash.HashAlgorithm hashAlg, ByteArrayAccess ba)
=> proxy hashAlg -> ba -> Hash.Digest hashAlg
doHash _ = Hash.hash
hashFromProxy :: proxy a -> a
hashFromProxy _ = undefined
class HasKeySize params where
getKeySizeSpecifier :: params -> KeySizeSpecifier
getMaximumKeySize :: HasKeySize params => params -> Int
getMaximumKeySize params =
case getKeySizeSpecifier params of
KeySizeRange _ n -> n
KeySizeEnum l -> maximum l
KeySizeFixed n -> n
validateKeySize :: HasKeySize params => params -> Int -> Bool
validateKeySize params len =
case getKeySizeSpecifier params of
KeySizeRange a b -> a <= len && len <= b
KeySizeEnum l -> len `elem` l
KeySizeFixed n -> len == n
generateKey :: (HasKeySize params, MonadRandom m, ByteArray key)
=> params -> m key
generateKey params = getRandomBytes (getMaximumKeySize params)
type MessageAuthenticationCode = AuthTag
data MACAlgorithm
= forall hashAlg . Hash.HashAlgorithm hashAlg
=> HMAC (DigestProxy hashAlg)
deriving instance Show MACAlgorithm
instance Eq MACAlgorithm where
HMAC a1 == HMAC a2 = DigestAlgorithm a1 == DigestAlgorithm a2
instance Enumerable MACAlgorithm where
values = [ HMAC MD5
, HMAC SHA1
, HMAC SHA224
, HMAC SHA256
, HMAC SHA384
, HMAC SHA512
]
instance OIDable MACAlgorithm where
getObjectID (HMAC MD5) = [1,3,6,1,5,5,8,1,1]
getObjectID (HMAC SHA1) = [1,3,6,1,5,5,8,1,2]
getObjectID (HMAC SHA224) = [1,2,840,113549,2,8]
getObjectID (HMAC SHA256) = [1,2,840,113549,2,9]
getObjectID (HMAC SHA384) = [1,2,840,113549,2,10]
getObjectID (HMAC SHA512) = [1,2,840,113549,2,11]
getObjectID ty = error ("Unsupported MACAlgorithm: " ++ show ty)
instance OIDNameable MACAlgorithm where
fromObjectID oid = unOIDNW <$> fromObjectID oid
instance AlgorithmId MACAlgorithm where
type AlgorithmType MACAlgorithm = MACAlgorithm
algorithmName _ = "mac algorithm"
algorithmType = id
parameterASN1S _ = id
parseParameter p = getNextMaybe nullOrNothing >> return p
instance HasKeySize MACAlgorithm where
getKeySizeSpecifier (HMAC a) = KeySizeFixed (digestSizeFromProxy a)
where digestSizeFromProxy = Hash.hashDigestSize . hashFromProxy
mac :: (ByteArrayAccess key, ByteArrayAccess message)
=> MACAlgorithm -> key -> message -> MessageAuthenticationCode
mac (HMAC alg) = hmacWith alg
where
hmacWith p key = AuthTag . B.convert . runHMAC p key
runHMAC :: (Hash.HashAlgorithm a, ByteArrayAccess k, ByteArrayAccess m)
=> proxy a -> k -> m -> HMAC.HMAC a
runHMAC _ = HMAC.hmac
data ContentEncryptionCipher cipher where
DES :: ContentEncryptionCipher Cipher.DES
DES_EDE2 :: ContentEncryptionCipher Cipher.DES_EDE2
DES_EDE3 :: ContentEncryptionCipher Cipher.DES_EDE3
AES128 :: ContentEncryptionCipher Cipher.AES128
AES192 :: ContentEncryptionCipher Cipher.AES192
AES256 :: ContentEncryptionCipher Cipher.AES256
CAST5 :: ContentEncryptionCipher Cipher.CAST5
Camellia128 :: ContentEncryptionCipher Cipher.Camellia128
deriving instance Show (ContentEncryptionCipher cipher)
deriving instance Eq (ContentEncryptionCipher cipher)
cecI :: ContentEncryptionCipher c -> Int
cecI DES = 0
cecI DES_EDE2 = 1
cecI DES_EDE3 = 2
cecI AES128 = 3
cecI AES192 = 4
cecI AES256 = 5
cecI CAST5 = 6
cecI Camellia128 = 7
getCipherKeySizeSpecifier :: Cipher cipher => proxy cipher -> KeySizeSpecifier
getCipherKeySizeSpecifier = cipherKeySize . cipherFromProxy
data ContentEncryptionAlg
= forall c . BlockCipher c => ECB (ContentEncryptionCipher c)
| forall c . BlockCipher c => CBC (ContentEncryptionCipher c)
| CBC_RC2
| forall c . BlockCipher c => CFB (ContentEncryptionCipher c)
| forall c . BlockCipher c => CTR (ContentEncryptionCipher c)
instance Show ContentEncryptionAlg where
show (ECB c) = shows c "_ECB"
show (CBC c) = shows c "_CBC"
show CBC_RC2 = "RC2_CBC"
show (CFB c) = shows c "_CFB"
show (CTR c) = shows c "_CTR"
instance Enumerable ContentEncryptionAlg where
values = [ CBC DES
, CBC DES_EDE3
, CBC AES128
, CBC AES192
, CBC AES256
, CBC CAST5
, CBC Camellia128
, CBC_RC2
, ECB DES
, ECB AES128
, ECB AES192
, ECB AES256
, ECB Camellia128
, CFB DES
, CFB AES128
, CFB AES192
, CFB AES256
, CFB Camellia128
, CTR Camellia128
]
instance OIDable ContentEncryptionAlg where
getObjectID (CBC DES) = [1,3,14,3,2,7]
getObjectID (CBC DES_EDE3) = [1,2,840,113549,3,7]
getObjectID (CBC AES128) = [2,16,840,1,101,3,4,1,2]
getObjectID (CBC AES192) = [2,16,840,1,101,3,4,1,22]
getObjectID (CBC AES256) = [2,16,840,1,101,3,4,1,42]
getObjectID (CBC CAST5) = [1,2,840,113533,7,66,10]
getObjectID (CBC Camellia128) = [1,2,392,200011,61,1,1,1,2]
getObjectID CBC_RC2 = [1,2,840,113549,3,2]
getObjectID (ECB DES) = [1,3,14,3,2,6]
getObjectID (ECB AES128) = [2,16,840,1,101,3,4,1,1]
getObjectID (ECB AES192) = [2,16,840,1,101,3,4,1,21]
getObjectID (ECB AES256) = [2,16,840,1,101,3,4,1,41]
getObjectID (ECB Camellia128) = [0,3,4401,5,3,1,9,1]
getObjectID (CFB DES) = [1,3,14,3,2,9]
getObjectID (CFB AES128) = [2,16,840,1,101,3,4,1,4]
getObjectID (CFB AES192) = [2,16,840,1,101,3,4,1,24]
getObjectID (CFB AES256) = [2,16,840,1,101,3,4,1,44]
getObjectID (CFB Camellia128) = [0,3,4401,5,3,1,9,4]
getObjectID (CTR Camellia128) = [0,3,4401,5,3,1,9,9]
getObjectID ty = error ("Unsupported ContentEncryptionAlg: " ++ show ty)
instance OIDNameable ContentEncryptionAlg where
fromObjectID oid = unOIDNW <$> fromObjectID oid
data ContentEncryptionParams
= forall c . BlockCipher c => ParamsECB (ContentEncryptionCipher c)
| forall c . BlockCipher c => ParamsCBC (ContentEncryptionCipher c) (IV c)
| ParamsCBCRC2 Int (IV RC2)
| forall c . BlockCipher c => ParamsCFB (ContentEncryptionCipher c) (IV c)
| forall c . BlockCipher c => ParamsCTR (ContentEncryptionCipher c) (IV c)
instance Show ContentEncryptionParams where
show = show . getContentEncryptionAlg
instance Eq ContentEncryptionParams where
ParamsECB c1 == ParamsECB c2 = cecI c1 == cecI c2
ParamsCBC c1 iv1 == ParamsCBC c2 iv2 = cecI c1 == cecI c2 && iv1 `B.eq` iv2
ParamsCBCRC2 i1 iv1 == ParamsCBCRC2 i2 iv2 = i1 == i2 && iv1 `B.eq` iv2
ParamsCFB c1 iv1 == ParamsCFB c2 iv2 = cecI c1 == cecI c2 && iv1 `B.eq` iv2
ParamsCTR c1 iv1 == ParamsCTR c2 iv2 = cecI c1 == cecI c2 && iv1 `B.eq` iv2
_ == _ = False
instance HasKeySize ContentEncryptionParams where
getKeySizeSpecifier (ParamsECB c) = getCipherKeySizeSpecifier c
getKeySizeSpecifier (ParamsCBC c _) = getCipherKeySizeSpecifier c
getKeySizeSpecifier (ParamsCBCRC2 i _) = KeySizeFixed $ (i + 7) `div` 8
getKeySizeSpecifier (ParamsCFB c _) = getCipherKeySizeSpecifier c
getKeySizeSpecifier (ParamsCTR c _) = getCipherKeySizeSpecifier c
instance ASN1Elem e => ProduceASN1Object e ContentEncryptionParams where
asn1s param =
asn1Container Sequence (oid . params)
where
oid = gOID (getObjectID $ getContentEncryptionAlg param)
params = ceParameterASN1S param
instance Monoid e => ParseASN1Object e ContentEncryptionParams where
parse = onNextContainer Sequence $ do
OID oid <- getNext
withObjectID "content encryption algorithm" oid parseCEParameter
ceParameterASN1S :: ASN1Elem e => ContentEncryptionParams -> ASN1Stream e
ceParameterASN1S (ParamsECB _) = id
ceParameterASN1S (ParamsCBC _ iv) = gOctetString (B.convert iv)
ceParameterASN1S (ParamsCBCRC2 len iv) = rc2ParameterASN1S len iv
ceParameterASN1S (ParamsCFB _ iv) = gOctetString (B.convert iv)
ceParameterASN1S (ParamsCTR _ iv) = gOctetString (B.convert iv)
parseCEParameter :: Monoid e
=> ContentEncryptionAlg -> ParseASN1 e ContentEncryptionParams
parseCEParameter (ECB c) = getMany getNext >> return (ParamsECB c)
parseCEParameter (CBC c) = ParamsCBC c <$> (getNext >>= getIV)
parseCEParameter CBC_RC2 = parseRC2Parameter
parseCEParameter (CFB c) = ParamsCFB c <$> (getNext >>= getIV)
parseCEParameter (CTR c) = ParamsCTR c <$> (getNext >>= getIV)
getIV :: BlockCipher cipher => ASN1 -> ParseASN1 e (IV cipher)
getIV (OctetString ivBs) =
case makeIV ivBs of
Nothing -> throwParseError "Bad IV in parsed parameters"
Just v -> return v
getIV _ = throwParseError "No IV in parsed parameter or incorrect format"
rc2ParameterASN1S :: ASN1Elem e => Int -> IV RC2 -> ASN1Stream e
rc2ParameterASN1S len iv
| len == 32 = gIV
| otherwise = asn1Container Sequence (rc2VersionASN1 len . gIV)
where gIV = gOctetString (B.convert iv)
parseRC2Parameter :: Monoid e => ParseASN1 e ContentEncryptionParams
parseRC2Parameter = parseOnlyIV 32 <|> parseFullParams
where
parseOnlyIV len = ParamsCBCRC2 len <$> (getNext >>= getIV)
parseFullParams = onNextContainer Sequence $
parseRC2Version >>= parseOnlyIV
getContentEncryptionAlg :: ContentEncryptionParams -> ContentEncryptionAlg
getContentEncryptionAlg (ParamsECB c) = ECB c
getContentEncryptionAlg (ParamsCBC c _) = CBC c
getContentEncryptionAlg (ParamsCBCRC2 _ _) = CBC_RC2
getContentEncryptionAlg (ParamsCFB c _) = CFB c
getContentEncryptionAlg (ParamsCTR c _) = CTR c
generateEncryptionParams :: MonadRandom m
=> ContentEncryptionAlg -> m ContentEncryptionParams
generateEncryptionParams (ECB c) = return (ParamsECB c)
generateEncryptionParams (CBC c) = ParamsCBC c <$> ivGenerate undefined
generateEncryptionParams CBC_RC2 = ParamsCBCRC2 128 <$> ivGenerate undefined
generateEncryptionParams (CFB c) = ParamsCFB c <$> ivGenerate undefined
generateEncryptionParams (CTR c) = ParamsCTR c <$> ivGenerate undefined
generateRC2EncryptionParams :: MonadRandom m
=> Int -> m ContentEncryptionParams
generateRC2EncryptionParams len = ParamsCBCRC2 len <$> ivGenerate undefined
contentEncrypt :: (ByteArray cek, ByteArray ba)
=> cek
-> ContentEncryptionParams
-> ba -> Either StoreError ba
contentEncrypt key params bs =
case params of
ParamsECB cipher -> getCipher cipher key >>= (\c -> force $ ecbEncrypt c $ padded c bs)
ParamsCBC cipher iv -> getCipher cipher key >>= (\c -> force $ cbcEncrypt c iv $ padded c bs)
ParamsCBCRC2 len iv -> getRC2Cipher len key >>= (\c -> force $ cbcEncrypt c iv $ padded c bs)
ParamsCFB cipher iv -> getCipher cipher key >>= (\c -> force $ cfbEncrypt c iv $ padded c bs)
ParamsCTR cipher iv -> getCipher cipher key >>= (\c -> force $ ctrCombine c iv $ padded c bs)
where
force x = x `seq` Right x
padded c = pad (PKCS7 $ blockSize c)
contentDecrypt :: (ByteArray cek, ByteArray ba)
=> cek
-> ContentEncryptionParams
-> ba -> Either StoreError ba
contentDecrypt key params bs =
case params of
ParamsECB cipher -> getCipher cipher key >>= (\c -> unpadded c (ecbDecrypt c bs))
ParamsCBC cipher iv -> getCipher cipher key >>= (\c -> unpadded c (cbcDecrypt c iv bs))
ParamsCBCRC2 len iv -> getRC2Cipher len key >>= (\c -> unpadded c (cbcDecrypt c iv bs))
ParamsCFB cipher iv -> getCipher cipher key >>= (\c -> unpadded c (cfbDecrypt c iv bs))
ParamsCTR cipher iv -> getCipher cipher key >>= (\c -> unpadded c (ctrCombine c iv bs))
where
unpadded c decrypted =
case unpad (PKCS7 $ blockSize c) decrypted of
Nothing -> Left DecryptionFailed
Just out -> Right out
rc2Table :: [Word8]
rc2Table =
[ 0xbd, 0x56, 0xea, 0xf2, 0xa2, 0xf1, 0xac, 0x2a, 0xb0, 0x93, 0xd1, 0x9c, 0x1b, 0x33, 0xfd, 0xd0
, 0x30, 0x04, 0xb6, 0xdc, 0x7d, 0xdf, 0x32, 0x4b, 0xf7, 0xcb, 0x45, 0x9b, 0x31, 0xbb, 0x21, 0x5a
, 0x41, 0x9f, 0xe1, 0xd9, 0x4a, 0x4d, 0x9e, 0xda, 0xa0, 0x68, 0x2c, 0xc3, 0x27, 0x5f, 0x80, 0x36
, 0x3e, 0xee, 0xfb, 0x95, 0x1a, 0xfe, 0xce, 0xa8, 0x34, 0xa9, 0x13, 0xf0, 0xa6, 0x3f, 0xd8, 0x0c
, 0x78, 0x24, 0xaf, 0x23, 0x52, 0xc1, 0x67, 0x17, 0xf5, 0x66, 0x90, 0xe7, 0xe8, 0x07, 0xb8, 0x60
, 0x48, 0xe6, 0x1e, 0x53, 0xf3, 0x92, 0xa4, 0x72, 0x8c, 0x08, 0x15, 0x6e, 0x86, 0x00, 0x84, 0xfa
, 0xf4, 0x7f, 0x8a, 0x42, 0x19, 0xf6, 0xdb, 0xcd, 0x14, 0x8d, 0x50, 0x12, 0xba, 0x3c, 0x06, 0x4e
, 0xec, 0xb3, 0x35, 0x11, 0xa1, 0x88, 0x8e, 0x2b, 0x94, 0x99, 0xb7, 0x71, 0x74, 0xd3, 0xe4, 0xbf
, 0x3a, 0xde, 0x96, 0x0e, 0xbc, 0x0a, 0xed, 0x77, 0xfc, 0x37, 0x6b, 0x03, 0x79, 0x89, 0x62, 0xc6
, 0xd7, 0xc0, 0xd2, 0x7c, 0x6a, 0x8b, 0x22, 0xa3, 0x5b, 0x05, 0x5d, 0x02, 0x75, 0xd5, 0x61, 0xe3
, 0x18, 0x8f, 0x55, 0x51, 0xad, 0x1f, 0x0b, 0x5e, 0x85, 0xe5, 0xc2, 0x57, 0x63, 0xca, 0x3d, 0x6c
, 0xb4, 0xc5, 0xcc, 0x70, 0xb2, 0x91, 0x59, 0x0d, 0x47, 0x20, 0xc8, 0x4f, 0x58, 0xe0, 0x01, 0xe2
, 0x16, 0x38, 0xc4, 0x6f, 0x3b, 0x0f, 0x65, 0x46, 0xbe, 0x7e, 0x2d, 0x7b, 0x82, 0xf9, 0x40, 0xb5
, 0x1d, 0x73, 0xf8, 0xeb, 0x26, 0xc7, 0x87, 0x97, 0x25, 0x54, 0xb1, 0x28, 0xaa, 0x98, 0x9d, 0xa5
, 0x64, 0x6d, 0x7a, 0xd4, 0x10, 0x81, 0x44, 0xef, 0x49, 0xd6, 0xae, 0x2e, 0xdd, 0x76, 0x5c, 0x2f
, 0xa7, 0x1c, 0xc9, 0x09, 0x69, 0x9a, 0x83, 0xcf, 0x29, 0x39, 0xb9, 0xe9, 0x4c, 0xff, 0x43, 0xab
]
rc2Forward :: B.Bytes
rc2Forward = B.pack rc2Table
rc2Reverse :: B.Bytes
rc2Reverse = B.allocAndFreeze (length rc2Table) (loop $ zip [0..] rc2Table)
where
loop :: [(Word8, Word8)] -> Ptr Word8 -> IO ()
loop [] _ = return ()
loop ((a,b):ts) p = pokeElemOff p (fromIntegral b) a >> loop ts p
rc2VersionASN1 :: ASN1Elem e => Int -> ASN1Stream e
rc2VersionASN1 len = gIntVal v
where
v | len < 0 = error "invalid RC2 effective key length"
| len >= 256 = fromIntegral len
| otherwise = fromIntegral (B.index rc2Forward len)
parseRC2Version :: Monoid e => ParseASN1 e Int
parseRC2Version = do
IntVal i <- getNext
when (i < 0) $ throwParseError "Parsed invalid RC2 effective key length"
let j = fromIntegral i
return $ if i >= 256 then j else fromIntegral (B.index rc2Reverse j)
data AuthContentEncryptionAlg
= AUTH_ENC_128
| AUTH_ENC_256
| CHACHA20_POLY1305
| forall c . BlockCipher c => CCM (ContentEncryptionCipher c)
| forall c . BlockCipher c => GCM (ContentEncryptionCipher c)
instance Show AuthContentEncryptionAlg where
show AUTH_ENC_128 = "AUTH_ENC_128"
show AUTH_ENC_256 = "AUTH_ENC_256"
show CHACHA20_POLY1305 = "CHACHA20_POLY1305"
show (CCM c) = shows c "_CCM"
show (GCM c) = shows c "_GCM"
instance Enumerable AuthContentEncryptionAlg where
values = [ AUTH_ENC_128
, AUTH_ENC_256
, CHACHA20_POLY1305
, CCM AES128
, CCM AES192
, CCM AES256
, GCM AES128
, GCM AES192
, GCM AES256
]
instance OIDable AuthContentEncryptionAlg where
getObjectID AUTH_ENC_128 = [1,2,840,113549,1,9,16,3,15]
getObjectID AUTH_ENC_256 = [1,2,840,113549,1,9,16,3,16]
getObjectID CHACHA20_POLY1305 = [1,2,840,113549,1,9,16,3,18]
getObjectID (CCM AES128) = [2,16,840,1,101,3,4,1,7]
getObjectID (CCM AES192) = [2,16,840,1,101,3,4,1,27]
getObjectID (CCM AES256) = [2,16,840,1,101,3,4,1,47]
getObjectID (GCM AES128) = [2,16,840,1,101,3,4,1,6]
getObjectID (GCM AES192) = [2,16,840,1,101,3,4,1,26]
getObjectID (GCM AES256) = [2,16,840,1,101,3,4,1,46]
getObjectID ty = error ("Unsupported AuthContentEncryptionAlg: " ++ show ty)
instance OIDNameable AuthContentEncryptionAlg where
fromObjectID oid = unOIDNW <$> fromObjectID oid
data AuthEncParams = AuthEncParams
{ prfAlgorithm :: PBKDF2_PRF
, encAlgorithm :: ContentEncryptionParams
, macAlgorithm :: MACAlgorithm
}
deriving (Show,Eq)
instance ASN1Elem e => ProduceASN1Object e AuthEncParams where
asn1s AuthEncParams{..} = asn1Container Sequence (kdf . encAlg . macAlg)
where
kdf = algorithmASN1S (Container Context 0) (asKDF prfAlgorithm)
encAlg = asn1s encAlgorithm
macAlg = algorithmASN1S Sequence macAlgorithm
asKDF algPrf = PBKDF2 { pbkdf2Salt = B.empty
, pbkdf2IterationCount = 1
, pbkdf2KeyLength = Nothing
, pbkdf2Prf = algPrf
}
instance Monoid e => ParseASN1Object e AuthEncParams where
parse = onNextContainer Sequence $ do
kdf <- parseAlgorithmMaybe (Container Context 0)
encAlg <- parse
macAlg <- parseAlgorithm Sequence
prfAlg <-
case kdf of
Nothing -> return PBKDF2_SHA1
Just (PBKDF2 _ _ _ a) -> return a
Just other -> throwParseError
("Unable to use " ++ show other ++ " in AuthEncParams")
return AuthEncParams { prfAlgorithm = prfAlg
, encAlgorithm = encAlg
, macAlgorithm = macAlg
}
data AuthContentEncryptionParams
= Params_AUTH_ENC_128 AuthEncParams
| Params_AUTH_ENC_256 AuthEncParams
| Params_CHACHA20_POLY1305 ChaChaPoly1305.Nonce
| forall c . BlockCipher c => ParamsCCM (ContentEncryptionCipher c) B.Bytes CCM_M CCM_L
| forall c . BlockCipher c => ParamsGCM (ContentEncryptionCipher c) B.Bytes Int
instance Show AuthContentEncryptionParams where
show = show . getAuthContentEncryptionAlg
instance Eq AuthContentEncryptionParams where
Params_AUTH_ENC_128 p1 == Params_AUTH_ENC_128 p2 = p1 == p2
Params_AUTH_ENC_256 p1 == Params_AUTH_ENC_256 p2 = p1 == p2
Params_CHACHA20_POLY1305 iv1 == Params_CHACHA20_POLY1305 iv2 =
iv1 `B.eq` iv2
ParamsCCM c1 iv1 m1 l1 == ParamsCCM c2 iv2 m2 l2 =
cecI c1 == cecI c2 && iv1 == iv2 && (m1, l1) == (m2, l2)
ParamsGCM c1 iv1 len1 == ParamsGCM c2 iv2 len2 =
cecI c1 == cecI c2 && iv1 == iv2 && len1 == len2
_ == _ = False
instance HasKeySize AuthContentEncryptionParams where
getKeySizeSpecifier (Params_AUTH_ENC_128 _) = KeySizeFixed 16
getKeySizeSpecifier (Params_AUTH_ENC_256 _) = KeySizeFixed 32
getKeySizeSpecifier (Params_CHACHA20_POLY1305 _) = KeySizeFixed 32
getKeySizeSpecifier (ParamsCCM c _ _ _) = getCipherKeySizeSpecifier c
getKeySizeSpecifier (ParamsGCM c _ _) = getCipherKeySizeSpecifier c
instance ASN1Elem e => ProduceASN1Object e AuthContentEncryptionParams where
asn1s param =
asn1Container Sequence (oid . params)
where
oid = gOID (getObjectID $ getAuthContentEncryptionAlg param)
params = aceParameterASN1S param
instance Monoid e => ParseASN1Object e AuthContentEncryptionParams where
parse = onNextContainer Sequence $ do
OID oid <- getNext
withObjectID "authenticated-content encryption algorithm" oid
parseACEParameter
aceParameterASN1S :: ASN1Elem e => AuthContentEncryptionParams -> ASN1Stream e
aceParameterASN1S (Params_AUTH_ENC_128 p) = asn1s p
aceParameterASN1S (Params_AUTH_ENC_256 p) = asn1s p
aceParameterASN1S (Params_CHACHA20_POLY1305 iv) = gOctetString (B.convert iv)
aceParameterASN1S (ParamsCCM _ iv m _) =
asn1Container Sequence (nonce . icvlen)
where
nonce = gOctetString (B.convert iv)
icvlen = gIntVal (fromIntegral $ getM m)
aceParameterASN1S (ParamsGCM _ iv len) =
asn1Container Sequence (nonce . icvlen)
where
nonce = gOctetString (B.convert iv)
icvlen = gIntVal (fromIntegral len)
parseACEParameter :: Monoid e
=> AuthContentEncryptionAlg
-> ParseASN1 e AuthContentEncryptionParams
parseACEParameter AUTH_ENC_128 = Params_AUTH_ENC_128 <$> parse
parseACEParameter AUTH_ENC_256 = Params_AUTH_ENC_256 <$> parse
parseACEParameter CHACHA20_POLY1305 = do
OctetString bs <- getNext
case ChaChaPoly1305.nonce12 bs of
CryptoPassed iv -> return (Params_CHACHA20_POLY1305 iv)
CryptoFailed e ->
throwParseError $ "Parsed invalid ChaChaPoly1305 nonce: " ++ show e
parseACEParameter (CCM c) = onNextContainer Sequence $ do
OctetString iv <- getNext
let ivlen = B.length iv
when (ivlen < 7 || ivlen > 13) $
throwParseError $ "Parsed invalid CCM nonce length: " ++ show ivlen
let Just l = fromL (15 - ivlen)
m <- parseM
return (ParamsCCM c (B.convert iv) m l)
parseACEParameter (GCM c) = onNextContainer Sequence $ do
OctetString iv <- getNext
when (B.null iv) $
throwParseError "Parsed empty GCM nonce"
icvlen <- fromMaybe 12 <$> getNextMaybe intOrNothing
when (icvlen < 12 || icvlen > 16) $
throwParseError $ "Parsed invalid GCM ICV length: " ++ show icvlen
return (ParamsGCM c (B.convert iv) $ fromIntegral icvlen)
getAuthContentEncryptionAlg :: AuthContentEncryptionParams
-> AuthContentEncryptionAlg
getAuthContentEncryptionAlg (Params_AUTH_ENC_128 _) = AUTH_ENC_128
getAuthContentEncryptionAlg (Params_AUTH_ENC_256 _) = AUTH_ENC_256
getAuthContentEncryptionAlg (Params_CHACHA20_POLY1305 _) = CHACHA20_POLY1305
getAuthContentEncryptionAlg (ParamsCCM c _ _ _) = CCM c
getAuthContentEncryptionAlg (ParamsGCM c _ _) = GCM c
generateAuthEnc128Params :: MonadRandom m
=> PBKDF2_PRF -> ContentEncryptionAlg -> MACAlgorithm
-> m AuthContentEncryptionParams
generateAuthEnc128Params prfAlg cea macAlg = do
params <- generateEncryptionParams cea
return $ Params_AUTH_ENC_128 $
AuthEncParams { prfAlgorithm = prfAlg
, encAlgorithm = params
, macAlgorithm = macAlg
}
generateAuthEnc256Params :: MonadRandom m
=> PBKDF2_PRF -> ContentEncryptionAlg -> MACAlgorithm
-> m AuthContentEncryptionParams
generateAuthEnc256Params prfAlg cea macAlg = do
params <- generateEncryptionParams cea
return $ Params_AUTH_ENC_256 $
AuthEncParams { prfAlgorithm = prfAlg
, encAlgorithm = params
, macAlgorithm = macAlg
}
generateChaChaPoly1305Params :: MonadRandom m => m AuthContentEncryptionParams
generateChaChaPoly1305Params = do
bs <- nonceGenerate 12
let iv = throwCryptoError (ChaChaPoly1305.nonce12 bs)
return (Params_CHACHA20_POLY1305 iv)
generateCCMParams :: (MonadRandom m, BlockCipher c)
=> ContentEncryptionCipher c -> CCM_M -> CCM_L
-> m AuthContentEncryptionParams
generateCCMParams c m l = do
iv <- nonceGenerate (15 - getL l)
return (ParamsCCM c iv m l)
generateGCMParams :: (MonadRandom m, BlockCipher c)
=> ContentEncryptionCipher c -> Int
-> m AuthContentEncryptionParams
generateGCMParams c l = do
iv <- nonceGenerate 12
return (ParamsGCM c iv l)
authContentEncrypt :: forall cek aad ba . (ByteArray cek, ByteArrayAccess aad, ByteArray ba)
=> cek
-> AuthContentEncryptionParams -> ba
-> aad -> ba -> Either StoreError (AuthTag, ba)
authContentEncrypt key params paramsRaw aad bs =
case params of
Params_AUTH_ENC_128 p -> checkAuthKey 16 key >> authEncrypt p
Params_AUTH_ENC_256 p -> checkAuthKey 32 key >> authEncrypt p
Params_CHACHA20_POLY1305 iv -> ccpInit key iv aad >>= ccpEncrypt
ParamsCCM cipher iv m l -> getAEAD cipher key (AEAD_CCM msglen m l) iv >>= encrypt (getM m)
ParamsGCM cipher iv len -> getAEAD cipher key AEAD_GCM iv >>= encrypt len
where
msglen = B.length bs
force x = x `seq` Right x
encrypt :: Int -> AEAD a -> Either StoreError (AuthTag, ba)
encrypt len aead = force $ aeadSimpleEncrypt aead aad bs len
ccpEncrypt :: ChaChaPoly1305.State -> Either a (AuthTag, ba)
ccpEncrypt state = force (found, encrypted)
where
(encrypted, state') = ChaChaPoly1305.encrypt bs state
found = ccpTag (ChaChaPoly1305.finalize state')
authEncrypt :: AuthEncParams -> Either StoreError (AuthTag, ba)
authEncrypt p@AuthEncParams{..} = do
let (encKey, macKey) = authKeys key p
encrypted <- contentEncrypt encKey encAlgorithm bs
let macMsg = paramsRaw `B.append` encrypted `B.append` B.convert aad
found = mac macAlgorithm macKey macMsg
return (found, encrypted)
authContentDecrypt :: forall cek aad ba . (ByteArray cek, ByteArrayAccess aad, ByteArray ba)
=> cek
-> AuthContentEncryptionParams -> ba
-> aad -> ba -> AuthTag -> Either StoreError ba
authContentDecrypt key params paramsRaw aad bs expected =
case params of
Params_AUTH_ENC_128 p -> checkAuthKey 16 key >> authDecrypt p
Params_AUTH_ENC_256 p -> checkAuthKey 32 key >> authDecrypt p
Params_CHACHA20_POLY1305 iv -> ccpInit key iv aad >>= ccpDecrypt
ParamsCCM cipher iv m l -> getAEAD cipher key (AEAD_CCM msglen m l) iv >>= decrypt
ParamsGCM cipher iv _ -> getAEAD cipher key AEAD_GCM iv >>= decrypt
where
msglen = B.length bs
badMac = Left BadContentMAC
decrypt :: AEAD a -> Either StoreError ba
decrypt aead = maybe badMac Right (aeadSimpleDecrypt aead aad bs expected)
ccpDecrypt :: ChaChaPoly1305.State -> Either StoreError ba
ccpDecrypt state
| found == expected = Right decrypted
| otherwise = badMac
where
(decrypted, state') = ChaChaPoly1305.decrypt bs state
found = ccpTag (ChaChaPoly1305.finalize state')
authDecrypt :: AuthEncParams -> Either StoreError ba
authDecrypt p@AuthEncParams{..}
| found == expected = contentDecrypt encKey encAlgorithm bs
| otherwise = badMac
where
(encKey, macKey) = authKeys key p
macMsg = paramsRaw `B.append` bs `B.append` B.convert aad
found = mac macAlgorithm macKey macMsg
getAEAD :: (BlockCipher cipher, ByteArray key, ByteArrayAccess iv)
=> proxy cipher -> key -> AEADMode -> iv -> Either StoreError (AEAD cipher)
getAEAD cipher key mode iv = do
c <- getCipher cipher key
fromCryptoFailable $ aeadInit mode c iv
authKeys :: ByteArrayAccess password
=> password -> AuthEncParams
-> (B.ScrubbedBytes, B.ScrubbedBytes)
authKeys key AuthEncParams{..} = (encKey, macKey)
where
encKDF = PBKDF2 "encryption" 1 Nothing prfAlgorithm
encLen = getMaximumKeySize encAlgorithm
encKey = kdfDerive encKDF encLen key
macKDF = PBKDF2 "authentication" 1 Nothing prfAlgorithm
macKey = kdfDerive macKDF macLen key
macLen | encLen == 24 = 16
| otherwise = getMaximumKeySize macAlgorithm
checkAuthKey :: ByteArrayAccess cek => Int -> cek -> Either StoreError ()
checkAuthKey sz key
| actual == sz = Right ()
| otherwise = Left (CryptoError CryptoError_KeySizeInvalid)
where actual = B.length key
ccpInit :: (ByteArrayAccess key, ByteArrayAccess aad)
=> key
-> ChaChaPoly1305.Nonce
-> aad
-> Either StoreError ChaChaPoly1305.State
ccpInit key nonce aad = case ChaChaPoly1305.initialize key nonce of
CryptoPassed s -> return (addAAD s)
CryptoFailed e -> Left (CryptoError e)
where addAAD = ChaChaPoly1305.finalizeAAD . ChaChaPoly1305.appendAAD aad
ccpTag :: Poly1305.Auth -> AuthTag
ccpTag (Poly1305.Auth bs) = AuthTag bs
data PBKDF2_PRF = PBKDF2_SHA1
| PBKDF2_SHA256
| PBKDF2_SHA512
deriving (Show,Eq)
instance Enumerable PBKDF2_PRF where
values = [ PBKDF2_SHA1
, PBKDF2_SHA256
, PBKDF2_SHA512
]
instance OIDable PBKDF2_PRF where
getObjectID PBKDF2_SHA1 = [1,2,840,113549,2,7]
getObjectID PBKDF2_SHA256 = [1,2,840,113549,2,9]
getObjectID PBKDF2_SHA512 = [1,2,840,113549,2,11]
instance OIDNameable PBKDF2_PRF where
fromObjectID oid = unOIDNW <$> fromObjectID oid
instance AlgorithmId PBKDF2_PRF where
type AlgorithmType PBKDF2_PRF = PBKDF2_PRF
algorithmName _ = "PBKDF2 PRF"
algorithmType = id
parameterASN1S _ = id
parseParameter p = getNextMaybe nullOrNothing >> return p
prf :: (ByteArrayAccess salt, ByteArrayAccess password, ByteArray out)
=> PBKDF2_PRF -> PBKDF2.Parameters -> password -> salt -> out
prf PBKDF2_SHA1 = PBKDF2.fastPBKDF2_SHA1
prf PBKDF2_SHA256 = PBKDF2.fastPBKDF2_SHA256
prf PBKDF2_SHA512 = PBKDF2.fastPBKDF2_SHA512
type Salt = ByteString
data KeyDerivationAlgorithm = TypePBKDF2 | TypeScrypt
instance Enumerable KeyDerivationAlgorithm where
values = [ TypePBKDF2
, TypeScrypt
]
instance OIDable KeyDerivationAlgorithm where
getObjectID TypePBKDF2 = [1,2,840,113549,1,5,12]
getObjectID TypeScrypt = [1,3,6,1,4,1,11591,4,11]
instance OIDNameable KeyDerivationAlgorithm where
fromObjectID oid = unOIDNW <$> fromObjectID oid
data KeyDerivationFunc =
PBKDF2 { pbkdf2Salt :: Salt
, pbkdf2IterationCount :: Int
, pbkdf2KeyLength :: Maybe Int
, pbkdf2Prf :: PBKDF2_PRF
}
| Scrypt { scryptSalt :: Salt
, scryptN :: Word64
, scryptR :: Int
, scryptP :: Int
, scryptKeyLength :: Maybe Int
}
deriving (Show,Eq)
instance AlgorithmId KeyDerivationFunc where
type AlgorithmType KeyDerivationFunc = KeyDerivationAlgorithm
algorithmName _ = "key derivation algorithm"
algorithmType PBKDF2{..} = TypePBKDF2
algorithmType Scrypt{..} = TypeScrypt
parameterASN1S PBKDF2{..} =
asn1Container Sequence (salt . iters . keyLen . mprf)
where
salt = gOctetString pbkdf2Salt
iters = gIntVal (toInteger pbkdf2IterationCount)
keyLen = maybe id (gIntVal . toInteger) pbkdf2KeyLength
mprf = if pbkdf2Prf == PBKDF2_SHA1 then id else algorithmASN1S Sequence pbkdf2Prf
parameterASN1S Scrypt{..} =
asn1Container Sequence (salt . n . r . p . keyLen)
where
salt = gOctetString scryptSalt
n = gIntVal (toInteger scryptN)
r = gIntVal (toInteger scryptR)
p = gIntVal (toInteger scryptP)
keyLen = maybe id (gIntVal . toInteger) scryptKeyLength
parseParameter TypePBKDF2 = onNextContainer Sequence $ do
OctetString salt <- getNext
IntVal iters <- getNext
keyLen <- getNextMaybe intOrNothing
b <- hasNext
mprf <- if b then parseAlgorithm Sequence else return PBKDF2_SHA1
return PBKDF2 { pbkdf2Salt = salt
, pbkdf2IterationCount = fromInteger iters
, pbkdf2KeyLength = fromInteger <$> keyLen
, pbkdf2Prf = mprf
}
parseParameter TypeScrypt = onNextContainer Sequence $ do
OctetString salt <- getNext
IntVal n <- getNext
IntVal r <- getNext
IntVal p <- getNext
keyLen <- getNextMaybe intOrNothing
return Scrypt { scryptSalt = salt
, scryptN = fromInteger n
, scryptR = fromInteger r
, scryptP = fromInteger p
, scryptKeyLength = fromInteger <$> keyLen
}
kdfKeyLength :: KeyDerivationFunc -> Maybe Int
kdfKeyLength PBKDF2{..} = pbkdf2KeyLength
kdfKeyLength Scrypt{..} = scryptKeyLength
kdfDerive :: (ByteArrayAccess password, ByteArray out)
=> KeyDerivationFunc -> Int -> password -> out
kdfDerive PBKDF2{..} len pwd = prf pbkdf2Prf params pwd pbkdf2Salt
where params = PBKDF2.Parameters pbkdf2IterationCount len
kdfDerive Scrypt{..} len pwd = Scrypt.generate params pwd scryptSalt
where params = Scrypt.Parameters { Scrypt.n = scryptN
, Scrypt.r = scryptR
, Scrypt.p = scryptP
, Scrypt.outputLength = len
}
generateSalt :: MonadRandom m => Int -> m Salt
generateSalt = getRandomBytes
data KeyEncryptionType = TypePWRIKEK
| TypeAES128_WRAP
| TypeAES192_WRAP
| TypeAES256_WRAP
| TypeAES128_WRAP_PAD
| TypeAES192_WRAP_PAD
| TypeAES256_WRAP_PAD
| TypeDES_EDE3_WRAP
| TypeRC2_WRAP
instance Enumerable KeyEncryptionType where
values = [ TypePWRIKEK
, TypeAES128_WRAP
, TypeAES192_WRAP
, TypeAES256_WRAP
, TypeAES128_WRAP_PAD
, TypeAES192_WRAP_PAD
, TypeAES256_WRAP_PAD
, TypeDES_EDE3_WRAP
, TypeRC2_WRAP
]
instance OIDable KeyEncryptionType where
getObjectID TypePWRIKEK = [1,2,840,113549,1,9,16,3,9]
getObjectID TypeAES128_WRAP = [2,16,840,1,101,3,4,1,5]
getObjectID TypeAES192_WRAP = [2,16,840,1,101,3,4,1,25]
getObjectID TypeAES256_WRAP = [2,16,840,1,101,3,4,1,45]
getObjectID TypeAES128_WRAP_PAD = [2,16,840,1,101,3,4,1,8]
getObjectID TypeAES192_WRAP_PAD = [2,16,840,1,101,3,4,1,28]
getObjectID TypeAES256_WRAP_PAD = [2,16,840,1,101,3,4,1,48]
getObjectID TypeDES_EDE3_WRAP = [1,2,840,113549,1,9,16,3,6]
getObjectID TypeRC2_WRAP = [1,2,840,113549,1,9,16,3,7]
instance OIDNameable KeyEncryptionType where
fromObjectID oid = unOIDNW <$> fromObjectID oid
data KeyEncryptionParams = PWRIKEK ContentEncryptionParams
| AES128_WRAP
| AES192_WRAP
| AES256_WRAP
| AES128_WRAP_PAD
| AES192_WRAP_PAD
| AES256_WRAP_PAD
| DES_EDE3_WRAP
| RC2_WRAP Int
deriving (Show,Eq)
instance AlgorithmId KeyEncryptionParams where
type AlgorithmType KeyEncryptionParams = KeyEncryptionType
algorithmName _ = "key encryption algorithm"
algorithmType (PWRIKEK _) = TypePWRIKEK
algorithmType AES128_WRAP = TypeAES128_WRAP
algorithmType AES192_WRAP = TypeAES192_WRAP
algorithmType AES256_WRAP = TypeAES256_WRAP
algorithmType AES128_WRAP_PAD = TypeAES128_WRAP_PAD
algorithmType AES192_WRAP_PAD = TypeAES192_WRAP_PAD
algorithmType AES256_WRAP_PAD = TypeAES256_WRAP_PAD
algorithmType DES_EDE3_WRAP = TypeDES_EDE3_WRAP
algorithmType (RC2_WRAP _) = TypeRC2_WRAP
parameterASN1S (PWRIKEK cep) = asn1s cep
parameterASN1S DES_EDE3_WRAP = gNull
parameterASN1S (RC2_WRAP ekl) = rc2VersionASN1 ekl
parameterASN1S _ = id
parseParameter TypePWRIKEK = PWRIKEK <$> parse
parseParameter TypeAES128_WRAP = return AES128_WRAP
parseParameter TypeAES192_WRAP = return AES192_WRAP
parseParameter TypeAES256_WRAP = return AES256_WRAP
parseParameter TypeAES128_WRAP_PAD = return AES128_WRAP_PAD
parseParameter TypeAES192_WRAP_PAD = return AES192_WRAP_PAD
parseParameter TypeAES256_WRAP_PAD = return AES256_WRAP_PAD
parseParameter TypeDES_EDE3_WRAP = getNextMaybe nullOrNothing >> return DES_EDE3_WRAP
parseParameter TypeRC2_WRAP = RC2_WRAP <$> parseRC2Version
instance HasKeySize KeyEncryptionParams where
getKeySizeSpecifier (PWRIKEK cep) = getKeySizeSpecifier cep
getKeySizeSpecifier AES128_WRAP = getCipherKeySizeSpecifier AES128
getKeySizeSpecifier AES192_WRAP = getCipherKeySizeSpecifier AES192
getKeySizeSpecifier AES256_WRAP = getCipherKeySizeSpecifier AES256
getKeySizeSpecifier AES128_WRAP_PAD = getCipherKeySizeSpecifier AES128
getKeySizeSpecifier AES192_WRAP_PAD = getCipherKeySizeSpecifier AES192
getKeySizeSpecifier AES256_WRAP_PAD = getCipherKeySizeSpecifier AES256
getKeySizeSpecifier DES_EDE3_WRAP = getCipherKeySizeSpecifier DES_EDE3
getKeySizeSpecifier (RC2_WRAP _) = KeySizeFixed 16
keyEncrypt :: (MonadRandom m, ByteArray kek, ByteArray ba)
=> kek -> KeyEncryptionParams -> ba -> m (Either StoreError ba)
keyEncrypt key (PWRIKEK params) bs =
case params of
ParamsECB cipher -> let cc = getCipher cipher key in either (return . Left) (\c -> wrapEncrypt (const . ecbEncrypt) c undefined bs) cc
ParamsCBC cipher iv -> let cc = getCipher cipher key in either (return . Left) (\c -> wrapEncrypt cbcEncrypt c iv bs) cc
ParamsCBCRC2 len iv -> let cc = getRC2Cipher len key in either (return . Left) (\c -> wrapEncrypt cbcEncrypt c iv bs) cc
ParamsCFB cipher iv -> let cc = getCipher cipher key in either (return . Left) (\c -> wrapEncrypt cfbEncrypt c iv bs) cc
ParamsCTR _ _ -> return $ Left (InvalidParameter "Unable to wrap key in CTR mode")
keyEncrypt key AES128_WRAP bs = return (getCipher AES128 key >>= (`AES_KW.wrap` bs))
keyEncrypt key AES192_WRAP bs = return (getCipher AES192 key >>= (`AES_KW.wrap` bs))
keyEncrypt key AES256_WRAP bs = return (getCipher AES256 key >>= (`AES_KW.wrap` bs))
keyEncrypt key AES128_WRAP_PAD bs = return (getCipher AES128 key >>= (`AES_KW.wrapPad` bs))
keyEncrypt key AES192_WRAP_PAD bs = return (getCipher AES192 key >>= (`AES_KW.wrapPad` bs))
keyEncrypt key AES256_WRAP_PAD bs = return (getCipher AES256 key >>= (`AES_KW.wrapPad` bs))
keyEncrypt key DES_EDE3_WRAP bs = either (return . Left) (wrap3DES bs) (getCipher DES_EDE3 key)
where wrap3DES b c = (\iv -> TripleDES_KW.wrap c iv b) <$> ivGenerate c
keyEncrypt key (RC2_WRAP ekl) bs = either (return . Left) (wrapRC2 bs) (getRC2Cipher ekl key)
where wrapRC2 b c = do iv <- ivGenerate c; RC2_KW.wrap c iv b
keyDecrypt :: (ByteArray kek, ByteArray ba)
=> kek -> KeyEncryptionParams -> ba -> Either StoreError ba
keyDecrypt key (PWRIKEK params) bs =
case params of
ParamsECB cipher -> getCipher cipher key >>= (\c -> wrapDecrypt (const . ecbDecrypt) c undefined bs)
ParamsCBC cipher iv -> getCipher cipher key >>= (\c -> wrapDecrypt cbcDecrypt c iv bs)
ParamsCBCRC2 len iv -> getRC2Cipher len key >>= (\c -> wrapDecrypt cbcDecrypt c iv bs)
ParamsCFB cipher iv -> getCipher cipher key >>= (\c -> wrapDecrypt cfbDecrypt c iv bs)
ParamsCTR _ _ -> Left (InvalidParameter "Unable to unwrap key in CTR mode")
keyDecrypt key AES128_WRAP bs = getCipher AES128 key >>= (`AES_KW.unwrap` bs)
keyDecrypt key AES192_WRAP bs = getCipher AES192 key >>= (`AES_KW.unwrap` bs)
keyDecrypt key AES256_WRAP bs = getCipher AES256 key >>= (`AES_KW.unwrap` bs)
keyDecrypt key AES128_WRAP_PAD bs = getCipher AES128 key >>= (`AES_KW.unwrapPad` bs)
keyDecrypt key AES192_WRAP_PAD bs = getCipher AES192 key >>= (`AES_KW.unwrapPad` bs)
keyDecrypt key AES256_WRAP_PAD bs = getCipher AES256 key >>= (`AES_KW.unwrapPad` bs)
keyDecrypt key DES_EDE3_WRAP bs = getCipher DES_EDE3 key >>= (`TripleDES_KW.unwrap` bs)
keyDecrypt key (RC2_WRAP ekl) bs = getRC2Cipher ekl key >>= (`RC2_KW.unwrap` bs)
keyWrap :: (MonadRandom m, ByteArray ba)
=> Int -> ba -> m (Either StoreError ba)
keyWrap sz input
| inLen < 3 = return $ Left (InvalidInput "keyWrap: input key too short")
| inLen > 255 = return $ Left (InvalidInput "keyWrap: input key too long")
| pLen == 0 = return $ Right $ B.concat [ count, check, input ]
| otherwise = do
padding <- getRandomBytes pLen
return $ Right $ B.concat [ count, check, input, padding ]
where
inLen = B.length input
count = B.singleton (fromIntegral inLen)
check = B.xor input (B.pack [255, 255, 255] :: B.Bytes)
pLen = sz - (inLen + 4) `mod` sz + comp
comp = if inLen + 4 > sz then 0 else sz
keyUnwrap :: ByteArray ba => ba -> Either StoreError ba
keyUnwrap input
| inLen < 4 = Left (InvalidInput "keyUnwrap: invalid wrapped key")
| valid = Right $ B.take count (B.drop 4 input)
| otherwise = Left (InvalidInput "keyUnwrap: invalid wrapped key")
where
inLen = B.length input
count = fromIntegral (B.index input 0)
bytes = [ B.index input (i + 1) `xor` B.index input (i + 4) | i <- [0..2] ]
valid = foldl1 (.&.) bytes == 0xFF &&! inLen >= count - 4
wrapEncrypt :: (MonadRandom m, BlockCipher cipher, ByteArray ba)
=> (cipher -> IV cipher -> ba -> ba)
-> cipher -> IV cipher -> ba -> m (Either StoreError ba)
wrapEncrypt encFn cipher iv input = do
wrapped <- keyWrap sz input
return (fn <$> wrapped)
where
sz = blockSize cipher
fn formatted =
let firstPass = encFn cipher iv formatted
lastBlock = B.dropView firstPass (B.length firstPass - sz)
Just iv' = makeIV lastBlock
in encFn cipher iv' firstPass
wrapDecrypt :: (BlockCipher cipher, ByteArray ba)
=> (cipher -> IV cipher -> ba -> ba)
-> cipher -> IV cipher -> ba -> Either StoreError ba
wrapDecrypt decFn cipher iv input = keyUnwrap (decFn cipher iv firstPass)
where
sz = blockSize cipher
(beg, lb) = B.splitAt (B.length input - sz) input
lastBlock = decFn cipher iv' lb
Just iv' = makeIV (B.dropView beg (B.length beg - sz))
Just iv'' = makeIV lastBlock
firstPass = decFn cipher iv'' beg `B.append` lastBlock
data OAEPParams = OAEPParams
{ oaepHashAlgorithm :: DigestAlgorithm
, oaepMaskGenAlgorithm :: MaskGenerationFunc
}
deriving (Show,Eq)
withOAEPParams :: forall seed output a . (ByteArrayAccess seed, ByteArray output)
=> OAEPParams
-> (forall hash . Hash.HashAlgorithm hash => RSAOAEP.OAEPParams hash seed output -> a)
-> a
withOAEPParams p fn =
case oaepHashAlgorithm p of
DigestAlgorithm hashAlg ->
fn RSAOAEP.OAEPParams
{ RSAOAEP.oaepHash = hashFromProxy hashAlg
, RSAOAEP.oaepMaskGenAlg = mgf (oaepMaskGenAlgorithm p)
, RSAOAEP.oaepLabel = Nothing
}
instance ASN1Elem e => ProduceASN1Object e OAEPParams where
asn1s OAEPParams{..} =
asn1Container Sequence (h . m)
where
sha1 = DigestAlgorithm SHA1
tag i = asn1Container (Container Context i)
h | oaepHashAlgorithm == sha1 = id
| otherwise = tag 0 (algorithmASN1S Sequence oaepHashAlgorithm)
m | oaepMaskGenAlgorithm == MGF1 sha1 = id
| otherwise = tag 1 (algorithmASN1S Sequence oaepMaskGenAlgorithm)
instance Monoid e => ParseASN1Object e OAEPParams where
parse = onNextContainer Sequence $ do
h <- tag 0 (parseAlgorithm Sequence)
m <- tag 1 (parseAlgorithm Sequence)
_ <- tag 2 parsePSpecified
return OAEPParams { oaepHashAlgorithm = fromMaybe sha1 h
, oaepMaskGenAlgorithm = fromMaybe (MGF1 sha1) m
}
where
sha1 = DigestAlgorithm SHA1
tag i = onNextContainerMaybe (Container Context i)
parsePSpecified = do
OID [1,2,840,113549,1,1,9] <- getNext
OctetString p <- getNext
guard (B.null p)
data KeyTransportType = TypeRSAES
| TypeRSAESOAEP
instance Enumerable KeyTransportType where
values = [ TypeRSAES
, TypeRSAESOAEP
]
instance OIDable KeyTransportType where
getObjectID TypeRSAES = [1,2,840,113549,1,1,1]
getObjectID TypeRSAESOAEP = [1,2,840,113549,1,1,7]
instance OIDNameable KeyTransportType where
fromObjectID oid = unOIDNW <$> fromObjectID oid
data KeyTransportParams = RSAES
| RSAESOAEP OAEPParams
deriving (Show,Eq)
instance AlgorithmId KeyTransportParams where
type AlgorithmType KeyTransportParams = KeyTransportType
algorithmName _ = "key transport algorithm"
algorithmType RSAES = TypeRSAES
algorithmType (RSAESOAEP _) = TypeRSAESOAEP
parameterASN1S RSAES = gNull
parameterASN1S (RSAESOAEP p) = asn1s p
parseParameter TypeRSAES = getNextMaybe nullOrNothing >> return RSAES
parseParameter TypeRSAESOAEP = RSAESOAEP <$> parse
transportEncrypt :: MonadRandom m
=> KeyTransportParams
-> X509.PubKey
-> ByteString
-> m (Either StoreError ByteString)
transportEncrypt RSAES (X509.PubKeyRSA pub) bs =
mapLeft RSAError <$> RSA.encrypt pub bs
transportEncrypt (RSAESOAEP p) (X509.PubKeyRSA pub) bs =
withOAEPParams p $ \params ->
mapLeft RSAError <$> RSAOAEP.encrypt params pub bs
transportEncrypt _ _ _ = return $ Left UnexpectedPublicKeyType
transportDecrypt :: MonadRandom m
=> KeyTransportParams
-> X509.PrivKey
-> ByteString
-> m (Either StoreError ByteString)
transportDecrypt RSAES (X509.PrivKeyRSA priv) bs =
mapLeft RSAError <$> RSA.decryptSafer priv bs
transportDecrypt (RSAESOAEP p) (X509.PrivKeyRSA priv) bs =
withOAEPParams p $ \params ->
mapLeft RSAError <$> RSAOAEP.decryptSafer params priv bs
transportDecrypt _ _ _ = return $ Left UnexpectedPrivateKeyType
data KeyAgreementType = TypeStdDH DigestAlgorithm
| TypeCofactorDH DigestAlgorithm
deriving (Show,Eq)
instance Enumerable KeyAgreementType where
values = [ TypeStdDH (DigestAlgorithm SHA1)
, TypeStdDH (DigestAlgorithm SHA224)
, TypeStdDH (DigestAlgorithm SHA256)
, TypeStdDH (DigestAlgorithm SHA384)
, TypeStdDH (DigestAlgorithm SHA512)
, TypeCofactorDH (DigestAlgorithm SHA1)
, TypeCofactorDH (DigestAlgorithm SHA224)
, TypeCofactorDH (DigestAlgorithm SHA256)
, TypeCofactorDH (DigestAlgorithm SHA384)
, TypeCofactorDH (DigestAlgorithm SHA512)
]
instance OIDable KeyAgreementType where
getObjectID (TypeStdDH (DigestAlgorithm SHA1)) = [1,3,133,16,840,63,0,2]
getObjectID (TypeStdDH (DigestAlgorithm SHA224)) = [1,3,132,1,11,0]
getObjectID (TypeStdDH (DigestAlgorithm SHA256)) = [1,3,132,1,11,1]
getObjectID (TypeStdDH (DigestAlgorithm SHA384)) = [1,3,132,1,11,2]
getObjectID (TypeStdDH (DigestAlgorithm SHA512)) = [1,3,132,1,11,3]
getObjectID (TypeCofactorDH (DigestAlgorithm SHA1)) = [1,3,133,16,840,63,0,3]
getObjectID (TypeCofactorDH (DigestAlgorithm SHA224)) = [1,3,132,1,14,0]
getObjectID (TypeCofactorDH (DigestAlgorithm SHA256)) = [1,3,132,1,14,1]
getObjectID (TypeCofactorDH (DigestAlgorithm SHA384)) = [1,3,132,1,14,2]
getObjectID (TypeCofactorDH (DigestAlgorithm SHA512)) = [1,3,132,1,14,3]
getObjectID ty = error ("Unsupported KeyAgreementType: " ++ show ty)
instance OIDNameable KeyAgreementType where
fromObjectID oid = unOIDNW <$> fromObjectID oid
data KeyAgreementParams = StdDH DigestAlgorithm KeyEncryptionParams
| CofactorDH DigestAlgorithm KeyEncryptionParams
deriving (Show,Eq)
instance AlgorithmId KeyAgreementParams where
type AlgorithmType KeyAgreementParams = KeyAgreementType
algorithmName _ = "key agreement algorithm"
algorithmType (StdDH d _) = TypeStdDH d
algorithmType (CofactorDH d _) = TypeCofactorDH d
parameterASN1S (StdDH _ p) = algorithmASN1S Sequence p
parameterASN1S (CofactorDH _ p) = algorithmASN1S Sequence p
parseParameter (TypeStdDH d) = StdDH d <$> parseAlgorithm Sequence
parseParameter (TypeCofactorDH d) = CofactorDH d <$> parseAlgorithm Sequence
ecdhKeyMaterial :: (ByteArrayAccess bin, ByteArray bout)
=> DigestAlgorithm -> KeyEncryptionParams -> Maybe ByteString -> bin -> bout
ecdhKeyMaterial (DigestAlgorithm hashAlg) kep ukm zz
| r == 0 = B.concat (map chunk [1..d])
| otherwise = B.concat (map chunk [1..d]) `B.append` B.take r (chunk $ succ d)
where
(d, r) = outLen `divMod` Hash.hashDigestSize prx
prx = hashFromProxy hashAlg
outLen = getMaximumKeySize kep
outBits = 8 * outLen
toWord32 = i2ospOf_ 4 . fromIntegral
chunk = B.convert . Hash.hashFinalize . hashCtx
hashCtx' = Hash.hashInitWith prx
hashCtx i = Hash.hashUpdate (Hash.hashUpdate (Hash.hashUpdate hashCtx' zz) (toWord32 i)) otherInfo
otherInfo =
let ki = algorithmASN1S Sequence kep
eui = case ukm of
Nothing -> id
Just bs -> asn1Container (Container Context 0)
(gOctetString bs)
spi = asn1Container (Container Context 2)
(gOctetString $ toWord32 outBits)
in encodeASN1S $ asn1Container Sequence (ki . eui . spi)
ecdhGenerate :: MonadRandom m => X509.PubKey -> m (Either StoreError (ECC.Curve, ECC.PrivateNumber, X509.SerializedPoint))
ecdhGenerate (X509.PubKeyEC pub) =
case ecPubKeyCurveName pub of
Nothing -> return $ Left NamedCurveRequired
Just n -> do
let curve = ECC.getCurveByName n
priv <- ECDH.generatePrivate curve
return $ Right (curve, priv, X509.pubkeyEC_pub pub)
ecdhGenerate _ = return $ Left UnexpectedPublicKeyType
ecdhEncrypt :: (MonadRandom m, ByteArray ba)
=> KeyAgreementParams -> Maybe ByteString -> ECC.Curve -> ECC.PrivateNumber -> X509.SerializedPoint -> ba -> m (Either StoreError ba)
ecdhEncrypt (StdDH dig kep) ukm curve d pt bs =
case unserializePoint curve pt of
Nothing -> return $ Left (InvalidInput "Invalid serialized point")
Just pub -> do
let s = ECDH.getShared curve d pub
k = ecdhKeyMaterial dig kep ukm s :: B.ScrubbedBytes
keyEncrypt k kep bs
ecdhEncrypt (CofactorDH dig kep) ukm curve d pt bs =
case unserializePoint curve pt of
Nothing -> return $ Left (InvalidInput "Invalid serialized point")
Just pub -> do
let h = ECC.ecc_h (ECC.common_curve curve)
s = ECDH.getShared curve (h * d) pub
k = ecdhKeyMaterial dig kep ukm s :: B.ScrubbedBytes
keyEncrypt k kep bs
ecdhDecrypt :: ByteArray ba
=> KeyAgreementParams -> Maybe ByteString -> X509.PrivKeyEC -> X509.SerializedPoint -> ba -> Either StoreError ba
ecdhDecrypt (StdDH dig kep) ukm priv pt bs =
case ecPrivKeyCurve priv of
Nothing -> Left UnsupportedEllipticCurve
Just curve ->
case unserializePoint curve pt of
Nothing -> Left (InvalidInput "Invalid serialized point")
Just pub -> do
let d = X509.privkeyEC_priv priv
s = ECDH.getShared curve d pub
k = ecdhKeyMaterial dig kep ukm s :: B.ScrubbedBytes
keyDecrypt k kep bs
ecdhDecrypt (CofactorDH dig kep) ukm priv pt bs =
case ecPrivKeyCurve priv of
Nothing -> Left UnsupportedEllipticCurve
Just curve ->
case unserializePoint curve pt of
Nothing -> Left (InvalidInput "Invalid serialized point")
Just pub -> do
let h = ECC.ecc_h (ECC.common_curve curve)
d = X509.privkeyEC_priv priv
s = ECDH.getShared curve (h * d) pub
k = ecdhKeyMaterial dig kep ukm s :: B.ScrubbedBytes
keyDecrypt k kep bs
getCipher :: (BlockCipher cipher, ByteArray key)
=> proxy cipher -> key -> Either StoreError cipher
getCipher _ key = fromCryptoFailable (cipherInit key)
getRC2Cipher :: ByteArray key => Int -> key -> Either StoreError RC2
getRC2Cipher len key = fromCryptoFailable (rc2WithEffectiveKeyLength len key)
ivGenerate :: (BlockCipher cipher, MonadRandom m) => cipher -> m (IV cipher)
ivGenerate cipher = do
bs <- getRandomBytes (blockSize cipher)
let Just iv = makeIV (bs :: ByteString)
return iv
nonceGenerate :: MonadRandom m => Int -> m B.Bytes
nonceGenerate = getRandomBytes
cipherFromProxy :: proxy cipher -> cipher
cipherFromProxy _ = undefined
proxyBlockSize :: BlockCipher cipher => proxy cipher -> Int
proxyBlockSize = blockSize . cipherFromProxy
getL :: CCM_L -> Int
getL CCM_L2 = 2
getL CCM_L3 = 3
getL CCM_L4 = 4
getM :: CCM_M -> Int
getM CCM_M4 = 4
getM CCM_M6 = 6
getM CCM_M8 = 8
getM CCM_M10 = 10
getM CCM_M12 = 12
getM CCM_M14 = 14
getM CCM_M16 = 16
fromL :: Int -> Maybe CCM_L
fromL 2 = Just CCM_L2
fromL 3 = Just CCM_L3
fromL 4 = Just CCM_L4
fromL _ = Nothing
parseM :: Monoid e => ParseASN1 e CCM_M
parseM = do
IntVal l <- getNext
case l of
4 -> return CCM_M4
6 -> return CCM_M6
8 -> return CCM_M8
10 -> return CCM_M10
12 -> return CCM_M12
14 -> return CCM_M14
16 -> return CCM_M16
i -> throwParseError ("Parsed invalid CCM parameter M: " ++ show i)
data MaskGenerationType = TypeMGF1
deriving (Show,Eq)
instance Enumerable MaskGenerationType where
values = [ TypeMGF1
]
instance OIDable MaskGenerationType where
getObjectID TypeMGF1 = [1,2,840,113549,1,1,8]
instance OIDNameable MaskGenerationType where
fromObjectID oid = unOIDNW <$> fromObjectID oid
newtype MaskGenerationFunc = MGF1 DigestAlgorithm
deriving (Show,Eq)
instance AlgorithmId MaskGenerationFunc where
type AlgorithmType MaskGenerationFunc = MaskGenerationType
algorithmName _ = "mask generation function"
algorithmType (MGF1 _) = TypeMGF1
parameterASN1S (MGF1 d) = algorithmASN1S Sequence d
parseParameter TypeMGF1 = MGF1 <$> parseAlgorithm Sequence
mgf :: (ByteArrayAccess seed, ByteArray output)
=> MaskGenerationFunc -> seed -> Int -> output
mgf (MGF1 (DigestAlgorithm hashAlg)) = MGF.mgf1 (hashFromProxy hashAlg)
type SignatureValue = ByteString
data PSSParams = PSSParams
{ pssHashAlgorithm :: DigestAlgorithm
, pssMaskGenAlgorithm :: MaskGenerationFunc
, pssSaltLength :: Int
}
deriving (Show,Eq)
withPSSParams :: forall seed output a . (ByteArrayAccess seed, ByteArray output)
=> PSSParams
-> (forall hash . Hash.HashAlgorithm hash => RSAPSS.PSSParams hash seed output -> a)
-> a
withPSSParams p fn =
case pssHashAlgorithm p of
DigestAlgorithm hashAlg ->
fn RSAPSS.PSSParams
{ RSAPSS.pssHash = hashFromProxy hashAlg
, RSAPSS.pssMaskGenAlg = mgf (pssMaskGenAlgorithm p)
, RSAPSS.pssSaltLength = pssSaltLength p
, RSAPSS.pssTrailerField = 0xbc
}
instance ASN1Elem e => ProduceASN1Object e PSSParams where
asn1s PSSParams{..} =
asn1Container Sequence (h . m . s)
where
sha1 = DigestAlgorithm SHA1
tag i = asn1Container (Container Context i)
h | pssHashAlgorithm == sha1 = id
| otherwise = tag 0 (algorithmASN1S Sequence pssHashAlgorithm)
m | pssMaskGenAlgorithm == MGF1 sha1 = id
| otherwise = tag 1 (algorithmASN1S Sequence pssMaskGenAlgorithm)
s | pssSaltLength == 20 && pssHashAlgorithm == sha1 = id
| otherwise = tag 2 (gIntVal $ fromIntegral pssSaltLength)
instance Monoid e => ParseASN1Object e PSSParams where
parse = onNextContainer Sequence $ do
h <- tag 0 (parseAlgorithm Sequence)
m <- tag 1 (parseAlgorithm Sequence)
s <- tag 2 $ do { IntVal i <- getNext; return (fromIntegral i) }
_ <- tag 3 $ do { IntVal 1 <- getNext; return () }
return PSSParams { pssHashAlgorithm = fromMaybe sha1 h
, pssMaskGenAlgorithm = fromMaybe (MGF1 sha1) m
, pssSaltLength = fromMaybe 20 s
}
where
sha1 = DigestAlgorithm SHA1
tag i = onNextContainerMaybe (Container Context i)
data SignatureType = TypeRSAAnyHash
| TypeRSA DigestAlgorithm
| TypeRSAPSS
| TypeDSA DigestAlgorithm
| TypeECDSA DigestAlgorithm
deriving (Show,Eq)
instance Enumerable SignatureType where
values = [ TypeRSAAnyHash
, TypeRSA (DigestAlgorithm MD2)
, TypeRSA (DigestAlgorithm MD5)
, TypeRSA (DigestAlgorithm SHA1)
, TypeRSA (DigestAlgorithm SHA224)
, TypeRSA (DigestAlgorithm SHA256)
, TypeRSA (DigestAlgorithm SHA384)
, TypeRSA (DigestAlgorithm SHA512)
, TypeRSAPSS
, TypeDSA (DigestAlgorithm SHA1)
, TypeDSA (DigestAlgorithm SHA224)
, TypeDSA (DigestAlgorithm SHA256)
, TypeECDSA (DigestAlgorithm SHA1)
, TypeECDSA (DigestAlgorithm SHA224)
, TypeECDSA (DigestAlgorithm SHA256)
, TypeECDSA (DigestAlgorithm SHA384)
, TypeECDSA (DigestAlgorithm SHA512)
]
instance OIDable SignatureType where
getObjectID TypeRSAAnyHash = [1,2,840,113549,1,1,1]
getObjectID (TypeRSA (DigestAlgorithm MD2)) = [1,2,840,113549,1,1,2]
getObjectID (TypeRSA (DigestAlgorithm MD5)) = [1,2,840,113549,1,1,4]
getObjectID (TypeRSA (DigestAlgorithm SHA1)) = [1,2,840,113549,1,1,5]
getObjectID (TypeRSA (DigestAlgorithm SHA224)) = [1,2,840,113549,1,1,14]
getObjectID (TypeRSA (DigestAlgorithm SHA256)) = [1,2,840,113549,1,1,11]
getObjectID (TypeRSA (DigestAlgorithm SHA384)) = [1,2,840,113549,1,1,12]
getObjectID (TypeRSA (DigestAlgorithm SHA512)) = [1,2,840,113549,1,1,13]
getObjectID TypeRSAPSS = [1,2,840,113549,1,1,10]
getObjectID (TypeDSA (DigestAlgorithm SHA1)) = [1,2,840,10040,4,3]
getObjectID (TypeDSA (DigestAlgorithm SHA224)) = [2,16,840,1,101,3,4,3,1]
getObjectID (TypeDSA (DigestAlgorithm SHA256)) = [2,16,840,1,101,3,4,3,2]
getObjectID (TypeECDSA (DigestAlgorithm SHA1)) = [1,2,840,10045,4,1]
getObjectID (TypeECDSA (DigestAlgorithm SHA224)) = [1,2,840,10045,4,3,1]
getObjectID (TypeECDSA (DigestAlgorithm SHA256)) = [1,2,840,10045,4,3,2]
getObjectID (TypeECDSA (DigestAlgorithm SHA384)) = [1,2,840,10045,4,3,3]
getObjectID (TypeECDSA (DigestAlgorithm SHA512)) = [1,2,840,10045,4,3,4]
getObjectID ty = error ("Unsupported SignatureType: " ++ show ty)
instance OIDNameable SignatureType where
fromObjectID oid = unOIDNW <$> fromObjectID oid
data SignatureAlg = RSAAnyHash
| RSA DigestAlgorithm
| RSAPSS PSSParams
| DSA DigestAlgorithm
| ECDSA DigestAlgorithm
deriving (Show,Eq)
instance AlgorithmId SignatureAlg where
type AlgorithmType SignatureAlg = SignatureType
algorithmName _ = "signature algorithm"
algorithmType RSAAnyHash = TypeRSAAnyHash
algorithmType (RSA alg) = TypeRSA alg
algorithmType (RSAPSS _) = TypeRSAPSS
algorithmType (DSA alg) = TypeDSA alg
algorithmType (ECDSA alg) = TypeECDSA alg
parameterASN1S RSAAnyHash = gNull
parameterASN1S (RSA _) = gNull
parameterASN1S (RSAPSS p) = asn1s p
parameterASN1S (DSA _) = id
parameterASN1S (ECDSA _) = id
parseParameter TypeRSAAnyHash = getNextMaybe nullOrNothing >> return RSAAnyHash
parseParameter (TypeRSA alg) = getNextMaybe nullOrNothing >> return (RSA alg)
parseParameter TypeRSAPSS = RSAPSS <$> parse
parseParameter (TypeDSA alg) = return (DSA alg)
parseParameter (TypeECDSA alg) = return (ECDSA alg)
signatureGenerate :: MonadRandom m => SignatureAlg -> X509.PrivKey -> ByteString -> m (Either StoreError SignatureValue)
signatureGenerate RSAAnyHash _ _ =
error "signatureGenerate: should call signatureResolveHash first"
signatureGenerate (RSA alg) (X509.PrivKeyRSA priv) msg =
let err = return . Left $ InvalidParameter ("Invalid hash algorithm for RSA: " ++ show alg)
in withHashAlgorithmASN1 alg err $ \hashAlg ->
mapLeft RSAError <$> RSA.signSafer (Just hashAlg) priv msg
signatureGenerate (RSAPSS p) (X509.PrivKeyRSA priv) msg =
withPSSParams p $ \params ->
mapLeft RSAError <$> RSAPSS.signSafer params priv msg
signatureGenerate (DSA alg) (X509.PrivKeyDSA priv) msg =
case alg of
DigestAlgorithm t ->
Right . dsaFromSignature <$> DSA.sign priv (hashFromProxy t) msg
signatureGenerate (ECDSA alg) (X509.PrivKeyEC priv) msg =
case alg of
DigestAlgorithm t ->
case ecdsaToPrivateKey priv of
Nothing -> return (Left UnsupportedEllipticCurve)
Just p ->
let h = hashFromProxy t
in Right . ecdsaFromSignature <$> ECDSA.sign p h msg
signatureGenerate _ _ _ = return (Left UnexpectedPrivateKeyType)
signatureVerify :: SignatureAlg -> X509.PubKey -> ByteString -> SignatureValue -> Bool
signatureVerify RSAAnyHash _ _ _ =
error "signatureVerify: should call signatureResolveHash first"
signatureVerify (RSA alg) (X509.PubKeyRSA pub) msg sig =
withHashAlgorithmASN1 alg False $ \hashAlg ->
RSA.verify (Just hashAlg) pub msg sig
signatureVerify (RSAPSS p) (X509.PubKeyRSA pub) msg sig =
withPSSParams p $ \params -> RSAPSS.verify params pub msg sig
signatureVerify (DSA alg) (X509.PubKeyDSA pub) msg sig = fromMaybe False $ do
s <- dsaToSignature sig
case alg of
DigestAlgorithm t -> return $ DSA.verify (hashFromProxy t) pub s msg
signatureVerify (ECDSA alg) (X509.PubKeyEC pub) msg sig = fromMaybe False $ do
p <- ecdsaToPublicKey pub
s <- ecdsaToSignature sig
case alg of
DigestAlgorithm t -> return $ ECDSA.verify (hashFromProxy t) p s msg
signatureVerify _ _ _ _ = False
withHashAlgorithmASN1 :: DigestAlgorithm
-> a
-> (forall hashAlg . RSA.HashAlgorithmASN1 hashAlg => hashAlg -> a)
-> a
withHashAlgorithmASN1 (DigestAlgorithm MD2) _ f = f Hash.MD2
withHashAlgorithmASN1 (DigestAlgorithm MD5) _ f = f Hash.MD5
withHashAlgorithmASN1 (DigestAlgorithm SHA1) _ f = f Hash.SHA1
withHashAlgorithmASN1 (DigestAlgorithm SHA224) _ f = f Hash.SHA224
withHashAlgorithmASN1 (DigestAlgorithm SHA256) _ f = f Hash.SHA256
withHashAlgorithmASN1 (DigestAlgorithm SHA384) _ f = f Hash.SHA384
withHashAlgorithmASN1 (DigestAlgorithm SHA512) _ f = f Hash.SHA512
withHashAlgorithmASN1 _ e _ = e
signatureResolveHash :: DigestAlgorithm -> SignatureAlg -> (DigestAlgorithm, SignatureAlg)
signatureResolveHash d RSAAnyHash = (d, RSA d)
signatureResolveHash _ alg@(RSA d) = (d, alg)
signatureResolveHash _ alg@(RSAPSS p) = (pssHashAlgorithm p, alg)
signatureResolveHash _ alg@(DSA d) = (d, alg)
signatureResolveHash _ alg@(ECDSA d) = (d, alg)
signatureCheckHash :: DigestAlgorithm -> SignatureAlg -> Maybe SignatureAlg
signatureCheckHash expected RSAAnyHash = Just $ RSA expected
signatureCheckHash expected alg@(RSA found)
| expected == found = Just alg
| otherwise = Nothing
signatureCheckHash expected alg@(RSAPSS p)
| expected == pssHashAlgorithm p = Just alg
| otherwise = Nothing
signatureCheckHash expected alg@(DSA found)
| expected == found = Just alg
| otherwise = Nothing
signatureCheckHash expected alg@(ECDSA found)
| expected == found = Just alg
| otherwise = Nothing
dsaToSignature :: ByteString -> Maybe DSA.Signature
dsaToSignature b = tryDecodeAndParse b $ onNextContainer Sequence $ do
IntVal r <- getNext
IntVal s <- getNext
return DSA.Signature { DSA.sign_r = r, DSA.sign_s = s }
dsaFromSignature :: DSA.Signature -> ByteString
dsaFromSignature sig = encodeASN1S $ asn1Container Sequence
(gIntVal (DSA.sign_r sig) . gIntVal (DSA.sign_s sig))
ecdsaToSignature :: ByteString -> Maybe ECDSA.Signature
ecdsaToSignature b = tryDecodeAndParse b $ onNextContainer Sequence $ do
IntVal r <- getNext
IntVal s <- getNext
return ECDSA.Signature { ECDSA.sign_r = r, ECDSA.sign_s = s }
ecdsaFromSignature :: ECDSA.Signature -> ByteString
ecdsaFromSignature sig = encodeASN1S $ asn1Container Sequence
(gIntVal (ECDSA.sign_r sig) . gIntVal (ECDSA.sign_s sig))
ecdsaToPublicKey :: X509.PubKeyEC -> Maybe ECDSA.PublicKey
ecdsaToPublicKey key = do
curve <- ecPubKeyCurve key
pt <- unserializePoint curve (X509.pubkeyEC_pub key)
return ECDSA.PublicKey { ECDSA.public_curve = curve, ECDSA.public_q = pt }
ecdsaToPrivateKey :: X509.PrivKeyEC -> Maybe ECDSA.PrivateKey
ecdsaToPrivateKey key = do
curve <- ecPrivKeyCurve key
let d = X509.privkeyEC_priv key
return ECDSA.PrivateKey { ECDSA.private_curve = curve, ECDSA.private_d = d }
tryDecodeAndParse :: ByteString -> ParseASN1 () a -> Maybe a
tryDecodeAndParse b parser =
either (const Nothing) Just $
case decodeASN1' BER b of
Left _ -> Left undefined
Right asn1 -> runParseASN1 parser asn1