{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
module Crypto.Store.CMS.Enveloped
( EncryptedKey
, UserKeyingMaterial
, RecipientInfo(..)
, EnvelopedData(..)
, ProducerOfRI
, ConsumerOfRI
, KTRecipientInfo(..)
, RecipientIdentifier(..)
, IssuerAndSerialNumber(..)
, forKeyTransRecipient
, withRecipientKeyTrans
, KARecipientInfo(..)
, OriginatorIdentifierOrKey(..)
, OriginatorPublicKey
, RecipientEncryptedKey(..)
, KeyAgreeRecipientIdentifier(..)
, forKeyAgreeRecipient
, withRecipientKeyAgree
, KeyEncryptionKey
, KEKRecipientInfo(..)
, KeyIdentifier(..)
, OtherKeyAttribute(..)
, forKeyRecipient
, withRecipientKey
, Password
, PasswordRecipientInfo(..)
, forPasswordRecipient
, withRecipientPassword
) where
import Control.Applicative
import Control.Monad
import Data.ASN1.BitArray
import Data.ASN1.Types
import Data.ByteString (ByteString)
import Data.List (find)
import Data.Maybe (fromMaybe)
import Data.X509
import Time.Types
import Crypto.Random (MonadRandom)
import Crypto.Store.ASN1.Generate
import Crypto.Store.ASN1.Parse
import Crypto.Store.CMS.Algorithms
import Crypto.Store.CMS.Attribute
import Crypto.Store.CMS.Encrypted
import Crypto.Store.CMS.OriginatorInfo
import Crypto.Store.CMS.Type
import Crypto.Store.CMS.Util
import Crypto.Store.Error
type EncryptedKey = ByteString
type UserKeyingMaterial = ByteString
type KeyEncryptionKey = ByteString
type Password = ByteString
data RecipientIdentifier
= RecipientIASN IssuerAndSerialNumber
| RecipientSKI ByteString
deriving (Show,Eq)
instance ASN1Elem e => ProduceASN1Object e RecipientIdentifier where
asn1s (RecipientIASN iasn) = asn1s iasn
asn1s (RecipientSKI ski) = asn1Container (Container Context 0)
(gOctetString ski)
instance Monoid e => ParseASN1Object e RecipientIdentifier where
parse = parseIASN <|> parseSKI
where parseIASN = RecipientIASN <$> parse
parseSKI = RecipientSKI <$>
onNextContainer (Container Context 0) parseBS
parseBS = do { OctetString bs <- getNext; return bs }
getKTVersion :: RecipientIdentifier -> Integer
getKTVersion (RecipientIASN _) = 0
getKTVersion (RecipientSKI _) = 2
data IssuerAndSerialNumber = IssuerAndSerialNumber
{ iasnIssuer :: DistinguishedName
, iasnSerial :: Integer
}
deriving (Show,Eq)
instance ASN1Elem e => ProduceASN1Object e IssuerAndSerialNumber where
asn1s IssuerAndSerialNumber{..} =
asn1Container Sequence (asn1s iasnIssuer . gIntVal iasnSerial)
instance Monoid e => ParseASN1Object e IssuerAndSerialNumber where
parse = onNextContainer Sequence $ do
i <- parse
IntVal s <- getNext
return IssuerAndSerialNumber { iasnIssuer = i
, iasnSerial = s
}
idEcPublicKey :: OID
idEcPublicKey = [1,2,840,10045,2,1]
data OriginatorPublicKey = OriginatorPublicKeyEC [ASN1] BitArray
deriving (Show,Eq)
originatorPublicKeyASN1S :: ASN1Elem e
=> ASN1ConstructionType
-> OriginatorPublicKey
-> ASN1Stream e
originatorPublicKeyASN1S ty (OriginatorPublicKeyEC asn1 ba) =
asn1Container ty (alg . gBitString ba)
where
alg = asn1Container Sequence (gOID idEcPublicKey . gMany asn1)
parseOriginatorPublicKey :: Monoid e
=> ASN1ConstructionType
-> ParseASN1 e OriginatorPublicKey
parseOriginatorPublicKey ty =
onNextContainer ty $ do
asn1 <- onNextContainer Sequence $ do
OID oid <- getNext
guard (oid == idEcPublicKey)
getMany getNext
BitString ba <- getNext
return (OriginatorPublicKeyEC asn1 ba)
data OriginatorIdentifierOrKey
= OriginatorIASN IssuerAndSerialNumber
| OriginatorSKI ByteString
| OriginatorPublic OriginatorPublicKey
deriving (Show,Eq)
instance ASN1Elem e => ProduceASN1Object e OriginatorIdentifierOrKey where
asn1s (OriginatorIASN iasn) = asn1s iasn
asn1s (OriginatorSKI ski) = asn1Container (Container Context 0)
(gOctetString ski)
asn1s (OriginatorPublic pub) =
originatorPublicKeyASN1S (Container Context 1) pub
instance Monoid e => ParseASN1Object e OriginatorIdentifierOrKey where
parse = parseIASN <|> parseSKI <|> parsePublic
where parseIASN = OriginatorIASN <$> parse
parseSKI = OriginatorSKI <$>
onNextContainer (Container Context 0) parseBS
parseBS = do { OctetString bs <- getNext; return bs }
parsePublic = OriginatorPublic <$>
parseOriginatorPublicKey (Container Context 1)
data KeyAgreeRecipientIdentifier
= KeyAgreeRecipientIASN IssuerAndSerialNumber
| KeyAgreeRecipientKI KeyIdentifier
deriving (Show,Eq)
instance ASN1Elem e => ProduceASN1Object e KeyAgreeRecipientIdentifier where
asn1s (KeyAgreeRecipientIASN iasn) = asn1s iasn
asn1s (KeyAgreeRecipientKI ki) = asn1Container (Container Context 0)
(asn1s ki)
instance Monoid e => ParseASN1Object e KeyAgreeRecipientIdentifier where
parse = parseIASN <|> parseKI
where parseIASN = KeyAgreeRecipientIASN <$> parse
parseKI = KeyAgreeRecipientKI <$>
onNextContainer (Container Context 0) parse
data RecipientEncryptedKey = RecipientEncryptedKey
{ rekRid :: KeyAgreeRecipientIdentifier
, rekEncryptedKey :: EncryptedKey
}
deriving (Show,Eq)
instance ASN1Elem e => ProduceASN1Object e RecipientEncryptedKey where
asn1s RecipientEncryptedKey{..} = asn1Container Sequence (rid . ek)
where rid = asn1s rekRid
ek = gOctetString rekEncryptedKey
instance Monoid e => ParseASN1Object e RecipientEncryptedKey where
parse = onNextContainer Sequence $ do
rid <- parse
OctetString ek <- getNext
return RecipientEncryptedKey { rekRid = rid, rekEncryptedKey = ek }
findRecipientEncryptedKey :: SignedCertificate
-> [RecipientEncryptedKey]
-> Maybe EncryptedKey
findRecipientEncryptedKey cert list = rekEncryptedKey <$> find fn list
where
c = signedObject (getSigned cert)
matchIASN iasn =
(iasnIssuer iasn, iasnSerial iasn) == (certIssuerDN c, certSerial c)
matchSKI ski =
case extensionGet (certExtensions c) of
Just (ExtSubjectKeyId idBs) -> idBs == ski
Nothing -> False
fn rek = case rekRid rek of
KeyAgreeRecipientIASN iasn -> matchIASN iasn
KeyAgreeRecipientKI ki -> matchSKI (keyIdentifier ki)
data OtherKeyAttribute = OtherKeyAttribute
{ keyAttrId :: OID
, keyAttr :: [ASN1]
}
deriving (Show,Eq)
instance ASN1Elem e => ProduceASN1Object e OtherKeyAttribute where
asn1s OtherKeyAttribute{..} = asn1Container Sequence (attrId . attr)
where attrId = gOID keyAttrId
attr = gMany keyAttr
instance Monoid e => ParseASN1Object e OtherKeyAttribute where
parse = onNextContainer Sequence $ do
OID attrId <- getNext
attr <- getMany getNext
return OtherKeyAttribute { keyAttrId = attrId, keyAttr = attr }
data KeyIdentifier = KeyIdentifier
{ keyIdentifier :: ByteString
, keyDate :: Maybe DateTime
, keyOther :: Maybe OtherKeyAttribute
}
deriving (Show,Eq)
instance ASN1Elem e => ProduceASN1Object e KeyIdentifier where
asn1s KeyIdentifier{..} = asn1Container Sequence (keyId . date . other)
where
keyId = gOctetString keyIdentifier
date = optASN1S keyDate $ \v -> gASN1Time TimeGeneralized v Nothing
other = optASN1S keyOther asn1s
instance Monoid e => ParseASN1Object e KeyIdentifier where
parse = onNextContainer Sequence $ do
OctetString keyId <- getNext
date <- getNextMaybe dateTimeOrNothing
b <- hasNext
other <- if b then Just <$> parse else return Nothing
return KeyIdentifier { keyIdentifier = keyId
, keyDate = date
, keyOther = other
}
data KTRecipientInfo = KTRecipientInfo
{ ktRid :: RecipientIdentifier
, ktKeyTransportParams :: KeyTransportParams
, ktEncryptedKey :: EncryptedKey
}
deriving (Show,Eq)
data KARecipientInfo = KARecipientInfo
{ kaOriginator :: OriginatorIdentifierOrKey
, kaUkm :: Maybe UserKeyingMaterial
, kaKeyAgreementParams :: KeyAgreementParams
, kaRecipientEncryptedKeys :: [RecipientEncryptedKey]
}
deriving (Show,Eq)
data KEKRecipientInfo = KEKRecipientInfo
{ kekId :: KeyIdentifier
, kekKeyEncryptionParams :: KeyEncryptionParams
, kekEncryptedKey :: EncryptedKey
}
deriving (Show,Eq)
data PasswordRecipientInfo = PasswordRecipientInfo
{ priKeyDerivationFunc :: KeyDerivationFunc
, priKeyEncryptionParams :: KeyEncryptionParams
, priEncryptedKey :: EncryptedKey
}
deriving (Show,Eq)
data RecipientInfo = KTRI KTRecipientInfo
| KARI KARecipientInfo
| KEKRI KEKRecipientInfo
| PasswordRI PasswordRecipientInfo
deriving (Show,Eq)
instance ASN1Elem e => ProduceASN1Object e RecipientInfo where
asn1s (KTRI KTRecipientInfo{..}) =
asn1Container Sequence (ver . rid . ktp . ek)
where
ver = gIntVal (getKTVersion ktRid)
rid = asn1s ktRid
ktp = algorithmASN1S Sequence ktKeyTransportParams
ek = gOctetString ktEncryptedKey
asn1s (KARI KARecipientInfo{..}) =
asn1Container (Container Context 1) (ver . ori . ukm . kap . reks)
where
ver = gIntVal 3
ori = asn1Container (Container Context 0) (asn1s kaOriginator)
kap = algorithmASN1S Sequence kaKeyAgreementParams
reks = asn1Container Sequence (asn1s kaRecipientEncryptedKeys)
ukm = case kaUkm of
Nothing -> id
Just bs -> asn1Container (Container Context 1) (gOctetString bs)
asn1s (KEKRI KEKRecipientInfo{..}) =
asn1Container (Container Context 2) (ver . kid . kep . ek)
where
ver = gIntVal 4
kid = asn1s kekId
kep = algorithmASN1S Sequence kekKeyEncryptionParams
ek = gOctetString kekEncryptedKey
asn1s (PasswordRI PasswordRecipientInfo{..}) =
asn1Container (Container Context 3) (ver . kdf . kep . ek)
where
ver = gIntVal 0
kdf = algorithmASN1S (Container Context 0) priKeyDerivationFunc
kep = algorithmASN1S Sequence priKeyEncryptionParams
ek = gOctetString priEncryptedKey
instance Monoid e => ParseASN1Object e RecipientInfo where
parse = do
c <- onNextContainerMaybe Sequence parseKT
`orElse` onNextContainerMaybe (Container Context 1) parseKA
`orElse` onNextContainerMaybe (Container Context 2) parseKEK
`orElse` onNextContainerMaybe (Container Context 3) parsePassword
case c of
Just val -> return val
Nothing -> throwParseError "RecipientInfo: unable to parse"
where
parseKT = KTRI <$> do
IntVal v <- getNext
when (v `notElem` [0, 2]) $
throwParseError ("RecipientInfo: parsed invalid KT version: " ++ show v)
rid <- parse
ktp <- parseAlgorithm Sequence
(OctetString ek) <- getNext
return KTRecipientInfo { ktRid = rid
, ktKeyTransportParams = ktp
, ktEncryptedKey = ek
}
parseKA = KARI <$> do
IntVal 3 <- getNext
ori <- onNextContainer (Container Context 0) parse
ukm <- onNextContainerMaybe (Container Context 1) $
do { OctetString bs <- getNext; return bs }
kap <- parseAlgorithm Sequence
reks <- onNextContainer Sequence parse
return KARecipientInfo { kaOriginator = ori
, kaUkm = ukm
, kaKeyAgreementParams = kap
, kaRecipientEncryptedKeys = reks
}
parseKEK = KEKRI <$> do
IntVal 4 <- getNext
kid <- parse
kep <- parseAlgorithm Sequence
(OctetString ek) <- getNext
return KEKRecipientInfo { kekId = kid
, kekKeyEncryptionParams = kep
, kekEncryptedKey = ek
}
parsePassword = PasswordRI <$> do
IntVal 0 <- getNext
kdf <- parseAlgorithm (Container Context 0)
kep <- parseAlgorithm Sequence
(OctetString ek) <- getNext
return PasswordRecipientInfo { priKeyDerivationFunc = kdf
, priKeyEncryptionParams = kep
, priEncryptedKey = ek
}
isVersion0 :: RecipientInfo -> Bool
isVersion0 (KTRI x) = getKTVersion (ktRid x) == 0
isVersion0 (KARI _) = False
isVersion0 (KEKRI _) = False
isVersion0 (PasswordRI _) = True
isPwriOri :: RecipientInfo -> Bool
isPwriOri (KTRI _) = False
isPwriOri (KARI _) = False
isPwriOri (KEKRI _) = False
isPwriOri (PasswordRI _) = True
data EnvelopedData content = EnvelopedData
{ evOriginatorInfo :: OriginatorInfo
, evRecipientInfos :: [RecipientInfo]
, evContentType :: ContentType
, evContentEncryptionParams :: ContentEncryptionParams
, evEncryptedContent :: content
, evUnprotectedAttrs :: [Attribute]
}
deriving (Show,Eq)
instance ProduceASN1Object ASN1P (EnvelopedData (Encap EncryptedContent)) where
asn1s EnvelopedData{..} =
asn1Container Sequence (ver . oi . ris . eci . ua)
where
ver = gIntVal v
ris = asn1Container Set (asn1s evRecipientInfos)
eci = encryptedContentInfoASN1S
(evContentType, evContentEncryptionParams, evEncryptedContent)
ua = attributesASN1S (Container Context 1) evUnprotectedAttrs
oi | evOriginatorInfo == mempty = id
| otherwise = originatorInfoASN1S (Container Context 0) evOriginatorInfo
v | hasChoiceOther evOriginatorInfo = 4
| any isPwriOri evRecipientInfos = 3
| evOriginatorInfo /= mempty = 2
| not (null evUnprotectedAttrs) = 2
| all isVersion0 evRecipientInfos = 0
| otherwise = 2
instance ParseASN1Object [ASN1Event] (EnvelopedData (Encap EncryptedContent)) where
parse =
onNextContainer Sequence $ do
IntVal v <- getNext
when (v > 4) $
throwParseError ("EnvelopedData: parsed invalid version: " ++ show v)
oi <- parseOriginatorInfo (Container Context 0) <|> return mempty
ris <- onNextContainer Set parse
(ct, params, ec) <- parseEncryptedContentInfo
attrs <- parseAttributes (Container Context 1)
return EnvelopedData { evOriginatorInfo = oi
, evRecipientInfos = ris
, evContentType = ct
, evContentEncryptionParams = params
, evEncryptedContent = ec
, evUnprotectedAttrs = attrs
}
type ProducerOfRI m = ContentEncryptionKey -> m (Either StoreError RecipientInfo)
type ConsumerOfRI m = RecipientInfo -> m (Either StoreError ContentEncryptionKey)
forKeyTransRecipient :: MonadRandom m
=> SignedCertificate -> KeyTransportParams -> ProducerOfRI m
forKeyTransRecipient cert params inkey = do
ek <- transportEncrypt params (certPubKey obj) inkey
return (KTRI . build <$> ek)
where
obj = signedObject (getSigned cert)
isn = IssuerAndSerialNumber (certIssuerDN obj) (certSerial obj)
build ek = KTRecipientInfo
{ ktRid = RecipientIASN isn
, ktKeyTransportParams = params
, ktEncryptedKey = ek
}
withRecipientKeyTrans :: MonadRandom m => PrivKey -> ConsumerOfRI m
withRecipientKeyTrans privKey (KTRI KTRecipientInfo{..}) =
transportDecrypt ktKeyTransportParams privKey ktEncryptedKey
withRecipientKeyTrans _ _ = pure (Left RecipientTypeMismatch)
forKeyAgreeRecipient :: MonadRandom m
=> SignedCertificate -> KeyAgreementParams -> ProducerOfRI m
forKeyAgreeRecipient cert params inkey = do
ephemeral <- ecdhGenerate (certPubKey obj)
case ephemeral of
Right pair -> do
let pt = ecdhPublic pair
aPub = OriginatorPublicKeyEC [] (toBitArray pt 0)
ek <- ecdhEncrypt params Nothing pair inkey
return (KARI . build aPub <$> ek)
Left err -> return $ Left err
where
obj = signedObject (getSigned cert)
isn = IssuerAndSerialNumber (certIssuerDN obj) (certSerial obj)
makeREK ek = RecipientEncryptedKey
{ rekRid = KeyAgreeRecipientIASN isn
, rekEncryptedKey = ek
}
build aPub ek =
KARecipientInfo
{ kaOriginator = OriginatorPublic aPub
, kaUkm = Nothing
, kaKeyAgreementParams = params
, kaRecipientEncryptedKeys = [ makeREK ek ]
}
withRecipientKeyAgree :: MonadRandom m => PrivKey -> SignedCertificate -> ConsumerOfRI m
withRecipientKeyAgree priv cert (KARI KARecipientInfo{..}) =
case kaOriginator of
OriginatorPublic (OriginatorPublicKeyEC _ ba) ->
case findRecipientEncryptedKey cert kaRecipientEncryptedKeys of
Nothing -> pure (Left RecipientKeyNotFound)
Just ek ->
let pub = bitArrayGetData ba
in pure (ecdhDecrypt kaKeyAgreementParams kaUkm priv pub ek)
_ -> pure (Left UnsupportedOriginatorFormat)
withRecipientKeyAgree _ _ _ = pure (Left RecipientTypeMismatch)
forKeyRecipient :: MonadRandom m
=> KeyEncryptionKey
-> KeyIdentifier
-> KeyEncryptionParams
-> ProducerOfRI m
forKeyRecipient key kid params inkey = do
ek <- keyEncrypt key params inkey
return (KEKRI . build <$> ek)
where
build ek = KEKRecipientInfo
{ kekId = kid
, kekKeyEncryptionParams = params
, kekEncryptedKey = ek
}
withRecipientKey :: Applicative f => KeyEncryptionKey -> ConsumerOfRI f
withRecipientKey key (KEKRI KEKRecipientInfo{..}) =
pure (keyDecrypt key kekKeyEncryptionParams kekEncryptedKey)
withRecipientKey _ _ = pure (Left RecipientTypeMismatch)
forPasswordRecipient :: MonadRandom m
=> Password
-> KeyDerivationFunc
-> KeyEncryptionParams
-> ProducerOfRI m
forPasswordRecipient pwd kdf params inkey = do
ek <- keyEncrypt derived params inkey
return (PasswordRI . build <$> ek)
where
derived = kdfDerive kdf len pwd :: EncryptedKey
len = fromMaybe (getMaximumKeySize params) (kdfKeyLength kdf)
build ek = PasswordRecipientInfo
{ priKeyDerivationFunc = kdf
, priKeyEncryptionParams = params
, priEncryptedKey = ek
}
withRecipientPassword :: Applicative f => Password -> ConsumerOfRI f
withRecipientPassword pwd (PasswordRI PasswordRecipientInfo{..}) =
pure (keyDecrypt derived priKeyEncryptionParams priEncryptedKey)
where
derived = kdfDerive priKeyDerivationFunc len pwd :: EncryptedKey
len = fromMaybe (getMaximumKeySize priKeyEncryptionParams)
(kdfKeyLength priKeyDerivationFunc)
withRecipientPassword _ _ = pure (Left RecipientTypeMismatch)