-- |
-- Module      : Crypto.Store.PKCS12
-- License     : BSD-style
-- Maintainer  : Olivier Chéron <olivier.cheron@gmail.com>
-- Stability   : experimental
-- Portability : unknown
--
-- Personal Information Exchange Syntax, aka PKCS #12.
--
-- Only password integrity mode and password privacy modes are supported.
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Crypto.Store.PKCS12
    ( IntegrityParams
    , readP12File
    , readP12FileFromMemory
    , writeP12File
    , writeP12FileToMemory
    , writeUnprotectedP12File
    , writeUnprotectedP12FileToMemory
    -- * PKCS #12 privacy
    , PKCS12
    , unPKCS12
    , unPKCS12'
    , unencrypted
    , encrypted
    -- * PKCS #12 contents and bags
    , SafeContents(..)
    , SafeBag
    , Bag(..)
    , SafeInfo(..)
    , CertInfo(..)
    , CRLInfo(..)
    , Attribute(..)
    , getSafeKeys
    , getAllSafeKeys
    , getSafeX509Certs
    , getAllSafeX509Certs
    , getSafeX509CRLs
    , getAllSafeX509CRLs
    -- * PKCS #12 attributes
    , findAttribute
    , setAttribute
    , filterAttributes
    , getFriendlyName
    , setFriendlyName
    , getLocalKeyId
    , setLocalKeyId
    -- * Credentials
    , fromCredential
    , fromNamedCredential
    , toCredential
    , toNamedCredential
    -- * Password-based protection
    , Password
    , OptAuthenticated(..)
    , recoverAuthenticated
    , ProtectionPassword
    , emptyNotTerminated
    , fromProtectionPassword
    , toProtectionPassword
    , OptProtected(..)
    , recover
    , recoverA
    ) where

import Control.Monad

import           Data.ASN1.Types
import qualified Data.ByteArray as B
import qualified Data.ByteString as BS
import           Data.List (partition)
import           Data.Maybe (fromMaybe, mapMaybe)
import           Data.Semigroup
import qualified Data.X509 as X509
import qualified Data.X509.Validation 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.Enveloped
import Crypto.Store.CMS.Util
import Crypto.Store.Error
import Crypto.Store.PKCS5
import Crypto.Store.PKCS5.PBES1
import Crypto.Store.PKCS8


-- Password-based integrity

-- | Data type for objects that are possibly authenticated with a password.
--
-- Content is verified and retrieved by providing a 'Password' value.  When
-- verification is successful, a value of type 'ProtectionPassword' is also
-- returned and this value can be fed to an inner decryption layer that needs
-- the same password (usual case for PKCS #12).
data OptAuthenticated a = Unauthenticated a
                          -- ^ Value is not authenticated
                        | Authenticated (Password -> Either StoreError (ProtectionPassword, a))
                          -- ^ Value is authenticated with a password

instance Functor OptAuthenticated where
    fmap :: forall a b. (a -> b) -> OptAuthenticated a -> OptAuthenticated b
fmap a -> b
f (Unauthenticated a
x) = forall a. a -> OptAuthenticated a
Unauthenticated (a -> b
f a
x)
    fmap a -> b
f (Authenticated ByteString -> Either StoreError (ProtectionPassword, a)
g)   = forall a.
(ByteString -> Either StoreError (ProtectionPassword, a))
-> OptAuthenticated a
Authenticated (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either StoreError (ProtectionPassword, a)
g)

-- | Try to recover an 'OptAuthenticated' content using the specified password.
--
-- When successful, the content is returned, as well as the password converted
-- to type 'ProtectionPassword'.  This password value can then be fed to the
-- inner decryption layer when both passwords are known to be same (usual case
-- for PKCS #12).
recoverAuthenticated :: Password -> OptAuthenticated a -> Either StoreError (ProtectionPassword, a)
recoverAuthenticated :: forall a.
ByteString
-> OptAuthenticated a -> Either StoreError (ProtectionPassword, a)
recoverAuthenticated ByteString
pwd (Unauthenticated a
x) = forall a b. b -> Either a b
Right (ByteString -> ProtectionPassword
toProtectionPassword ByteString
pwd, a
x)
recoverAuthenticated ByteString
pwd (Authenticated ByteString -> Either StoreError (ProtectionPassword, a)
f)   = ByteString -> Either StoreError (ProtectionPassword, a)
f ByteString
pwd


-- Decoding and parsing

-- | Read a PKCS #12 file from disk.
readP12File :: FilePath -> IO (Either StoreError (OptAuthenticated PKCS12))
readP12File :: String -> IO (Either StoreError (OptAuthenticated PKCS12))
readP12File String
path = ByteString -> Either StoreError (OptAuthenticated PKCS12)
readP12FileFromMemory forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile String
path

-- | Read a PKCS #12 file from a bytearray in BER format.
readP12FileFromMemory :: BS.ByteString -> Either StoreError (OptAuthenticated PKCS12)
readP12FileFromMemory :: ByteString -> Either StoreError (OptAuthenticated PKCS12)
readP12FileFromMemory ByteString
ber = forall obj.
ParseASN1Object [ASN1Event] obj =>
ByteString -> Either StoreError obj
decode ByteString
ber forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {a}.
ParseASN1Object [ASN1Event] a =>
PFX -> Either StoreError (OptAuthenticated a)
integrity
  where
    integrity :: PFX -> Either StoreError (OptAuthenticated a)
integrity PFX{Maybe MacData
ByteString
macData :: PFX -> Maybe MacData
authSafeData :: PFX -> ByteString
macData :: Maybe MacData
authSafeData :: ByteString
..} =
        case Maybe MacData
macData of
            Maybe MacData
Nothing -> forall a. a -> OptAuthenticated a
Unauthenticated forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall obj.
ParseASN1Object [ASN1Event] obj =>
ByteString -> Either StoreError obj
decode ByteString
authSafeData
            Just MacData
md -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
(ByteString -> Either StoreError (ProtectionPassword, a))
-> OptAuthenticated a
Authenticated (forall {a}.
ParseASN1Object [ASN1Event] a =>
MacData
-> ByteString
-> ByteString
-> Either StoreError (ProtectionPassword, a)
verify MacData
md ByteString
authSafeData)

    verify :: MacData
-> ByteString
-> ByteString
-> Either StoreError (ProtectionPassword, a)
verify MacData{MessageAuthenticationCode
DigestAlgorithm
PBEParameter
macParams :: MacData -> PBEParameter
macValue :: MacData -> MessageAuthenticationCode
digAlg :: MacData -> DigestAlgorithm
macParams :: PBEParameter
macValue :: MessageAuthenticationCode
digAlg :: DigestAlgorithm
..} ByteString
content ByteString
pwdUTF8 =
        case DigestAlgorithm
digAlg of
            DigestAlgorithm DigestProxy hashAlg
d -> [ProtectionPassword] -> Either StoreError (ProtectionPassword, a)
loop (ByteString -> [ProtectionPassword]
toProtectionPasswords ByteString
pwdUTF8)
              where
                -- iterate over all possible representations of a password
                -- until a successful match is found
                loop :: [ProtectionPassword] -> Either StoreError (ProtectionPassword, a)
loop []           = forall a b. a -> Either a b
Left StoreError
BadContentMAC
                loop (ProtectionPassword
pwd:[ProtectionPassword]
others) =
                    let fn :: Key
-> MACAlgorithm
-> ByteString
-> Either StoreError (ProtectionPassword, a)
fn Key
key MACAlgorithm
macAlg ByteString
bs
                            | Bool -> Bool
not (forall params. HasStrength params => params -> Bool
securityAcceptable MACAlgorithm
macAlg) =
                                forall a b. a -> Either a b
Left (String -> StoreError
InvalidParameter String
"Integrity MAC too weak")
                            | MessageAuthenticationCode
macValue forall a. Eq a => a -> a -> Bool
== forall key message.
(ByteArrayAccess key, ByteArrayAccess message) =>
MACAlgorithm -> key -> message -> MessageAuthenticationCode
mac MACAlgorithm
macAlg Key
key ByteString
bs = (ProtectionPassword
pwd,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall obj.
ParseASN1Object [ASN1Event] obj =>
ByteString -> Either StoreError obj
decode ByteString
bs
                            | Bool
otherwise = [ProtectionPassword] -> Either StoreError (ProtectionPassword, a)
loop [ProtectionPassword]
others
                     in forall hash result.
HashAlgorithm hash =>
(StoreError -> result)
-> (Key -> MACAlgorithm -> ByteString -> result)
-> DigestProxy hash
-> PBEParameter
-> ByteString
-> ProtectionPassword
-> result
pkcs12mac forall a b. a -> Either a b
Left Key
-> MACAlgorithm
-> ByteString
-> Either StoreError (ProtectionPassword, a)
fn DigestProxy hashAlg
d PBEParameter
macParams ByteString
content ProtectionPassword
pwd


-- Generating and encoding

-- | Parameters used for password integrity mode.
type IntegrityParams = (DigestAlgorithm, PBEParameter)

-- | Write a PKCS #12 file to disk.
writeP12File :: FilePath
             -> IntegrityParams -> ProtectionPassword
             -> PKCS12
             -> IO (Either StoreError ())
writeP12File :: String
-> IntegrityParams
-> ProtectionPassword
-> PKCS12
-> IO (Either StoreError ())
writeP12File String
path IntegrityParams
intp ProtectionPassword
pw PKCS12
aSafe =
    case IntegrityParams
-> ProtectionPassword -> PKCS12 -> Either StoreError ByteString
writeP12FileToMemory IntegrityParams
intp ProtectionPassword
pw PKCS12
aSafe of
        Left StoreError
e   -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left StoreError
e)
        Right ByteString
bs -> forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ByteString -> IO ()
BS.writeFile String
path ByteString
bs

-- | Write a PKCS #12 file to a bytearray in DER format.
writeP12FileToMemory :: IntegrityParams -> ProtectionPassword
                     -> PKCS12
                     -> Either StoreError BS.ByteString
writeP12FileToMemory :: IntegrityParams
-> ProtectionPassword -> PKCS12 -> Either StoreError ByteString
writeP12FileToMemory (alg :: DigestAlgorithm
alg@(DigestAlgorithm DigestProxy hashAlg
hashAlg), PBEParameter
pbeParam) ProtectionPassword
pwdUTF8 PKCS12
aSafe =
    MacData -> ByteString
encode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either StoreError MacData
protect
  where
    content :: ByteString
content   = forall obj. ProduceASN1Object ASN1P obj => obj -> ByteString
encodeASN1Object PKCS12
aSafe
    encode :: MacData -> ByteString
encode MacData
md = forall obj. ProduceASN1Object ASN1P obj => obj -> ByteString
encodeASN1Object PFX { authSafeData :: ByteString
authSafeData = ByteString
content, macData :: Maybe MacData
macData = forall a. a -> Maybe a
Just MacData
md }

    protect :: Either StoreError MacData
protect = forall hash result.
HashAlgorithm hash =>
(StoreError -> result)
-> (Key -> MACAlgorithm -> ByteString -> result)
-> DigestProxy hash
-> PBEParameter
-> ByteString
-> ProtectionPassword
-> result
pkcs12mac forall a b. a -> Either a b
Left Key -> MACAlgorithm -> ByteString -> Either StoreError MacData
fn DigestProxy hashAlg
hashAlg PBEParameter
pbeParam ByteString
content ProtectionPassword
pwdUTF8
    fn :: Key -> MACAlgorithm -> ByteString -> Either StoreError MacData
fn Key
key MACAlgorithm
macAlg ByteString
bs = forall a b. b -> Either a b
Right MacData { digAlg :: DigestAlgorithm
digAlg    = DigestAlgorithm
alg
                                     , macValue :: MessageAuthenticationCode
macValue  = forall key message.
(ByteArrayAccess key, ByteArrayAccess message) =>
MACAlgorithm -> key -> message -> MessageAuthenticationCode
mac MACAlgorithm
macAlg Key
key ByteString
bs
                                     , macParams :: PBEParameter
macParams = PBEParameter
pbeParam
                                     }

-- | Write a PKCS #12 file without integrity protection to disk.
writeUnprotectedP12File :: FilePath -> PKCS12 -> IO ()
writeUnprotectedP12File :: String -> PKCS12 -> IO ()
writeUnprotectedP12File String
path = String -> ByteString -> IO ()
BS.writeFile String
path forall b c a. (b -> c) -> (a -> b) -> a -> c
. PKCS12 -> ByteString
writeUnprotectedP12FileToMemory

-- | Write a PKCS #12 file without integrity protection to a bytearray in DER
-- format.
writeUnprotectedP12FileToMemory :: PKCS12 -> BS.ByteString
writeUnprotectedP12FileToMemory :: PKCS12 -> ByteString
writeUnprotectedP12FileToMemory PKCS12
aSafe = forall obj. ProduceASN1Object ASN1P obj => obj -> ByteString
encodeASN1Object PFX
pfx
  where
    content :: ByteString
content = forall obj. ProduceASN1Object ASN1P obj => obj -> ByteString
encodeASN1Object PKCS12
aSafe
    pfx :: PFX
pfx     = PFX { authSafeData :: ByteString
authSafeData = ByteString
content, macData :: Maybe MacData
macData = forall a. Maybe a
Nothing }


-- PFX and MacData

data PFX = PFX
    { PFX -> ByteString
authSafeData :: BS.ByteString
    , PFX -> Maybe MacData
macData :: Maybe MacData
    }
    deriving (Int -> PFX -> ShowS
[PFX] -> ShowS
PFX -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PFX] -> ShowS
$cshowList :: [PFX] -> ShowS
show :: PFX -> String
$cshow :: PFX -> String
showsPrec :: Int -> PFX -> ShowS
$cshowsPrec :: Int -> PFX -> ShowS
Show,PFX -> PFX -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PFX -> PFX -> Bool
$c/= :: PFX -> PFX -> Bool
== :: PFX -> PFX -> Bool
$c== :: PFX -> PFX -> Bool
Eq)

instance ProduceASN1Object ASN1P PFX where
    asn1s :: PFX -> ASN1Stream ASN1P
asn1s PFX{Maybe MacData
ByteString
macData :: Maybe MacData
authSafeData :: ByteString
macData :: PFX -> Maybe MacData
authSafeData :: PFX -> ByteString
..} =
        forall e.
ASN1Elem e =>
ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
asn1Container ASN1ConstructionType
Sequence (ASN1Stream ASN1P
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASN1Stream ASN1P
a forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASN1Stream ASN1P
m)
      where
        v :: ASN1Stream ASN1P
v = forall e. ASN1Elem e => Integer -> ASN1Stream e
gIntVal Integer
3
        a :: ASN1Stream ASN1P
a = forall e obj. ProduceASN1Object e obj => obj -> ASN1Stream e
asn1s (ByteString -> ContentInfo
DataCI ByteString
authSafeData)
        m :: ASN1Stream ASN1P
m = forall a e. Maybe a -> (a -> ASN1Stream e) -> ASN1Stream e
optASN1S Maybe MacData
macData forall e obj. ProduceASN1Object e obj => obj -> ASN1Stream e
asn1s

instance ParseASN1Object [ASN1Event] PFX where
    parse :: ParseASN1 [ASN1Event] PFX
parse = forall e a.
Monoid e =>
ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e a
onNextContainer ASN1ConstructionType
Sequence forall a b. (a -> b) -> a -> b
$ do
        IntVal Integer
v <- forall e. Monoid e => ParseASN1 e ASN1
getNext
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
v forall a. Eq a => a -> a -> Bool
/= Integer
3) forall a b. (a -> b) -> a -> b
$
            forall e a. String -> ParseASN1 e a
throwParseError (String
"PFX: parsed invalid version: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
v)
        ContentInfo
ci <- forall e obj. ParseASN1Object e obj => ParseASN1 e obj
parse
        ByteString
d <- case ContentInfo
ci of
                 DataCI ByteString
bs      -> forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
                 SignedDataCI SignedData (Encap ByteString)
_ -> forall e a. String -> ParseASN1 e a
throwParseError String
"PFX: public-key integrity mode is not supported"
                 ContentInfo
_              -> forall e a. String -> ParseASN1 e a
throwParseError forall a b. (a -> b) -> a -> b
$ String
"PFX: invalid content type: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (ContentInfo -> ContentType
getContentType ContentInfo
ci)
        Bool
b <- forall e. ParseASN1 e Bool
hasNext
        Maybe MacData
m <- if Bool
b then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e obj. ParseASN1Object e obj => ParseASN1 e obj
parse else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        forall (m :: * -> *) a. Monad m => a -> m a
return PFX { authSafeData :: ByteString
authSafeData = ByteString
d, macData :: Maybe MacData
macData = Maybe MacData
m }

data MacData = MacData
    { MacData -> DigestAlgorithm
digAlg :: DigestAlgorithm
    , MacData -> MessageAuthenticationCode
macValue :: MessageAuthenticationCode
    , MacData -> PBEParameter
macParams :: PBEParameter
    }
    deriving (Int -> MacData -> ShowS
[MacData] -> ShowS
MacData -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MacData] -> ShowS
$cshowList :: [MacData] -> ShowS
show :: MacData -> String
$cshow :: MacData -> String
showsPrec :: Int -> MacData -> ShowS
$cshowsPrec :: Int -> MacData -> ShowS
Show,MacData -> MacData -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MacData -> MacData -> Bool
$c/= :: MacData -> MacData -> Bool
== :: MacData -> MacData -> Bool
$c== :: MacData -> MacData -> Bool
Eq)

instance ASN1Elem e => ProduceASN1Object e MacData where
    asn1s :: MacData -> ASN1Stream e
asn1s MacData{MessageAuthenticationCode
DigestAlgorithm
PBEParameter
macParams :: PBEParameter
macValue :: MessageAuthenticationCode
digAlg :: DigestAlgorithm
macParams :: MacData -> PBEParameter
macValue :: MacData -> MessageAuthenticationCode
digAlg :: MacData -> DigestAlgorithm
..} =
        forall e.
ASN1Elem e =>
ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
asn1Container ASN1ConstructionType
Sequence (ASN1Stream e
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASN1Stream e
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASN1Stream e
i)
      where
        m :: ASN1Stream e
m = forall e.
ASN1Elem e =>
ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
asn1Container ASN1ConstructionType
Sequence (ASN1Stream e
a forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASN1Stream e
v)
        a :: ASN1Stream e
a = forall e param.
(ASN1Elem e, AlgorithmId param, OIDable (AlgorithmType param)) =>
ASN1ConstructionType -> param -> ASN1Stream e
algorithmASN1S ASN1ConstructionType
Sequence DigestAlgorithm
digAlg
        v :: ASN1Stream e
v = forall e. ASN1Elem e => ByteString -> ASN1Stream e
gOctetString (forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
B.convert MessageAuthenticationCode
macValue)
        s :: ASN1Stream e
s = forall e. ASN1Elem e => ByteString -> ASN1Stream e
gOctetString (PBEParameter -> ByteString
pbeSalt PBEParameter
macParams)
        i :: ASN1Stream e
i = forall e. ASN1Elem e => Integer -> ASN1Stream e
gIntVal (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ PBEParameter -> Int
pbeIterationCount PBEParameter
macParams)

instance Monoid e => ParseASN1Object e MacData where
    parse :: ParseASN1 e MacData
parse = forall e a.
Monoid e =>
ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e a
onNextContainer ASN1ConstructionType
Sequence forall a b. (a -> b) -> a -> b
$ do
        (DigestAlgorithm
a, ByteString
v) <- forall e a.
Monoid e =>
ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e a
onNextContainer ASN1ConstructionType
Sequence forall a b. (a -> b) -> a -> b
$ do
            DigestAlgorithm
a <- forall e param.
(Monoid e, AlgorithmId param, OIDNameable (AlgorithmType param)) =>
ASN1ConstructionType -> ParseASN1 e param
parseAlgorithm ASN1ConstructionType
Sequence
            OctetString ByteString
v <- forall e. Monoid e => ParseASN1 e ASN1
getNext
            forall (m :: * -> *) a. Monad m => a -> m a
return (DigestAlgorithm
a, ByteString
v)
        OctetString ByteString
s <- forall e. Monoid e => ParseASN1 e ASN1
getNext
        Bool
b <- forall e. ParseASN1 e Bool
hasNext
        IntVal Integer
i <- if Bool
b then forall e. Monoid e => ParseASN1 e ASN1
getNext else forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> ASN1
IntVal Integer
1)
        forall (m :: * -> *) a. Monad m => a -> m a
return MacData { digAlg :: DigestAlgorithm
digAlg = DigestAlgorithm
a
                       , macValue :: MessageAuthenticationCode
macValue = Bytes -> MessageAuthenticationCode
AuthTag (forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
B.convert ByteString
v)
                       , macParams :: PBEParameter
macParams = ByteString -> Int -> PBEParameter
PBEParameter ByteString
s (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
                       }


-- AuthenticatedSafe

-- | PKCS #12 privacy wrapper, adding optional encryption to 'SafeContents'.
-- ASN.1 equivalent is @AuthenticatedSafe@.
--
-- The semigroup interface allows to combine multiple pieces encrypted
-- separately but they should all derive from the same password to be readable
-- by 'unPKCS12' and most other software.
newtype PKCS12 = PKCS12 [ASElement]
    deriving (Int -> PKCS12 -> ShowS
[PKCS12] -> ShowS
PKCS12 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PKCS12] -> ShowS
$cshowList :: [PKCS12] -> ShowS
show :: PKCS12 -> String
$cshow :: PKCS12 -> String
showsPrec :: Int -> PKCS12 -> ShowS
$cshowsPrec :: Int -> PKCS12 -> ShowS
Show,PKCS12 -> PKCS12 -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PKCS12 -> PKCS12 -> Bool
$c/= :: PKCS12 -> PKCS12 -> Bool
== :: PKCS12 -> PKCS12 -> Bool
$c== :: PKCS12 -> PKCS12 -> Bool
Eq)

instance Semigroup PKCS12 where
    PKCS12 [ASElement]
a <> :: PKCS12 -> PKCS12 -> PKCS12
<> PKCS12 [ASElement]
b = [ASElement] -> PKCS12
PKCS12 ([ASElement]
a forall a. [a] -> [a] -> [a]
++ [ASElement]
b)

instance ProduceASN1Object ASN1P PKCS12 where
    asn1s :: PKCS12 -> ASN1Stream ASN1P
asn1s (PKCS12 [ASElement]
elems) = forall e.
ASN1Elem e =>
ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
asn1Container ASN1ConstructionType
Sequence (forall e obj. ProduceASN1Object e obj => obj -> ASN1Stream e
asn1s [ASElement]
elems)

instance ParseASN1Object [ASN1Event] PKCS12 where
    parse :: ParseASN1 [ASN1Event] PKCS12
parse = [ASElement] -> PKCS12
PKCS12 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a.
Monoid e =>
ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e a
onNextContainer ASN1ConstructionType
Sequence forall e obj. ParseASN1Object e obj => ParseASN1 e obj
parse

-- | Read the contents of a PKCS #12.  The same privacy password will be used
-- for all content elements.
--
-- This convenience function returns a 'Protected' value as soon as one element
-- at least is encrypted.  This does not mean all elements were actually
-- protected in the input.  If detailed view is required then function
-- 'unPKCS12'' is also available.
unPKCS12 :: PKCS12 -> OptProtected [SafeContents]
unPKCS12 :: PKCS12 -> OptProtected [SafeContents]
unPKCS12 = forall a. [OptProtected a] -> OptProtected [a]
applySamePassword forall b c a. (b -> c) -> (a -> b) -> a -> c
. PKCS12 -> [OptProtected SafeContents]
unPKCS12'

-- | Read the contents of a PKCS #12.
unPKCS12' :: PKCS12 -> [OptProtected SafeContents]
unPKCS12' :: PKCS12 -> [OptProtected SafeContents]
unPKCS12' (PKCS12 [ASElement]
elems) = forall a b. (a -> b) -> [a] -> [b]
map ASElement -> OptProtected SafeContents
f [ASElement]
elems
  where f :: ASElement -> OptProtected SafeContents
f (Unencrypted SafeContents
sc) = forall a. a -> OptProtected a
Unprotected SafeContents
sc
        f (Encrypted PKCS5
e)    = forall a.
(ProtectionPassword -> Either StoreError a) -> OptProtected a
Protected (PKCS5 -> ProtectionPassword -> Either StoreError ByteString
decrypt PKCS5
e forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall obj.
ParseASN1Object [ASN1Event] obj =>
ByteString -> Either StoreError obj
decode)

-- | Build a PKCS #12 without encryption.  Usage scenario is when private keys
-- are already encrypted with 'PKCS8ShroudedKeyBag'.
unencrypted :: SafeContents -> PKCS12
unencrypted :: SafeContents -> PKCS12
unencrypted = [ASElement] -> PKCS12
PKCS12 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. SafeContents -> ASElement
Unencrypted

-- | Build a PKCS #12 encrypted with the specified scheme and password.
encrypted :: EncryptionScheme -> ProtectionPassword -> SafeContents -> Either StoreError PKCS12
encrypted :: EncryptionScheme
-> ProtectionPassword -> SafeContents -> Either StoreError PKCS12
encrypted EncryptionScheme
alg ProtectionPassword
pwd SafeContents
sc = [ASElement] -> PKCS12
PKCS12 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. PKCS5 -> ASElement
Encrypted forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EncryptionScheme
-> ProtectionPassword -> ByteString -> Either StoreError PKCS5
encrypt EncryptionScheme
alg ProtectionPassword
pwd ByteString
bs
  where bs :: ByteString
bs = forall obj. ProduceASN1Object ASN1P obj => obj -> ByteString
encodeASN1Object SafeContents
sc

data ASElement = Unencrypted SafeContents
               | Encrypted PKCS5
    deriving (Int -> ASElement -> ShowS
[ASElement] -> ShowS
ASElement -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ASElement] -> ShowS
$cshowList :: [ASElement] -> ShowS
show :: ASElement -> String
$cshow :: ASElement -> String
showsPrec :: Int -> ASElement -> ShowS
$cshowsPrec :: Int -> ASElement -> ShowS
Show,ASElement -> ASElement -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ASElement -> ASElement -> Bool
$c/= :: ASElement -> ASElement -> Bool
== :: ASElement -> ASElement -> Bool
$c== :: ASElement -> ASElement -> Bool
Eq)

instance ASN1Elem e => ProduceASN1Object e ASElement where
    asn1s :: ASElement -> ASN1Stream e
asn1s (Unencrypted SafeContents
sc) = forall e.
ASN1Elem e =>
ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
asn1Container ASN1ConstructionType
Sequence (ASN1Stream e
oid forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASN1Stream e
cont)
      where
        oid :: ASN1Stream e
oid = forall e. ASN1Elem e => OID -> ASN1Stream e
gOID (forall a. OIDable a => a -> OID
getObjectID ContentType
DataType)
        cont :: ASN1Stream e
cont = forall e.
ASN1Elem e =>
ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
asn1Container (ASN1Class -> Int -> ASN1ConstructionType
Container ASN1Class
Context Int
0) (forall e. ASN1Elem e => ByteString -> ASN1Stream e
gOctetString ByteString
bs)
        bs :: ByteString
bs = forall obj. ProduceASN1Object ASN1P obj => obj -> ByteString
encodeASN1Object SafeContents
sc

    asn1s (Encrypted PKCS5{ByteString
EncryptionScheme
encryptedData :: PKCS5 -> ByteString
encryptionAlgorithm :: PKCS5 -> EncryptionScheme
encryptedData :: ByteString
encryptionAlgorithm :: EncryptionScheme
..}) = forall e.
ASN1Elem e =>
ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
asn1Container ASN1ConstructionType
Sequence (ASN1Stream e
oid forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASN1Stream e
cont)
      where
        oid :: ASN1Stream e
oid = forall e. ASN1Elem e => OID -> ASN1Stream e
gOID (forall a. OIDable a => a -> OID
getObjectID ContentType
EncryptedDataType)
        cont :: ASN1Stream e
cont = forall e.
ASN1Elem e =>
ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
asn1Container (ASN1Class -> Int -> ASN1ConstructionType
Container ASN1Class
Context Int
0) ASN1Stream e
inner
        inner :: ASN1Stream e
inner = forall e.
ASN1Elem e =>
ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
asn1Container ASN1ConstructionType
Sequence (forall e. ASN1Elem e => Integer -> ASN1Stream e
gIntVal Integer
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASN1Stream e
eci)
        eci :: ASN1Stream e
eci = forall e alg.
(ASN1Elem e, ProduceASN1Object e alg) =>
(ContentType, alg, Encap ByteString) -> ASN1Stream e
encryptedContentInfoASN1S
                  (ContentType
DataType, EncryptionScheme
encryptionAlgorithm, forall a. a -> Encap a
Attached ByteString
encryptedData)

instance Monoid e => ParseASN1Object e ASElement where
    parse :: ParseASN1 e ASElement
parse = forall e a.
Monoid e =>
ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e a
onNextContainer ASN1ConstructionType
Sequence forall a b. (a -> b) -> a -> b
$ do
        OID OID
oid <- forall e. Monoid e => ParseASN1 e ASN1
getNext
        forall a e b.
OIDNameable a =>
String -> OID -> (a -> ParseASN1 e b) -> ParseASN1 e b
withObjectID String
"content type" OID
oid forall a b. (a -> b) -> a -> b
$ \ContentType
ct ->
            forall e a.
Monoid e =>
ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e a
onNextContainer (ASN1Class -> Int -> ASN1ConstructionType
Container ASN1Class
Context Int
0) (ContentType -> ParseASN1 e ASElement
parseInner ContentType
ct)
      where
        parseInner :: ContentType -> ParseASN1 e ASElement
parseInner ContentType
DataType          = SafeContents -> ASElement
Unencrypted forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseASN1 e SafeContents
parseUnencrypted
        parseInner ContentType
EncryptedDataType = PKCS5 -> ASElement
Encrypted forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseASN1 e PKCS5
parseEncrypted
        parseInner ContentType
EnvelopedDataType = forall e a. String -> ParseASN1 e a
throwParseError String
"PKCS12: public-key privacy mode is not supported"
        parseInner ContentType
ct                = forall e a. String -> ParseASN1 e a
throwParseError forall a b. (a -> b) -> a -> b
$ String
"PKCS12: invalid content type: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ContentType
ct

        parseUnencrypted :: ParseASN1 e SafeContents
parseUnencrypted = forall e obj.
(Monoid e, ParseASN1Object [ASN1Event] obj) =>
String -> ParseASN1 e obj
parseOctetStringObject String
"PKCS12"
        parseEncrypted :: ParseASN1 e PKCS5
parseEncrypted = forall e a.
Monoid e =>
ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e a
onNextContainer ASN1ConstructionType
Sequence forall a b. (a -> b) -> a -> b
$ do
            IntVal Integer
0 <- forall e. Monoid e => ParseASN1 e ASN1
getNext
            (ContentType
DataType, EncryptionScheme
eScheme, Attached ByteString
ed) <- forall e alg.
ParseASN1Object e alg =>
ParseASN1 e (ContentType, alg, Encap ByteString)
parseEncryptedContentInfo
            forall (m :: * -> *) a. Monad m => a -> m a
return PKCS5 { encryptionAlgorithm :: EncryptionScheme
encryptionAlgorithm = EncryptionScheme
eScheme, encryptedData :: ByteString
encryptedData = ByteString
ed }


-- Bags

-- | Polymorphic PKCS #12 bag parameterized by the payload data type.
data Bag info = Bag
    { forall info. Bag info -> info
bagInfo :: info              -- ^ bag payload
    , forall info. Bag info -> [Attribute]
bagAttributes :: [Attribute] -- ^ attributes providing additional information
    }
    deriving (Int -> Bag info -> ShowS
forall info. Show info => Int -> Bag info -> ShowS
forall info. Show info => [Bag info] -> ShowS
forall info. Show info => Bag info -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Bag info] -> ShowS
$cshowList :: forall info. Show info => [Bag info] -> ShowS
show :: Bag info -> String
$cshow :: forall info. Show info => Bag info -> String
showsPrec :: Int -> Bag info -> ShowS
$cshowsPrec :: forall info. Show info => Int -> Bag info -> ShowS
Show,Bag info -> Bag info -> Bool
forall info. Eq info => Bag info -> Bag info -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bag info -> Bag info -> Bool
$c/= :: forall info. Eq info => Bag info -> Bag info -> Bool
== :: Bag info -> Bag info -> Bool
$c== :: forall info. Eq info => Bag info -> Bag info -> Bool
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 info -> ASN1Stream e
asn1s Bag{info
[Attribute]
bagAttributes :: [Attribute]
bagInfo :: info
bagAttributes :: forall info. Bag info -> [Attribute]
bagInfo :: forall info. Bag info -> info
..} = forall e.
ASN1Elem e =>
ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
asn1Container ASN1ConstructionType
Sequence (ASN1Stream e
oid forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASN1Stream e
val forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASN1Stream e
att)
      where
        typ :: BagType info
typ = forall info. BagInfo info => info -> BagType info
bagType info
bagInfo
        oid :: ASN1Stream e
oid = forall e. ASN1Elem e => OID -> ASN1Stream e
gOID (forall a. OIDable a => a -> OID
getObjectID BagType info
typ)
        val :: ASN1Stream e
val = forall e.
ASN1Elem e =>
ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
asn1Container (ASN1Class -> Int -> ASN1ConstructionType
Container ASN1Class
Context Int
0) (forall info e. (BagInfo info, ASN1Elem e) => info -> ASN1Stream e
valueASN1S info
bagInfo)

        att :: ASN1Stream e
att | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Attribute]
bagAttributes = forall a. a -> a
id
            | Bool
otherwise          = forall e.
ASN1Elem e =>
ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
asn1Container ASN1ConstructionType
Set (forall e obj. ProduceASN1Object e obj => obj -> ASN1Stream e
asn1s [Attribute]
bagAttributes)

instance (Monoid e, BagInfo info, OIDNameable (BagType info)) => ParseASN1Object e (Bag info) where
    parse :: ParseASN1 e (Bag info)
parse = forall e a.
Monoid e =>
ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e a
onNextContainer ASN1ConstructionType
Sequence forall a b. (a -> b) -> a -> b
$ do
        OID OID
oid <- forall e. Monoid e => ParseASN1 e ASN1
getNext
        info
val <- forall a e b.
OIDNameable a =>
String -> OID -> (a -> ParseASN1 e b) -> ParseASN1 e b
withObjectID (info -> String
getName forall a. HasCallStack => a
undefined) OID
oid forall a b. (a -> b) -> a -> b
$
                   forall e a.
Monoid e =>
ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e a
onNextContainer (ASN1Class -> Int -> ASN1ConstructionType
Container ASN1Class
Context Int
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall info e.
(BagInfo info, Monoid e) =>
BagType info -> ParseASN1 e info
parseValue
        [Attribute]
att <- forall a. a -> Maybe a -> a
fromMaybe [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a.
Monoid e =>
ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e (Maybe a)
onNextContainerMaybe ASN1ConstructionType
Set forall e obj. ParseASN1Object e obj => ParseASN1 e obj
parse
        forall (m :: * -> *) a. Monad m => a -> m a
return Bag { bagInfo :: info
bagInfo = info
val, bagAttributes :: [Attribute]
bagAttributes = [Attribute]
att }
      where
        getName :: info -> String
        getName :: info -> String
getName = forall info. BagInfo info => info -> String
bagName

data CertType = TypeCertX509 deriving (Int -> CertType -> ShowS
[CertType] -> ShowS
CertType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CertType] -> ShowS
$cshowList :: [CertType] -> ShowS
show :: CertType -> String
$cshow :: CertType -> String
showsPrec :: Int -> CertType -> ShowS
$cshowsPrec :: Int -> CertType -> ShowS
Show,CertType -> CertType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CertType -> CertType -> Bool
$c/= :: CertType -> CertType -> Bool
== :: CertType -> CertType -> Bool
$c== :: CertType -> CertType -> Bool
Eq)

instance Enumerable CertType where
    values :: [CertType]
values = [ CertType
TypeCertX509 ]

instance OIDable CertType where
    getObjectID :: CertType -> OID
getObjectID CertType
TypeCertX509 = [Integer
1,Integer
2,Integer
840,Integer
113549,Integer
1,Integer
9,Integer
22,Integer
1]

instance OIDNameable CertType where
    fromObjectID :: OID -> Maybe CertType
fromObjectID OID
oid = forall a. OIDNameableWrapper a -> a
unOIDNW forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. OIDNameable a => OID -> Maybe a
fromObjectID OID
oid

-- | Certificate bags.  Only X.509 certificates are supported.
newtype CertInfo = CertX509 X509.SignedCertificate deriving (Int -> CertInfo -> ShowS
[CertInfo] -> ShowS
CertInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CertInfo] -> ShowS
$cshowList :: [CertInfo] -> ShowS
show :: CertInfo -> String
$cshow :: CertInfo -> String
showsPrec :: Int -> CertInfo -> ShowS
$cshowsPrec :: Int -> CertInfo -> ShowS
Show,CertInfo -> CertInfo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CertInfo -> CertInfo -> Bool
$c/= :: CertInfo -> CertInfo -> Bool
== :: CertInfo -> CertInfo -> Bool
$c== :: CertInfo -> CertInfo -> Bool
Eq)

instance BagInfo CertInfo where
    type BagType CertInfo = CertType
    bagName :: CertInfo -> String
bagName CertInfo
_ = String
"CertBag"
    bagType :: CertInfo -> BagType CertInfo
bagType (CertX509 SignedCertificate
_) = CertType
TypeCertX509
    valueASN1S :: forall e. ASN1Elem e => CertInfo -> ASN1Stream e
valueASN1S (CertX509 SignedCertificate
c) = forall e. ASN1Elem e => ByteString -> ASN1Stream e
gOctetString (forall obj. ProduceASN1Object ASN1P obj => obj -> ByteString
encodeASN1Object SignedCertificate
c)
    parseValue :: forall e. Monoid e => BagType CertInfo -> ParseASN1 e CertInfo
parseValue CertType
BagType CertInfo
TypeCertX509 = SignedCertificate -> CertInfo
CertX509 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e obj.
(Monoid e, ParseASN1Object [ASN1Event] obj) =>
String -> ParseASN1 e obj
parseOctetStringObject String
"CertBag"

data CRLType = TypeCRLX509 deriving (Int -> CRLType -> ShowS
[CRLType] -> ShowS
CRLType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CRLType] -> ShowS
$cshowList :: [CRLType] -> ShowS
show :: CRLType -> String
$cshow :: CRLType -> String
showsPrec :: Int -> CRLType -> ShowS
$cshowsPrec :: Int -> CRLType -> ShowS
Show,CRLType -> CRLType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CRLType -> CRLType -> Bool
$c/= :: CRLType -> CRLType -> Bool
== :: CRLType -> CRLType -> Bool
$c== :: CRLType -> CRLType -> Bool
Eq)

instance Enumerable CRLType where
    values :: [CRLType]
values = [ CRLType
TypeCRLX509 ]

instance OIDable CRLType where
    getObjectID :: CRLType -> OID
getObjectID CRLType
TypeCRLX509 = [Integer
1,Integer
2,Integer
840,Integer
113549,Integer
1,Integer
9,Integer
23,Integer
1]

instance OIDNameable CRLType where
    fromObjectID :: OID -> Maybe CRLType
fromObjectID OID
oid = forall a. OIDNameableWrapper a -> a
unOIDNW forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. OIDNameable a => OID -> Maybe a
fromObjectID OID
oid

-- | CRL bags.  Only X.509 CRLs are supported.
newtype CRLInfo = CRLX509 X509.SignedCRL deriving (Int -> CRLInfo -> ShowS
[CRLInfo] -> ShowS
CRLInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CRLInfo] -> ShowS
$cshowList :: [CRLInfo] -> ShowS
show :: CRLInfo -> String
$cshow :: CRLInfo -> String
showsPrec :: Int -> CRLInfo -> ShowS
$cshowsPrec :: Int -> CRLInfo -> ShowS
Show,CRLInfo -> CRLInfo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CRLInfo -> CRLInfo -> Bool
$c/= :: CRLInfo -> CRLInfo -> Bool
== :: CRLInfo -> CRLInfo -> Bool
$c== :: CRLInfo -> CRLInfo -> Bool
Eq)

instance BagInfo CRLInfo where
    type BagType CRLInfo = CRLType
    bagName :: CRLInfo -> String
bagName CRLInfo
_ = String
"CRLBag"
    bagType :: CRLInfo -> BagType CRLInfo
bagType (CRLX509 SignedCRL
_) = CRLType
TypeCRLX509
    valueASN1S :: forall e. ASN1Elem e => CRLInfo -> ASN1Stream e
valueASN1S (CRLX509 SignedCRL
c) = forall e. ASN1Elem e => ByteString -> ASN1Stream e
gOctetString (forall obj. ProduceASN1Object ASN1P obj => obj -> ByteString
encodeASN1Object SignedCRL
c)
    parseValue :: forall e. Monoid e => BagType CRLInfo -> ParseASN1 e CRLInfo
parseValue CRLType
BagType CRLInfo
TypeCRLX509 = SignedCRL -> CRLInfo
CRLX509 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e obj.
(Monoid e, ParseASN1Object [ASN1Event] obj) =>
String -> ParseASN1 e obj
parseOctetStringObject String
"CRLBag"

data SafeType = TypeKey
              | TypePKCS8ShroudedKey
              | TypeCert
              | TypeCRL
              | TypeSecret
              | TypeSafeContents
    deriving (Int -> SafeType -> ShowS
[SafeType] -> ShowS
SafeType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SafeType] -> ShowS
$cshowList :: [SafeType] -> ShowS
show :: SafeType -> String
$cshow :: SafeType -> String
showsPrec :: Int -> SafeType -> ShowS
$cshowsPrec :: Int -> SafeType -> ShowS
Show,SafeType -> SafeType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SafeType -> SafeType -> Bool
$c/= :: SafeType -> SafeType -> Bool
== :: SafeType -> SafeType -> Bool
$c== :: SafeType -> SafeType -> Bool
Eq)

instance Enumerable SafeType where
    values :: [SafeType]
values = [ SafeType
TypeKey
             , SafeType
TypePKCS8ShroudedKey
             , SafeType
TypeCert
             , SafeType
TypeCRL
             , SafeType
TypeSecret
             , SafeType
TypeSafeContents
             ]

instance OIDable SafeType where
    getObjectID :: SafeType -> OID
getObjectID SafeType
TypeKey              = [Integer
1,Integer
2,Integer
840,Integer
113549,Integer
1,Integer
12,Integer
10,Integer
1,Integer
1]
    getObjectID SafeType
TypePKCS8ShroudedKey = [Integer
1,Integer
2,Integer
840,Integer
113549,Integer
1,Integer
12,Integer
10,Integer
1,Integer
2]
    getObjectID SafeType
TypeCert             = [Integer
1,Integer
2,Integer
840,Integer
113549,Integer
1,Integer
12,Integer
10,Integer
1,Integer
3]
    getObjectID SafeType
TypeCRL              = [Integer
1,Integer
2,Integer
840,Integer
113549,Integer
1,Integer
12,Integer
10,Integer
1,Integer
4]
    getObjectID SafeType
TypeSecret           = [Integer
1,Integer
2,Integer
840,Integer
113549,Integer
1,Integer
12,Integer
10,Integer
1,Integer
5]
    getObjectID SafeType
TypeSafeContents     = [Integer
1,Integer
2,Integer
840,Integer
113549,Integer
1,Integer
12,Integer
10,Integer
1,Integer
6]

instance OIDNameable SafeType where
    fromObjectID :: OID -> Maybe SafeType
fromObjectID OID
oid = forall a. OIDNameableWrapper a -> a
unOIDNW forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. OIDNameable a => OID -> Maybe a
fromObjectID OID
oid

-- | Main bag payload in PKCS #12 contents.
data SafeInfo = KeyBag (FormattedKey X509.PrivKey) -- ^ unencrypted private key
              | PKCS8ShroudedKeyBag PKCS5          -- ^ encrypted private key
              | CertBag (Bag CertInfo)             -- ^ certificate
              | CRLBag (Bag CRLInfo)               -- ^ CRL
              | SecretBag [ASN1]                   -- ^ arbitrary secret
              | SafeContentsBag SafeContents       -- ^ safe contents embeded recursively
    deriving (Int -> SafeInfo -> ShowS
[SafeInfo] -> ShowS
SafeInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SafeInfo] -> ShowS
$cshowList :: [SafeInfo] -> ShowS
show :: SafeInfo -> String
$cshow :: SafeInfo -> String
showsPrec :: Int -> SafeInfo -> ShowS
$cshowsPrec :: Int -> SafeInfo -> ShowS
Show,SafeInfo -> SafeInfo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SafeInfo -> SafeInfo -> Bool
$c/= :: SafeInfo -> SafeInfo -> Bool
== :: SafeInfo -> SafeInfo -> Bool
$c== :: SafeInfo -> SafeInfo -> Bool
Eq)

instance BagInfo SafeInfo where
    type BagType SafeInfo = SafeType
    bagName :: SafeInfo -> String
bagName SafeInfo
_ = String
"SafeBag"

    bagType :: SafeInfo -> BagType SafeInfo
bagType (KeyBag FormattedKey PrivKey
_)              = SafeType
TypeKey
    bagType (PKCS8ShroudedKeyBag PKCS5
_) = SafeType
TypePKCS8ShroudedKey
    bagType (CertBag Bag CertInfo
_)             = SafeType
TypeCert
    bagType (CRLBag Bag CRLInfo
_)              = SafeType
TypeCRL
    bagType (SecretBag [ASN1]
_)           = SafeType
TypeSecret
    bagType (SafeContentsBag SafeContents
_)     = SafeType
TypeSafeContents

    valueASN1S :: forall e. ASN1Elem e => SafeInfo -> ASN1Stream e
valueASN1S (KeyBag FormattedKey PrivKey
k)              = forall e obj. ProduceASN1Object e obj => obj -> ASN1Stream e
asn1s FormattedKey PrivKey
k
    valueASN1S (PKCS8ShroudedKeyBag PKCS5
k) = forall e obj. ProduceASN1Object e obj => obj -> ASN1Stream e
asn1s PKCS5
k
    valueASN1S (CertBag Bag CertInfo
c)             = forall e obj. ProduceASN1Object e obj => obj -> ASN1Stream e
asn1s Bag CertInfo
c
    valueASN1S (CRLBag Bag CRLInfo
c)              = forall e obj. ProduceASN1Object e obj => obj -> ASN1Stream e
asn1s Bag CRLInfo
c
    valueASN1S (SecretBag [ASN1]
s)           = forall e. ASN1Elem e => [ASN1] -> ASN1Stream e
gMany [ASN1]
s
    valueASN1S (SafeContentsBag SafeContents
sc)    = forall e obj. ProduceASN1Object e obj => obj -> ASN1Stream e
asn1s SafeContents
sc

    parseValue :: forall e. Monoid e => BagType SafeInfo -> ParseASN1 e SafeInfo
parseValue SafeType
BagType SafeInfo
TypeKey              = FormattedKey PrivKey -> SafeInfo
KeyBag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e obj. ParseASN1Object e obj => ParseASN1 e obj
parse
    parseValue SafeType
BagType SafeInfo
TypePKCS8ShroudedKey = PKCS5 -> SafeInfo
PKCS8ShroudedKeyBag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e obj. ParseASN1Object e obj => ParseASN1 e obj
parse
    parseValue SafeType
BagType SafeInfo
TypeCert             = Bag CertInfo -> SafeInfo
CertBag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e obj. ParseASN1Object e obj => ParseASN1 e obj
parse
    parseValue SafeType
BagType SafeInfo
TypeCRL              = Bag CRLInfo -> SafeInfo
CRLBag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e obj. ParseASN1Object e obj => ParseASN1 e obj
parse
    parseValue SafeType
BagType SafeInfo
TypeSecret           = [ASN1] -> SafeInfo
SecretBag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a. ParseASN1 e a -> ParseASN1 e [a]
getMany forall e. Monoid e => ParseASN1 e ASN1
getNext
    parseValue SafeType
BagType SafeInfo
TypeSafeContents     = SafeContents -> SafeInfo
SafeContentsBag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e obj. ParseASN1Object e obj => ParseASN1 e obj
parse

-- | Main bag type in a PKCS #12.
type SafeBag = Bag SafeInfo

-- | Content objects stored in a PKCS #12.
newtype SafeContents = SafeContents { SafeContents -> [SafeBag]
unSafeContents :: [SafeBag] }
    deriving (Int -> SafeContents -> ShowS
[SafeContents] -> ShowS
SafeContents -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SafeContents] -> ShowS
$cshowList :: [SafeContents] -> ShowS
show :: SafeContents -> String
$cshow :: SafeContents -> String
showsPrec :: Int -> SafeContents -> ShowS
$cshowsPrec :: Int -> SafeContents -> ShowS
Show,SafeContents -> SafeContents -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SafeContents -> SafeContents -> Bool
$c/= :: SafeContents -> SafeContents -> Bool
== :: SafeContents -> SafeContents -> Bool
$c== :: SafeContents -> SafeContents -> Bool
Eq)

instance ASN1Elem e => ProduceASN1Object e SafeContents where
    asn1s :: SafeContents -> ASN1Stream e
asn1s (SafeContents [SafeBag]
s) = forall e.
ASN1Elem e =>
ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
asn1Container ASN1ConstructionType
Sequence (forall e obj. ProduceASN1Object e obj => obj -> ASN1Stream e
asn1s [SafeBag]
s)

instance Monoid e => ParseASN1Object e SafeContents where
    parse :: ParseASN1 e SafeContents
parse = [SafeBag] -> SafeContents
SafeContents forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a.
Monoid e =>
ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e a
onNextContainer ASN1ConstructionType
Sequence forall e obj. ParseASN1Object e obj => ParseASN1 e obj
parse

filterBags :: ([Attribute] -> Bool) -> SafeContents -> SafeContents
filterBags :: ([Attribute] -> Bool) -> SafeContents -> SafeContents
filterBags [Attribute] -> Bool
p (SafeContents [SafeBag]
scs) = [SafeBag] -> SafeContents
SafeContents (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SafeBag -> Maybe SafeBag
f [SafeBag]
scs)
  where
    f :: SafeBag -> Maybe SafeBag
f (Bag (SafeContentsBag SafeContents
inner) [Attribute]
attrs) =
        forall a. a -> Maybe a
Just (forall info. info -> [Attribute] -> Bag info
Bag (SafeContents -> SafeInfo
SafeContentsBag forall a b. (a -> b) -> a -> b
$ ([Attribute] -> Bool) -> SafeContents -> SafeContents
filterBags [Attribute] -> Bool
p SafeContents
inner) [Attribute]
attrs)
    f SafeBag
bag | [Attribute] -> Bool
p (forall info. Bag info -> [Attribute]
bagAttributes SafeBag
bag)         = forall a. a -> Maybe a
Just SafeBag
bag
          | Bool
otherwise                     = forall a. Maybe a
Nothing

filterByFriendlyName :: String -> SafeContents -> SafeContents
filterByFriendlyName :: String -> SafeContents -> SafeContents
filterByFriendlyName String
name = ([Attribute] -> Bool) -> SafeContents -> SafeContents
filterBags ((forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just String
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Attribute] -> Maybe String
getFriendlyName)

filterByLocalKeyId :: BS.ByteString -> SafeContents -> SafeContents
filterByLocalKeyId :: ByteString -> SafeContents -> SafeContents
filterByLocalKeyId ByteString
d = ([Attribute] -> Bool) -> SafeContents -> SafeContents
filterBags ((forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ByteString
d) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Attribute] -> Maybe ByteString
getLocalKeyId)

getSafeKeysId :: SafeContents -> [OptProtected (Id X509.PrivKey)]
getSafeKeysId :: SafeContents -> [OptProtected (Id PrivKey)]
getSafeKeysId (SafeContents [SafeBag]
scs) = [SafeBag] -> [OptProtected (Id PrivKey)]
loop [SafeBag]
scs
  where
    loop :: [SafeBag] -> [OptProtected (Id PrivKey)]
loop []           = []
    loop (SafeBag
bag : [SafeBag]
bags) =
        case forall info. Bag info -> info
bagInfo SafeBag
bag of
            KeyBag (FormattedKey PrivateKeyFormat
_ PrivKey
k) -> forall a. a -> OptProtected a
Unprotected (forall a info. a -> Bag info -> Id a
mkId PrivKey
k SafeBag
bag) forall a. a -> [a] -> [a]
: [SafeBag] -> [OptProtected (Id PrivKey)]
loop [SafeBag]
bags
            PKCS8ShroudedKeyBag PKCS5
k     -> forall a.
(ProtectionPassword -> Either StoreError a) -> OptProtected a
Protected (forall {a} {info}.
(ParseASN1Object [ASN1Event] (Traditional a),
 ParseASN1Object [ASN1Event] (Modern a)) =>
PKCS5 -> Bag info -> ProtectionPassword -> Either StoreError (Id a)
unshroud PKCS5
k SafeBag
bag) forall a. a -> [a] -> [a]
: [SafeBag] -> [OptProtected (Id PrivKey)]
loop [SafeBag]
bags
            SafeContentsBag SafeContents
inner     -> SafeContents -> [OptProtected (Id PrivKey)]
getSafeKeysId SafeContents
inner forall a. [a] -> [a] -> [a]
++ [SafeBag] -> [OptProtected (Id PrivKey)]
loop [SafeBag]
bags
            SafeInfo
_                         -> [SafeBag] -> [OptProtected (Id PrivKey)]
loop [SafeBag]
bags

    unshroud :: PKCS5 -> Bag info -> ProtectionPassword -> Either StoreError (Id a)
unshroud PKCS5
shrouded Bag info
bag ProtectionPassword
pwd = do
        ByteString
bs <- PKCS5 -> ProtectionPassword -> Either StoreError ByteString
decrypt PKCS5
shrouded ProtectionPassword
pwd
        FormattedKey PrivateKeyFormat
_ a
k <- forall obj.
ParseASN1Object [ASN1Event] obj =>
ByteString -> Either StoreError obj
decode ByteString
bs
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a info. a -> Bag info -> Id a
mkId a
k Bag info
bag)

-- | Return all private keys contained in the safe contents.
getSafeKeys :: SafeContents -> [OptProtected X509.PrivKey]
getSafeKeys :: SafeContents -> [OptProtected PrivKey]
getSafeKeys = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Id a -> a
unId) forall b c a. (b -> c) -> (a -> b) -> a -> c
. SafeContents -> [OptProtected (Id PrivKey)]
getSafeKeysId

getAllSafeKeysId :: [SafeContents] -> OptProtected [Id X509.PrivKey]
getAllSafeKeysId :: [SafeContents] -> OptProtected [Id PrivKey]
getAllSafeKeysId = forall a. [OptProtected a] -> OptProtected [a]
applySamePassword forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SafeContents -> [OptProtected (Id PrivKey)]
getSafeKeysId

-- | Return all private keys contained in the safe content list.  All shrouded
-- private keys must derive from the same password.
--
-- This convenience function returns a 'Protected' value as soon as one key at
-- least is encrypted.  This does not mean all keys were actually protected in
-- the input.  If detailed view is required then function 'getSafeKeys' is
-- available.
getAllSafeKeys :: [SafeContents] -> OptProtected [X509.PrivKey]
getAllSafeKeys :: [SafeContents] -> OptProtected [PrivKey]
getAllSafeKeys = forall a. [OptProtected a] -> OptProtected [a]
applySamePassword forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SafeContents -> [OptProtected PrivKey]
getSafeKeys

getSafeX509CertsId :: SafeContents -> [Id X509.SignedCertificate]
getSafeX509CertsId :: SafeContents -> [Id SignedCertificate]
getSafeX509CertsId (SafeContents [SafeBag]
scs) = [SafeBag] -> [Id SignedCertificate]
loop [SafeBag]
scs
  where
    loop :: [SafeBag] -> [Id SignedCertificate]
loop []           = []
    loop (SafeBag
bag : [SafeBag]
bags) =
        case forall info. Bag info -> info
bagInfo SafeBag
bag of
            CertBag (Bag (CertX509 SignedCertificate
c) [Attribute]
_) -> forall a info. a -> Bag info -> Id a
mkId SignedCertificate
c SafeBag
bag forall a. a -> [a] -> [a]
: [SafeBag] -> [Id SignedCertificate]
loop [SafeBag]
bags
            SafeContentsBag SafeContents
inner        -> SafeContents -> [Id SignedCertificate]
getSafeX509CertsId SafeContents
inner forall a. [a] -> [a] -> [a]
++ [SafeBag] -> [Id SignedCertificate]
loop [SafeBag]
bags
            SafeInfo
_                            -> [SafeBag] -> [Id SignedCertificate]
loop [SafeBag]
bags

-- | Return all X.509 certificates contained in the safe contents.
getSafeX509Certs :: SafeContents -> [X509.SignedCertificate]
getSafeX509Certs :: SafeContents -> [SignedCertificate]
getSafeX509Certs = forall a b. (a -> b) -> [a] -> [b]
map forall a. Id a -> a
unId forall b c a. (b -> c) -> (a -> b) -> a -> c
. SafeContents -> [Id SignedCertificate]
getSafeX509CertsId

-- | Return all X.509 certificates contained in the safe content list.
getAllSafeX509Certs :: [SafeContents] -> [X509.SignedCertificate]
getAllSafeX509Certs :: [SafeContents] -> [SignedCertificate]
getAllSafeX509Certs = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SafeContents -> [SignedCertificate]
getSafeX509Certs

getSafeX509CRLsId :: SafeContents -> [Id X509.SignedCRL]
getSafeX509CRLsId :: SafeContents -> [Id SignedCRL]
getSafeX509CRLsId (SafeContents [SafeBag]
scs) = [SafeBag] -> [Id SignedCRL]
loop [SafeBag]
scs
  where
    loop :: [SafeBag] -> [Id SignedCRL]
loop []           = []
    loop (SafeBag
bag : [SafeBag]
bags) =
        case forall info. Bag info -> info
bagInfo SafeBag
bag of
            CRLBag (Bag (CRLX509 SignedCRL
c) [Attribute]
_) -> forall a info. a -> Bag info -> Id a
mkId SignedCRL
c SafeBag
bag forall a. a -> [a] -> [a]
: [SafeBag] -> [Id SignedCRL]
loop [SafeBag]
bags
            SafeContentsBag SafeContents
inner      -> SafeContents -> [Id SignedCRL]
getSafeX509CRLsId SafeContents
inner forall a. [a] -> [a] -> [a]
++ [SafeBag] -> [Id SignedCRL]
loop [SafeBag]
bags
            SafeInfo
_                          -> [SafeBag] -> [Id SignedCRL]
loop [SafeBag]
bags

-- | Return all X.509 CRLs contained in the safe contents.
getSafeX509CRLs :: SafeContents -> [X509.SignedCRL]
getSafeX509CRLs :: SafeContents -> [SignedCRL]
getSafeX509CRLs = forall a b. (a -> b) -> [a] -> [b]
map forall a. Id a -> a
unId forall b c a. (b -> c) -> (a -> b) -> a -> c
. SafeContents -> [Id SignedCRL]
getSafeX509CRLsId

-- | Return all X.509 CRLs contained in the safe content list.
getAllSafeX509CRLs :: [SafeContents] -> [X509.SignedCRL]
getAllSafeX509CRLs :: [SafeContents] -> [SignedCRL]
getAllSafeX509CRLs = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SafeContents -> [SignedCRL]
getSafeX509CRLs


-- Conversion to/from credentials

getInnerCredential :: [SafeContents] -> SamePassword (Maybe (X509.CertificateChain, X509.PrivKey))
getInnerCredential :: [SafeContents] -> SamePassword (Maybe (CertificateChain, PrivKey))
getInnerCredential [SafeContents]
l = forall a. OptProtected a -> SamePassword a
SamePassword ([Id PrivKey] -> Maybe (CertificateChain, PrivKey)
fn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SafeContents] -> OptProtected [Id PrivKey]
getAllSafeKeysId [SafeContents]
l)
  where
    certs :: [SignedCertificate]
certs     = [SafeContents] -> [SignedCertificate]
getAllSafeX509Certs [SafeContents]
l
    fn :: [Id PrivKey] -> Maybe (CertificateChain, PrivKey)
fn [Id PrivKey]
idKeys = do
        Id PrivKey
iKey <- forall a. [a] -> Maybe a
single [Id PrivKey]
idKeys
        let k :: PrivKey
k = forall a. Id a -> a
unId Id PrivKey
iKey
        case forall a. Id a -> Maybe ByteString
idKeyId Id PrivKey
iKey of
            Just ByteString
d  -> do
                -- locate a single certificate with same ID as private key
                -- and follow the issuers to get all certificates in the chain
                let filtered :: [SafeContents]
filtered = forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> SafeContents -> SafeContents
filterByLocalKeyId ByteString
d) [SafeContents]
l
                SignedCertificate
leaf <- forall a. [a] -> Maybe a
single ([SafeContents] -> [SignedCertificate]
getAllSafeX509Certs [SafeContents]
filtered)
                forall (f :: * -> *) a. Applicative f => a -> f a
pure (SignedCertificate -> [SignedCertificate] -> CertificateChain
buildCertificateChain SignedCertificate
leaf [SignedCertificate]
certs, PrivKey
k)
            Maybe ByteString
Nothing ->
                case forall a. Id a -> Maybe String
idName Id PrivKey
iKey of
                    Just String
name -> do
                        -- same but using friendly name of private key
                        let filtered :: [SafeContents]
filtered = forall a b. (a -> b) -> [a] -> [b]
map (String -> SafeContents -> SafeContents
filterByFriendlyName String
name) [SafeContents]
l
                        SignedCertificate
leaf <- forall a. [a] -> Maybe a
single ([SafeContents] -> [SignedCertificate]
getAllSafeX509Certs [SafeContents]
filtered)
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure (SignedCertificate -> [SignedCertificate] -> CertificateChain
buildCertificateChain SignedCertificate
leaf [SignedCertificate]
certs, PrivKey
k)
                    Maybe String
Nothing   -> do
                        -- no identifier available, so we simply return all
                        -- certificates with input order
                        forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SignedCertificate]
certs)
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure ([SignedCertificate] -> CertificateChain
X509.CertificateChain [SignedCertificate]
certs, PrivKey
k)

-- | Extract the private key and certificate chain from a 'PKCS12' value.  A
-- credential is returned when the structure contains exactly one private key
-- and at least one X.509 certificate.
toCredential :: PKCS12 -> OptProtected (Maybe (X509.CertificateChain, X509.PrivKey))
toCredential :: PKCS12 -> OptProtected (Maybe (CertificateChain, PrivKey))
toCredential PKCS12
p12 =
    forall a. SamePassword a -> OptProtected a
unSamePassword (forall a. OptProtected a -> SamePassword a
SamePassword (PKCS12 -> OptProtected [SafeContents]
unPKCS12 PKCS12
p12) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [SafeContents] -> SamePassword (Maybe (CertificateChain, PrivKey))
getInnerCredential)

getInnerCredentialNamed :: String -> [SafeContents] -> SamePassword (Maybe (X509.CertificateChain, X509.PrivKey))
getInnerCredentialNamed :: String
-> [SafeContents]
-> SamePassword (Maybe (CertificateChain, PrivKey))
getInnerCredentialNamed String
name [SafeContents]
l = forall a. OptProtected a -> SamePassword a
SamePassword ([PrivKey] -> Maybe (CertificateChain, PrivKey)
fn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SafeContents] -> OptProtected [PrivKey]
getAllSafeKeys [SafeContents]
filtered)
  where
    certs :: [SignedCertificate]
certs    = [SafeContents] -> [SignedCertificate]
getAllSafeX509Certs [SafeContents]
l
    filtered :: [SafeContents]
filtered = forall a b. (a -> b) -> [a] -> [b]
map (String -> SafeContents -> SafeContents
filterByFriendlyName String
name) [SafeContents]
l
    fn :: [PrivKey] -> Maybe (CertificateChain, PrivKey)
fn [PrivKey]
keys  = do
        PrivKey
k <- forall a. [a] -> Maybe a
single [PrivKey]
keys
        SignedCertificate
leaf <- forall a. [a] -> Maybe a
single ([SafeContents] -> [SignedCertificate]
getAllSafeX509Certs [SafeContents]
filtered)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (SignedCertificate -> [SignedCertificate] -> CertificateChain
buildCertificateChain SignedCertificate
leaf [SignedCertificate]
certs, PrivKey
k)

-- | Extract a private key and certificate chain with the specified friendly
-- name from a 'PKCS12' value.  A credential is returned when the structure
-- contains exactly one private key and one X.509 certificate with the name.
toNamedCredential :: String -> PKCS12 -> OptProtected (Maybe (X509.CertificateChain, X509.PrivKey))
toNamedCredential :: String
-> PKCS12 -> OptProtected (Maybe (CertificateChain, PrivKey))
toNamedCredential String
name PKCS12
p12 = forall a. SamePassword a -> OptProtected a
unSamePassword forall a b. (a -> b) -> a -> b
$
    forall a. OptProtected a -> SamePassword a
SamePassword (PKCS12 -> OptProtected [SafeContents]
unPKCS12 PKCS12
p12) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String
-> [SafeContents]
-> SamePassword (Maybe (CertificateChain, PrivKey))
getInnerCredentialNamed String
name

-- | Build a 'PKCS12' value containing a private key and certificate chain.
-- Distinct encryption is applied for both.  Encrypting the certificate chain is
-- optional.
--
-- Note: advice is to always generate fresh and independent 'EncryptionScheme'
-- values so that the salt is not reused twice in the encryption process.
fromCredential :: Maybe EncryptionScheme -- for certificates
               -> EncryptionScheme       -- for private key
               -> ProtectionPassword
               -> (X509.CertificateChain, X509.PrivKey)
               -> Either StoreError PKCS12
fromCredential :: Maybe EncryptionScheme
-> EncryptionScheme
-> ProtectionPassword
-> (CertificateChain, PrivKey)
-> Either StoreError PKCS12
fromCredential = ([Attribute] -> [Attribute])
-> Maybe EncryptionScheme
-> EncryptionScheme
-> ProtectionPassword
-> (CertificateChain, PrivKey)
-> Either StoreError PKCS12
fromCredential' forall a. a -> a
id

-- | Build a 'PKCS12' value containing a private key and certificate chain
-- identified with the specified friendly name.  Distinct encryption is applied
-- for private key and certificates.  Encrypting the certificate chain is
-- optional.
--
-- Note: advice is to always generate fresh and independent 'EncryptionScheme'
-- values so that the salt is not reused twice in the encryption process.
fromNamedCredential :: String
                    -> Maybe EncryptionScheme -- for certificates
                    -> EncryptionScheme       -- for private key
                    -> ProtectionPassword
                    -> (X509.CertificateChain, X509.PrivKey)
                    -> Either StoreError PKCS12
fromNamedCredential :: String
-> Maybe EncryptionScheme
-> EncryptionScheme
-> ProtectionPassword
-> (CertificateChain, PrivKey)
-> Either StoreError PKCS12
fromNamedCredential String
name = ([Attribute] -> [Attribute])
-> Maybe EncryptionScheme
-> EncryptionScheme
-> ProtectionPassword
-> (CertificateChain, PrivKey)
-> Either StoreError PKCS12
fromCredential' (String -> [Attribute] -> [Attribute]
setFriendlyName String
name)

fromCredential' :: ([Attribute] -> [Attribute])
                -> Maybe EncryptionScheme -- for certificates
                -> EncryptionScheme       -- for private key
                -> ProtectionPassword
                -> (X509.CertificateChain, X509.PrivKey)
                -> Either StoreError PKCS12
fromCredential' :: ([Attribute] -> [Attribute])
-> Maybe EncryptionScheme
-> EncryptionScheme
-> ProtectionPassword
-> (CertificateChain, PrivKey)
-> Either StoreError PKCS12
fromCredential' [Attribute] -> [Attribute]
trans Maybe EncryptionScheme
algChain EncryptionScheme
algKey ProtectionPassword
pwd (X509.CertificateChain [SignedCertificate]
certs, PrivKey
key)
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SignedCertificate]
certs = forall a b. a -> Either a b
Left (String -> StoreError
InvalidInput String
"Empty certificate chain")
    | Bool
otherwise  = forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either StoreError PKCS12
pkcs12Chain forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either StoreError PKCS12
pkcs12Key
  where
    pkcs12Key :: Either StoreError PKCS12
pkcs12Key   = SafeContents -> PKCS12
unencrypted forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either StoreError SafeContents
scKeyOrError
    pkcs12Chain :: Either StoreError PKCS12
pkcs12Chain =
        case Maybe EncryptionScheme
algChain of
            Just EncryptionScheme
alg -> EncryptionScheme
-> ProtectionPassword -> SafeContents -> Either StoreError PKCS12
encrypted EncryptionScheme
alg ProtectionPassword
pwd SafeContents
scChain
            Maybe EncryptionScheme
Nothing  -> forall a b. b -> Either a b
Right (SafeContents -> PKCS12
unencrypted SafeContents
scChain)

    scChain :: SafeContents
scChain       = [SafeBag] -> SafeContents
SafeContents (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [Attribute] -> SignedCertificate -> SafeBag
toCertBag [[Attribute]]
certAttrs [SignedCertificate]
certs)
    certAttrs :: [[Attribute]]
certAttrs     = [Attribute]
attrs forall a. a -> [a] -> [a]
: forall a. a -> [a]
repeat []
    toCertBag :: [Attribute] -> SignedCertificate -> SafeBag
toCertBag [Attribute]
a SignedCertificate
c = forall info. info -> [Attribute] -> Bag info
Bag (Bag CertInfo -> SafeInfo
CertBag (forall info. info -> [Attribute] -> Bag info
Bag (SignedCertificate -> CertInfo
CertX509 SignedCertificate
c) [])) [Attribute]
a

    scKeyOrError :: Either StoreError SafeContents
scKeyOrError = PKCS5 -> SafeContents
wrap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EncryptionScheme
-> ProtectionPassword -> ByteString -> Either StoreError PKCS5
encrypt EncryptionScheme
algKey ProtectionPassword
pwd ByteString
encodedKey

    wrap :: PKCS5 -> SafeContents
wrap PKCS5
shrouded = [SafeBag] -> SafeContents
SafeContents [forall info. info -> [Attribute] -> Bag info
Bag (PKCS5 -> SafeInfo
PKCS8ShroudedKeyBag PKCS5
shrouded) [Attribute]
attrs]
    encodedKey :: ByteString
encodedKey    = forall obj. ProduceASN1Object ASN1P obj => obj -> ByteString
encodeASN1Object (forall a. PrivateKeyFormat -> a -> FormattedKey a
FormattedKey PrivateKeyFormat
PKCS8Format PrivKey
key)

    X509.Fingerprint ByteString
keyId = forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> HashALG -> Fingerprint
X509.getFingerprint (forall a. [a] -> a
head [SignedCertificate]
certs) HashALG
X509.HashSHA1
    attrs :: [Attribute]
attrs = [Attribute] -> [Attribute]
trans (ByteString -> [Attribute] -> [Attribute]
setLocalKeyId ByteString
keyId [])

-- Standard attributes

friendlyName :: OID
friendlyName :: OID
friendlyName = [Integer
1,Integer
2,Integer
840,Integer
113549,Integer
1,Integer
9,Integer
20]

-- | Return the value of the @friendlyName@ attribute.
getFriendlyName :: [Attribute] -> Maybe String
getFriendlyName :: [Attribute] -> Maybe String
getFriendlyName [Attribute]
attrs = forall a. OID -> [Attribute] -> ParseASN1 () a -> Maybe a
runParseAttribute OID
friendlyName [Attribute]
attrs forall a b. (a -> b) -> a -> b
$ do
    ASN1String ASN1CharacterString
str <- forall e. Monoid e => ParseASN1 e ASN1
getNext
    case ASN1CharacterString -> Maybe String
asn1CharacterToString ASN1CharacterString
str of
        Maybe String
Nothing -> forall e a. String -> ParseASN1 e a
throwParseError String
"Invalid friendlyName value"
        Just String
s  -> forall (m :: * -> *) a. Monad m => a -> m a
return String
s

-- | Add or replace the @friendlyName@ attribute in a list of attributes.
setFriendlyName :: String -> [Attribute] -> [Attribute]
setFriendlyName :: String -> [Attribute] -> [Attribute]
setFriendlyName String
name = OID -> ASN1S -> [Attribute] -> [Attribute]
setAttributeASN1S OID
friendlyName (forall e. ASN1Elem e => String -> ASN1Stream e
gBMPString String
name)

localKeyId :: OID
localKeyId :: OID
localKeyId = [Integer
1,Integer
2,Integer
840,Integer
113549,Integer
1,Integer
9,Integer
21]

-- | Return the value of the @localKeyId@ attribute.
getLocalKeyId :: [Attribute] -> Maybe BS.ByteString
getLocalKeyId :: [Attribute] -> Maybe ByteString
getLocalKeyId [Attribute]
attrs = forall a. OID -> [Attribute] -> ParseASN1 () a -> Maybe a
runParseAttribute OID
localKeyId [Attribute]
attrs forall a b. (a -> b) -> a -> b
$ do
    OctetString ByteString
d <- forall e. Monoid e => ParseASN1 e ASN1
getNext
    forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
d

-- | Add or replace the @localKeyId@ attribute in a list of attributes.
setLocalKeyId :: BS.ByteString -> [Attribute] -> [Attribute]
setLocalKeyId :: ByteString -> [Attribute] -> [Attribute]
setLocalKeyId ByteString
d = OID -> ASN1S -> [Attribute] -> [Attribute]
setAttributeASN1S OID
localKeyId (forall e. ASN1Elem e => ByteString -> ASN1Stream e
gOctetString ByteString
d)


-- Utilities

-- Internal wrapper of OptProtected providing Applicative and Monad instances.
--
-- This adds the following constraint: all values composed must derive from the
-- same encryption password.  Semantically, 'Protected' actually means
-- "requiring a password".  Otherwise composition of 'Protected' and
-- 'Unprotected' values is unsound.
newtype SamePassword a = SamePassword { forall a. SamePassword a -> OptProtected a
unSamePassword :: OptProtected a }

instance Functor SamePassword where
    fmap :: forall a b. (a -> b) -> SamePassword a -> SamePassword b
fmap a -> b
f (SamePassword OptProtected a
opt) = forall a. OptProtected a -> SamePassword a
SamePassword (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f OptProtected a
opt)

instance Applicative SamePassword where
    pure :: forall a. a -> SamePassword a
pure a
a = forall a. OptProtected a -> SamePassword a
SamePassword (forall a. a -> OptProtected a
Unprotected a
a)

    SamePassword (Unprotected a -> b
f) <*> :: forall a b.
SamePassword (a -> b) -> SamePassword a -> SamePassword b
<*> SamePassword (Unprotected a
x) =
        forall a. OptProtected a -> SamePassword a
SamePassword (forall a. a -> OptProtected a
Unprotected (a -> b
f a
x))

    SamePassword (Unprotected a -> b
f) <*> SamePassword (Protected ProtectionPassword -> Either StoreError a
x) =
        forall a. OptProtected a -> SamePassword a
SamePassword forall a b. (a -> b) -> a -> b
$ forall a.
(ProtectionPassword -> Either StoreError a) -> OptProtected a
Protected (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtectionPassword -> Either StoreError a
x)

    SamePassword (Protected ProtectionPassword -> Either StoreError (a -> b)
f) <*> SamePassword (Unprotected a
x) =
        forall a. OptProtected a -> SamePassword a
SamePassword forall a b. (a -> b) -> a -> b
$ forall a.
(ProtectionPassword -> Either StoreError a) -> OptProtected a
Protected (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> a -> b
$ a
x) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtectionPassword -> Either StoreError (a -> b)
f)

    SamePassword (Protected ProtectionPassword -> Either StoreError (a -> b)
f) <*> SamePassword (Protected ProtectionPassword -> Either StoreError a
x) =
        forall a. OptProtected a -> SamePassword a
SamePassword forall a b. (a -> b) -> a -> b
$ forall a.
(ProtectionPassword -> Either StoreError a) -> OptProtected a
Protected (\ProtectionPassword
pwd -> ProtectionPassword -> Either StoreError (a -> b)
f ProtectionPassword
pwd forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ProtectionPassword -> Either StoreError a
x ProtectionPassword
pwd)

instance Monad SamePassword where
    return :: forall a. a -> SamePassword a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure

    SamePassword (Unprotected a
x)   >>= :: forall a b.
SamePassword a -> (a -> SamePassword b) -> SamePassword b
>>= a -> SamePassword b
f = a -> SamePassword b
f a
x
    SamePassword (Protected ProtectionPassword -> Either StoreError a
inner) >>= a -> SamePassword b
f =
        forall a. OptProtected a -> SamePassword a
SamePassword forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(ProtectionPassword -> Either StoreError a) -> OptProtected a
Protected forall a b. (a -> b) -> a -> b
$ \ProtectionPassword
pwd ->
            case ProtectionPassword -> Either StoreError a
inner ProtectionPassword
pwd of
                Left StoreError
err -> forall a b. a -> Either a b
Left StoreError
err
                Right a
x  -> forall a.
ProtectionPassword -> OptProtected a -> Either StoreError a
recover ProtectionPassword
pwd (forall a. SamePassword a -> OptProtected a
unSamePassword forall a b. (a -> b) -> a -> b
$ a -> SamePassword b
f a
x)

applySamePassword :: [OptProtected a] -> OptProtected [a]
applySamePassword :: forall a. [OptProtected a] -> OptProtected [a]
applySamePassword = forall a. SamePassword a -> OptProtected a
unSamePassword forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a. OptProtected a -> SamePassword a
SamePassword

single :: [a] -> Maybe a
single :: forall a. [a] -> Maybe a
single [a
x] = forall a. a -> Maybe a
Just a
x
single [a]
_   = forall a. Maybe a
Nothing

data Id a = Id
    { forall a. Id a -> a
unId    :: a
    , forall a. Id a -> Maybe ByteString
idKeyId :: Maybe BS.ByteString
    , forall a. Id a -> Maybe String
idName  :: Maybe String
    }

mkId :: a -> Bag info -> Id a
mkId :: forall a info. a -> Bag info -> Id a
mkId a
val Bag info
bag = a
val seq :: forall a b. a -> b -> b
`seq` forall a. a -> Maybe ByteString -> Maybe String -> Id a
Id a
val ([Attribute] -> Maybe ByteString
getLocalKeyId [Attribute]
attrs) ([Attribute] -> Maybe String
getFriendlyName [Attribute]
attrs)
  where attrs :: [Attribute]
attrs = forall info. Bag info -> [Attribute]
bagAttributes Bag info
bag

decode :: ParseASN1Object [ASN1Event] obj => BS.ByteString -> Either StoreError obj
decode :: forall obj.
ParseASN1Object [ASN1Event] obj =>
ByteString -> Either StoreError obj
decode = forall obj.
ParseASN1Object [ASN1Event] obj =>
ByteString -> Either StoreError obj
decodeASN1Object

parseOctetStringObject :: (Monoid e, ParseASN1Object [ASN1Event] obj)
                       => String -> ParseASN1 e obj
parseOctetStringObject :: forall e obj.
(Monoid e, ParseASN1Object [ASN1Event] obj) =>
String -> ParseASN1 e obj
parseOctetStringObject String
name = do
    ByteString
bs <- forall e. Monoid e => ParseASN1 e ByteString
parseOctetString
    case forall obj.
ParseASN1Object [ASN1Event] obj =>
ByteString -> Either StoreError obj
decode ByteString
bs of
        Left StoreError
e  -> forall e a. String -> ParseASN1 e a
throwParseError (String
name forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show StoreError
e)
        Right obj
c -> forall (m :: * -> *) a. Monad m => a -> m a
return obj
c

buildCertificateChain :: X509.SignedCertificate -> [X509.SignedCertificate]
                      -> X509.CertificateChain
buildCertificateChain :: SignedCertificate -> [SignedCertificate] -> CertificateChain
buildCertificateChain SignedCertificate
leaf [SignedCertificate]
authorities =
    [SignedCertificate] -> CertificateChain
X509.CertificateChain (SignedCertificate
leaf forall a. a -> [a] -> [a]
: SignedCertificate -> [SignedCertificate] -> [SignedCertificate]
findAuthorities SignedCertificate
leaf [SignedCertificate]
authorities)
  where
    findAuthorities :: SignedCertificate -> [SignedCertificate] -> [SignedCertificate]
findAuthorities SignedCertificate
cert [SignedCertificate]
others
        | SignedCertificate -> DistinguishedName
subject SignedCertificate
cert forall a. Eq a => a -> a -> Bool
== SignedCertificate -> DistinguishedName
issuer SignedCertificate
cert = []
        | Bool
otherwise                   =
            case forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\SignedCertificate
c -> SignedCertificate -> DistinguishedName
subject SignedCertificate
c forall a. Eq a => a -> a -> Bool
== SignedCertificate -> DistinguishedName
issuer SignedCertificate
cert) [SignedCertificate]
others of
                ([SignedCertificate
c], [SignedCertificate]
others') -> SignedCertificate
c forall a. a -> [a] -> [a]
: SignedCertificate -> [SignedCertificate] -> [SignedCertificate]
findAuthorities SignedCertificate
c [SignedCertificate]
others'
                ([SignedCertificate], [SignedCertificate])
_              -> []

    signedCert :: SignedCertificate -> Certificate
signedCert = forall a. (Show a, Eq a, ASN1Object a) => Signed a -> a
X509.signedObject forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Show a, Eq a, ASN1Object a) => SignedExact a -> Signed a
X509.getSigned

    subject :: SignedCertificate -> DistinguishedName
subject SignedCertificate
c = Certificate -> DistinguishedName
X509.certSubjectDN (SignedCertificate -> Certificate
signedCert SignedCertificate
c)
    issuer :: SignedCertificate -> DistinguishedName
issuer SignedCertificate
c  = Certificate -> DistinguishedName
X509.certIssuerDN (SignedCertificate -> Certificate
signedCert SignedCertificate
c)