{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Crypto.Store.PKCS12
( IntegrityParams
, readP12File
, readP12FileFromMemory
, writeP12File
, writeP12FileToMemory
, writeUnprotectedP12File
, writeUnprotectedP12FileToMemory
, PKCS12
, unPKCS12
, unPKCS12'
, unencrypted
, encrypted
, SafeContents(..)
, SafeBag
, Bag(..)
, SafeInfo(..)
, CertInfo(..)
, CRLInfo(..)
, Attribute(..)
, getSafeKeys
, getAllSafeKeys
, getSafeX509Certs
, getAllSafeX509Certs
, getSafeX509CRLs
, getAllSafeX509CRLs
, findAttribute
, setAttribute
, filterAttributes
, getFriendlyName
, setFriendlyName
, getLocalKeyId
, setLocalKeyId
, fromCredential
, toCredential
, Password
, OptProtected(..)
, recover
, recoverA
) where
import Control.Monad
import Data.ASN1.Types
import Data.ASN1.BinaryEncoding
import Data.ASN1.Encoding
import qualified Data.ByteArray as B
import qualified Data.ByteString as BS
import Data.Maybe (fromMaybe)
import Data.Semigroup
import qualified Data.X509 as X509
import Crypto.Cipher.Types
import Crypto.Store.ASN1.Generate
import Crypto.Store.ASN1.Parse
import Crypto.Store.CMS
import Crypto.Store.CMS.Algorithms
import Crypto.Store.CMS.Attribute
import Crypto.Store.CMS.Encrypted
import Crypto.Store.CMS.Util
import Crypto.Store.Error
import Crypto.Store.PKCS5
import Crypto.Store.PKCS5.PBES1
import Crypto.Store.PKCS8
readP12File :: FilePath -> IO (Either StoreError (OptProtected PKCS12))
readP12File path = readP12FileFromMemory <$> BS.readFile path
readP12FileFromMemory :: BS.ByteString -> Either StoreError (OptProtected PKCS12)
readP12FileFromMemory ber = decode ber >>= integrity
where
integrity PFX{..} =
case macData of
Nothing -> Unprotected <$> decode authSafeData
Just md -> return $ Protected (verify md authSafeData)
verify MacData{..} content pwdUTF8 =
case digAlg of
DigestAlgorithm d ->
let fn key macAlg bs
| macValue == mac macAlg key bs = decode bs
| otherwise = Left BadContentMAC
in pkcs12mac Left fn d macParams content pwdUTF8
type IntegrityParams = (DigestAlgorithm, PBEParameter)
writeP12File :: FilePath
-> IntegrityParams -> Password
-> PKCS12
-> IO (Either StoreError ())
writeP12File path intp pw aSafe =
case writeP12FileToMemory intp pw aSafe of
Left e -> return (Left e)
Right bs -> Right <$> BS.writeFile path bs
writeP12FileToMemory :: IntegrityParams -> Password
-> PKCS12
-> Either StoreError BS.ByteString
writeP12FileToMemory (alg@(DigestAlgorithm hashAlg), pbeParam) pwdUTF8 aSafe =
encode <$> protect
where
content = encodeASN1Object aSafe
encode md = encodeASN1Object PFX { authSafeData = content, macData = Just md }
protect = pkcs12mac Left fn hashAlg pbeParam content pwdUTF8
fn key macAlg bs = Right MacData { digAlg = alg
, macValue = mac macAlg key bs
, macParams = pbeParam
}
writeUnprotectedP12File :: FilePath -> PKCS12 -> IO ()
writeUnprotectedP12File path = BS.writeFile path . writeUnprotectedP12FileToMemory
writeUnprotectedP12FileToMemory :: PKCS12 -> BS.ByteString
writeUnprotectedP12FileToMemory aSafe = encodeASN1Object pfx
where
content = encodeASN1Object aSafe
pfx = PFX { authSafeData = content, macData = Nothing }
data PFX = PFX
{ authSafeData :: BS.ByteString
, macData :: Maybe MacData
}
deriving (Show,Eq)
instance ProduceASN1Object ASN1P PFX where
asn1s PFX{..} =
asn1Container Sequence (v . a . m)
where
v = gIntVal 3
a = asn1s (DataCI authSafeData)
m = optASN1S macData asn1s
instance ParseASN1Object [ASN1Event] PFX where
parse = onNextContainer Sequence $ do
IntVal v <- getNext
when (v /= 3) $
throwParseError ("PFX: parsed invalid version: " ++ show v)
ci <- parse
d <- case ci of
DataCI bs -> return bs
SignedDataCI _ -> throwParseError "PFX: public-key integrity mode is not supported"
_ -> throwParseError $ "PFX: invalid content type: " ++ show (getContentType ci)
b <- hasNext
m <- if b then Just <$> parse else pure Nothing
return PFX { authSafeData = d, macData = m }
data MacData = MacData
{ digAlg :: DigestAlgorithm
, macValue :: MessageAuthenticationCode
, macParams :: PBEParameter
}
deriving (Show,Eq)
instance ASN1Elem e => ProduceASN1Object e MacData where
asn1s MacData{..} =
asn1Container Sequence (m . s . i)
where
m = asn1Container Sequence (a . v)
a = algorithmASN1S Sequence digAlg
v = gOctetString (B.convert macValue)
s = gOctetString (pbeSalt macParams)
i = gIntVal (fromIntegral $ pbeIterationCount macParams)
instance Monoid e => ParseASN1Object e MacData where
parse = onNextContainer Sequence $ do
(a, v) <- onNextContainer Sequence $ do
a <- parseAlgorithm Sequence
OctetString v <- getNext
return (a, v)
OctetString s <- getNext
b <- hasNext
IntVal i <- if b then getNext else pure (IntVal 1)
return MacData { digAlg = a
, macValue = AuthTag (B.convert v)
, macParams = PBEParameter s (fromIntegral i)
}
newtype PKCS12 = PKCS12 [ASElement]
deriving (Show,Eq)
instance Semigroup PKCS12 where
PKCS12 a <> PKCS12 b = PKCS12 (a ++ b)
instance ProduceASN1Object ASN1P PKCS12 where
asn1s (PKCS12 elems) = asn1Container Sequence (asn1s elems)
instance ParseASN1Object [ASN1Event] PKCS12 where
parse = PKCS12 <$> onNextContainer Sequence parse
unPKCS12 :: PKCS12 -> OptProtected [SafeContents]
unPKCS12 = applySamePassword . unPKCS12'
unPKCS12' :: PKCS12 -> [OptProtected SafeContents]
unPKCS12' (PKCS12 elems) = map f elems
where f (Unencrypted sc) = Unprotected sc
f (Encrypted e) = Protected (decrypt e >=> decode)
unencrypted :: SafeContents -> PKCS12
unencrypted = PKCS12 . (:[]) . Unencrypted
encrypted :: EncryptionScheme -> Password -> SafeContents -> Either StoreError PKCS12
encrypted alg pwd sc = PKCS12 . (:[]) . Encrypted <$> encrypt alg pwd bs
where bs = encodeASN1Object sc
data ASElement = Unencrypted SafeContents
| Encrypted PKCS5
deriving (Show,Eq)
instance ASN1Elem e => ProduceASN1Object e ASElement where
asn1s (Unencrypted sc) = asn1Container Sequence (oid . cont)
where
oid = gOID (getObjectID DataType)
cont = asn1Container (Container Context 0) (gOctetString bs)
bs = encodeASN1Object sc
asn1s (Encrypted PKCS5{..}) = asn1Container Sequence (oid . cont)
where
oid = gOID (getObjectID EncryptedDataType)
cont = asn1Container (Container Context 0) inner
inner = asn1Container Sequence (gIntVal 0 . eci)
eci = encryptedContentInfoASN1S
(DataType, encryptionAlgorithm, encryptedData)
instance Monoid e => ParseASN1Object e ASElement where
parse = onNextContainer Sequence $ do
OID oid <- getNext
withObjectID "content type" oid $ \ct ->
onNextContainer (Container Context 0) (parseInner ct)
where
parseInner DataType = Unencrypted <$> parseUnencrypted
parseInner EncryptedDataType = Encrypted <$> parseEncrypted
parseInner EnvelopedDataType = throwParseError "PKCS12: public-key privacy mode is not supported"
parseInner ct = throwParseError $ "PKCS12: invalid content type: " ++ show ct
parseUnencrypted = parseOctetStringObject "PKCS12"
parseEncrypted = onNextContainer Sequence $ do
IntVal 0 <- getNext
(DataType, eScheme, ed) <- parseEncryptedContentInfo
return PKCS5 { encryptionAlgorithm = eScheme, encryptedData = ed }
data Bag info = Bag
{ bagInfo :: info
, bagAttributes :: [Attribute]
}
deriving (Show,Eq)
class BagInfo info where
type BagType info
bagName :: info -> String
bagType :: info -> BagType info
valueASN1S :: ASN1Elem e => info -> ASN1Stream e
parseValue :: Monoid e => BagType info -> ParseASN1 e info
instance (ASN1Elem e, BagInfo info, OIDable (BagType info)) => ProduceASN1Object e (Bag info) where
asn1s Bag{..} = asn1Container Sequence (oid . val . att)
where
typ = bagType bagInfo
oid = gOID (getObjectID typ)
val = asn1Container (Container Context 0) (valueASN1S bagInfo)
att | null bagAttributes = id
| otherwise = asn1Container Set (asn1s bagAttributes)
instance (Monoid e, BagInfo info, OIDNameable (BagType info)) => ParseASN1Object e (Bag info) where
parse = onNextContainer Sequence $ do
OID oid <- getNext
val <- withObjectID (getName undefined) oid $
onNextContainer (Container Context 0) . parseValue
att <- fromMaybe [] <$> onNextContainerMaybe Set parse
return Bag { bagInfo = val, bagAttributes = att }
where
getName :: info -> String
getName = bagName
data CertType = TypeCertX509 deriving (Show,Eq)
instance Enumerable CertType where
values = [ TypeCertX509 ]
instance OIDable CertType where
getObjectID TypeCertX509 = [1,2,840,113549,1,9,22,1]
instance OIDNameable CertType where
fromObjectID oid = unOIDNW <$> fromObjectID oid
newtype CertInfo = CertX509 X509.SignedCertificate deriving (Show,Eq)
instance BagInfo CertInfo where
type BagType CertInfo = CertType
bagName _ = "CertBag"
bagType (CertX509 _) = TypeCertX509
valueASN1S (CertX509 c) = gOctetString (encodeASN1Object c)
parseValue TypeCertX509 = CertX509 <$> parseOctetStringObject "CertBag"
data CRLType = TypeCRLX509 deriving (Show,Eq)
instance Enumerable CRLType where
values = [ TypeCRLX509 ]
instance OIDable CRLType where
getObjectID TypeCRLX509 = [1,2,840,113549,1,9,23,1]
instance OIDNameable CRLType where
fromObjectID oid = unOIDNW <$> fromObjectID oid
newtype CRLInfo = CRLX509 X509.SignedCRL deriving (Show,Eq)
instance BagInfo CRLInfo where
type BagType CRLInfo = CRLType
bagName _ = "CRLBag"
bagType (CRLX509 _) = TypeCRLX509
valueASN1S (CRLX509 c) = gOctetString (encodeASN1Object c)
parseValue TypeCRLX509 = CRLX509 <$> parseOctetStringObject "CRLBag"
data SafeType = TypeKey
| TypePKCS8ShroudedKey
| TypeCert
| TypeCRL
| TypeSecret
| TypeSafeContents
deriving (Show,Eq)
instance Enumerable SafeType where
values = [ TypeKey
, TypePKCS8ShroudedKey
, TypeCert
, TypeCRL
, TypeSecret
, TypeSafeContents
]
instance OIDable SafeType where
getObjectID TypeKey = [1,2,840,113549,1,12,10,1,1]
getObjectID TypePKCS8ShroudedKey = [1,2,840,113549,1,12,10,1,2]
getObjectID TypeCert = [1,2,840,113549,1,12,10,1,3]
getObjectID TypeCRL = [1,2,840,113549,1,12,10,1,4]
getObjectID TypeSecret = [1,2,840,113549,1,12,10,1,5]
getObjectID TypeSafeContents = [1,2,840,113549,1,12,10,1,6]
instance OIDNameable SafeType where
fromObjectID oid = unOIDNW <$> fromObjectID oid
data SafeInfo = KeyBag (FormattedKey X509.PrivKey)
| PKCS8ShroudedKeyBag PKCS5
| CertBag (Bag CertInfo)
| CRLBag (Bag CRLInfo)
| SecretBag [ASN1]
| SafeContentsBag SafeContents
deriving (Show,Eq)
instance BagInfo SafeInfo where
type BagType SafeInfo = SafeType
bagName _ = "SafeBag"
bagType (KeyBag _) = TypeKey
bagType (PKCS8ShroudedKeyBag _) = TypePKCS8ShroudedKey
bagType (CertBag _) = TypeCert
bagType (CRLBag _) = TypeCRL
bagType (SecretBag _) = TypeSecret
bagType (SafeContentsBag _) = TypeSafeContents
valueASN1S (KeyBag k) = asn1s k
valueASN1S (PKCS8ShroudedKeyBag k) = asn1s k
valueASN1S (CertBag c) = asn1s c
valueASN1S (CRLBag c) = asn1s c
valueASN1S (SecretBag s) = gMany s
valueASN1S (SafeContentsBag sc) = asn1s sc
parseValue TypeKey = KeyBag <$> parse
parseValue TypePKCS8ShroudedKey = PKCS8ShroudedKeyBag <$> parse
parseValue TypeCert = CertBag <$> parse
parseValue TypeCRL = CRLBag <$> parse
parseValue TypeSecret = SecretBag <$> getMany getNext
parseValue TypeSafeContents = SafeContentsBag <$> parse
type SafeBag = Bag SafeInfo
newtype SafeContents = SafeContents { unSafeContents :: [SafeBag] }
deriving (Show,Eq)
instance ASN1Elem e => ProduceASN1Object e SafeContents where
asn1s (SafeContents s) = asn1Container Sequence (asn1s s)
instance Monoid e => ParseASN1Object e SafeContents where
parse = SafeContents <$> onNextContainer Sequence parse
getSafeKeys :: SafeContents -> [OptProtected X509.PrivKey]
getSafeKeys (SafeContents scs) = loop scs
where
loop [] = []
loop (bag : bags) =
case bagInfo bag of
KeyBag (FormattedKey _ k) -> Unprotected k : loop bags
PKCS8ShroudedKeyBag k -> Protected (unshroud k) : loop bags
SafeContentsBag inner -> getSafeKeys inner ++ loop bags
_ -> loop bags
unshroud shrouded pwd = do
bs <- decrypt shrouded pwd
FormattedKey _ k <- decode bs
return k
getAllSafeKeys :: [SafeContents] -> OptProtected [X509.PrivKey]
getAllSafeKeys = applySamePassword . concatMap getSafeKeys
getSafeX509Certs :: SafeContents -> [X509.SignedCertificate]
getSafeX509Certs (SafeContents scs) = loop scs
where
loop [] = []
loop (bag : bags) =
case bagInfo bag of
CertBag (Bag (CertX509 c) _) -> c : loop bags
SafeContentsBag inner -> getSafeX509Certs inner ++ loop bags
_ -> loop bags
getAllSafeX509Certs :: [SafeContents] -> [X509.SignedCertificate]
getAllSafeX509Certs = concatMap getSafeX509Certs
getSafeX509CRLs :: SafeContents -> [X509.SignedCRL]
getSafeX509CRLs (SafeContents scs) = loop scs
where
loop [] = []
loop (bag : bags) =
case bagInfo bag of
CRLBag (Bag (CRLX509 c) _) -> c : loop bags
SafeContentsBag inner -> getSafeX509CRLs inner ++ loop bags
_ -> loop bags
getAllSafeX509CRLs :: [SafeContents] -> [X509.SignedCRL]
getAllSafeX509CRLs = concatMap getSafeX509CRLs
getInnerCredential :: [SafeContents] -> SamePassword (Maybe (X509.CertificateChain, X509.PrivKey))
getInnerCredential l = SamePassword (fn <$> getAllSafeKeys l)
where
certs = getAllSafeX509Certs l
fn [] = Nothing
fn [k] | null certs = Nothing
| otherwise = Just (X509.CertificateChain certs, k)
fn _ = Nothing
toCredential :: PKCS12 -> OptProtected (Maybe (X509.CertificateChain, X509.PrivKey))
toCredential p12 =
unSamePassword (SamePassword (unPKCS12 p12) >>= getInnerCredential)
fromCredential :: Maybe EncryptionScheme
-> EncryptionScheme
-> Password
-> (X509.CertificateChain, X509.PrivKey)
-> Either StoreError PKCS12
fromCredential algChain algKey pwd (X509.CertificateChain certs, key)
| null certs = Left (InvalidInput "Empty certificate chain")
| otherwise = (<>) <$> pkcs12Chain <*> pkcs12Key
where
pkcs12Key = unencrypted <$> scKeyOrError
pkcs12Chain =
case algChain of
Just alg -> encrypted alg pwd scChain
Nothing -> Right (unencrypted scChain)
scChain = SafeContents (map toCertBag certs)
toCertBag c = Bag (CertBag (Bag (CertX509 c) [])) []
scKeyOrError = wrap <$> encrypt algKey pwd encodedKey
wrap shrouded = SafeContents [Bag (PKCS8ShroudedKeyBag shrouded) []]
encodedKey = encodeASN1Object (FormattedKey PKCS8Format key)
friendlyName :: OID
friendlyName = [1,2,840,113549,1,9,20]
getFriendlyName :: [Attribute] -> Maybe String
getFriendlyName attrs = runParseAttribute friendlyName attrs $ do
ASN1String str <- getNext
case asn1CharacterToString str of
Nothing -> throwParseError "Invalid friendlyName value"
Just s -> return s
setFriendlyName :: String -> [Attribute] -> [Attribute]
setFriendlyName name = setAttributeASN1S friendlyName (gBMPString name)
localKeyId :: OID
localKeyId = [1,2,840,113549,1,9,21]
getLocalKeyId :: [Attribute] -> Maybe BS.ByteString
getLocalKeyId attrs = runParseAttribute localKeyId attrs $ do
OctetString d <- getNext
return d
setLocalKeyId :: BS.ByteString -> [Attribute] -> [Attribute]
setLocalKeyId d = setAttributeASN1S localKeyId (gOctetString d)
newtype SamePassword a = SamePassword { unSamePassword :: OptProtected a }
instance Functor SamePassword where
fmap f (SamePassword opt) = SamePassword (fmap f opt)
instance Applicative SamePassword where
pure a = SamePassword (Unprotected a)
SamePassword (Unprotected f) <*> SamePassword (Unprotected x) =
SamePassword (Unprotected (f x))
SamePassword (Unprotected f) <*> SamePassword (Protected x) =
SamePassword $ Protected (fmap f . x)
SamePassword (Protected f) <*> SamePassword (Unprotected x) =
SamePassword $ Protected (fmap ($ x) . f)
SamePassword (Protected f) <*> SamePassword (Protected x) =
SamePassword $ Protected (\pwd -> f pwd <*> x pwd)
instance Monad SamePassword where
return = pure
SamePassword (Unprotected x) >>= f = f x
SamePassword (Protected inner) >>= f =
SamePassword . Protected $ \pwd ->
case inner pwd of
Left err -> Left err
Right x -> recover pwd (unSamePassword $ f x)
applySamePassword :: [OptProtected a] -> OptProtected [a]
applySamePassword = unSamePassword . traverse SamePassword
decode :: ParseASN1Object [ASN1Event] obj => BS.ByteString -> Either StoreError obj
decode bs =
case decodeASN1Repr' BER bs of
Left e -> Left (DecodingError e)
Right asn1 ->
case fromASN1Repr asn1 of
Right (obj, []) -> Right obj
Right _ -> Left (ParseFailure "Incomplete parse")
Left e -> Left (ParseFailure e)
parseOctetStringObject :: (Monoid e, ParseASN1Object [ASN1Event] obj)
=> String -> ParseASN1 e obj
parseOctetStringObject name = do
OctetString bs <- getNext
case decode bs of
Left e -> throwParseError (name ++ ": " ++ show e)
Right c -> return c