-- |
-- Module      : Network.TLS.Credentials
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unknown
--
{-# LANGUAGE CPP #-}
module Network.TLS.Credentials
    ( Credential
    , Credentials(..)
    , credentialLoadX509
    , credentialLoadX509FromMemory
    , credentialLoadX509Chain
    , credentialLoadX509ChainFromMemory
    , credentialsFindForSigning
    , credentialsFindForDecrypting
    , credentialsListSigningAlgorithms
    , credentialPublicPrivateKeys
    , credentialMatchesHashSignatures
    ) where

import Network.TLS.Crypto
import Network.TLS.X509
import Network.TLS.Imports
import Data.X509.File
import Data.X509.Memory
import Data.X509

import qualified Data.X509             as X509
import qualified Network.TLS.Struct    as TLS

type Credential = (CertificateChain, PrivKey)

newtype Credentials = Credentials [Credential] deriving (Int -> Credentials -> ShowS
[Credentials] -> ShowS
Credentials -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Credentials] -> ShowS
$cshowList :: [Credentials] -> ShowS
show :: Credentials -> String
$cshow :: Credentials -> String
showsPrec :: Int -> Credentials -> ShowS
$cshowsPrec :: Int -> Credentials -> ShowS
Show)

instance Semigroup Credentials where
    Credentials [Credential]
l1 <> :: Credentials -> Credentials -> Credentials
<> Credentials [Credential]
l2 = [Credential] -> Credentials
Credentials ([Credential]
l1 forall a. [a] -> [a] -> [a]
++ [Credential]
l2)

instance Monoid Credentials where
    mempty :: Credentials
mempty = [Credential] -> Credentials
Credentials []
#if !(MIN_VERSION_base(4,11,0))
    mappend (Credentials l1) (Credentials l2) = Credentials (l1 ++ l2)
#endif

-- | try to create a new credential object from a public certificate
-- and the associated private key that are stored on the filesystem
-- in PEM format.
credentialLoadX509 :: FilePath -- ^ public certificate (X.509 format)
                   -> FilePath -- ^ private key associated
                   -> IO (Either String Credential)
credentialLoadX509 :: String -> String -> IO (Either String Credential)
credentialLoadX509 String
certFile = String -> [String] -> String -> IO (Either String Credential)
credentialLoadX509Chain String
certFile []

-- | similar to 'credentialLoadX509' but take the certificate
-- and private key from memory instead of from the filesystem.
credentialLoadX509FromMemory :: ByteString
                  -> ByteString
                  -> Either String Credential
credentialLoadX509FromMemory :: ByteString -> ByteString -> Either String Credential
credentialLoadX509FromMemory ByteString
certData =
  ByteString
-> [ByteString] -> ByteString -> Either String Credential
credentialLoadX509ChainFromMemory ByteString
certData []

-- | similar to 'credentialLoadX509' but also allow specifying chain
-- certificates.
credentialLoadX509Chain ::
                      FilePath   -- ^ public certificate (X.509 format)
                   -> [FilePath] -- ^ chain certificates (X.509 format)
                   -> FilePath   -- ^ private key associated
                   -> IO (Either String Credential)
credentialLoadX509Chain :: String -> [String] -> String -> IO (Either String Credential)
credentialLoadX509Chain String
certFile [String]
chainFiles String
privateFile = do
    [SignedExact Certificate]
x509 <- forall a.
(ASN1Object a, Eq a, Show a) =>
String -> IO [SignedExact a]
readSignedObject String
certFile
    [[SignedExact Certificate]]
chains <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a.
(ASN1Object a, Eq a, Show a) =>
String -> IO [SignedExact a]
readSignedObject [String]
chainFiles
    [PrivKey]
keys <- String -> IO [PrivKey]
readKeyFile String
privateFile
    case [PrivKey]
keys of
        []    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
"no keys found"
        (PrivKey
k:[PrivKey]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ([SignedExact Certificate] -> CertificateChain
CertificateChain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ [SignedExact Certificate]
x509 forall a. a -> [a] -> [a]
: [[SignedExact Certificate]]
chains, PrivKey
k)

-- | similar to 'credentialLoadX509FromMemory' but also allow
-- specifying chain certificates.
credentialLoadX509ChainFromMemory :: ByteString
                  -> [ByteString]
                  -> ByteString
                  -> Either String Credential
credentialLoadX509ChainFromMemory :: ByteString
-> [ByteString] -> ByteString -> Either String Credential
credentialLoadX509ChainFromMemory ByteString
certData [ByteString]
chainData ByteString
privateData =
    let x509 :: [SignedExact Certificate]
x509   = forall a.
(ASN1Object a, Eq a, Show a) =>
ByteString -> [SignedExact a]
readSignedObjectFromMemory ByteString
certData
        chains :: [[SignedExact Certificate]]
chains = forall a b. (a -> b) -> [a] -> [b]
map forall a.
(ASN1Object a, Eq a, Show a) =>
ByteString -> [SignedExact a]
readSignedObjectFromMemory [ByteString]
chainData
        keys :: [PrivKey]
keys   = ByteString -> [PrivKey]
readKeyFileFromMemory ByteString
privateData
     in case [PrivKey]
keys of
            []    -> forall a b. a -> Either a b
Left String
"no keys found"
            (PrivKey
k:[PrivKey]
_) -> forall a b. b -> Either a b
Right ([SignedExact Certificate] -> CertificateChain
CertificateChain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ [SignedExact Certificate]
x509 forall a. a -> [a] -> [a]
: [[SignedExact Certificate]]
chains, PrivKey
k)

credentialsListSigningAlgorithms :: Credentials -> [KeyExchangeSignatureAlg]
credentialsListSigningAlgorithms :: Credentials -> [KeyExchangeSignatureAlg]
credentialsListSigningAlgorithms (Credentials [Credential]
l) = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Credential -> Maybe KeyExchangeSignatureAlg
credentialCanSign [Credential]
l

credentialsFindForSigning :: KeyExchangeSignatureAlg -> Credentials -> Maybe Credential
credentialsFindForSigning :: KeyExchangeSignatureAlg -> Credentials -> Maybe Credential
credentialsFindForSigning KeyExchangeSignatureAlg
kxsAlg (Credentials [Credential]
l) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Credential -> Bool
forSigning [Credential]
l
  where forSigning :: Credential -> Bool
forSigning Credential
cred = case Credential -> Maybe KeyExchangeSignatureAlg
credentialCanSign Credential
cred of
            Maybe KeyExchangeSignatureAlg
Nothing  -> Bool
False
            Just KeyExchangeSignatureAlg
kxs -> KeyExchangeSignatureAlg
kxs forall a. Eq a => a -> a -> Bool
== KeyExchangeSignatureAlg
kxsAlg

credentialsFindForDecrypting :: Credentials -> Maybe Credential
credentialsFindForDecrypting :: Credentials -> Maybe Credential
credentialsFindForDecrypting (Credentials [Credential]
l) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Credential -> Bool
forEncrypting [Credential]
l
  where forEncrypting :: Credential -> Bool
forEncrypting Credential
cred = forall a. a -> Maybe a
Just () forall a. Eq a => a -> a -> Bool
== Credential -> Maybe ()
credentialCanDecrypt Credential
cred

-- here we assume that only RSA is supported for key encipherment (encryption/decryption)
-- we keep the same construction as 'credentialCanSign', returning a Maybe of () in case
-- this change in future.
credentialCanDecrypt :: Credential -> Maybe ()
credentialCanDecrypt :: Credential -> Maybe ()
credentialCanDecrypt (CertificateChain
chain, PrivKey
priv) =
    case (PubKey
pub, PrivKey
priv) of
        (PubKeyRSA PublicKey
_, PrivKeyRSA PrivateKey
_) ->
            case forall a. Extension a => Extensions -> Maybe a
extensionGet (Certificate -> Extensions
certExtensions Certificate
cert) of
                Maybe ExtKeyUsage
Nothing                                     -> forall a. a -> Maybe a
Just ()
                Just (ExtKeyUsage [ExtKeyUsageFlag]
flags)
                    | ExtKeyUsageFlag
KeyUsage_keyEncipherment forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ExtKeyUsageFlag]
flags -> forall a. a -> Maybe a
Just ()
                    | Bool
otherwise                             -> forall a. Maybe a
Nothing
        (PubKey, PrivKey)
_                           -> forall a. Maybe a
Nothing
    where cert :: Certificate
cert   = SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
signed
          pub :: PubKey
pub    = Certificate -> PubKey
certPubKey Certificate
cert
          signed :: SignedExact Certificate
signed = CertificateChain -> SignedExact Certificate
getCertificateChainLeaf CertificateChain
chain

credentialCanSign :: Credential -> Maybe KeyExchangeSignatureAlg
credentialCanSign :: Credential -> Maybe KeyExchangeSignatureAlg
credentialCanSign (CertificateChain
chain, PrivKey
priv) =
    case forall a. Extension a => Extensions -> Maybe a
extensionGet (Certificate -> Extensions
certExtensions Certificate
cert) of
        Maybe ExtKeyUsage
Nothing    -> (PubKey, PrivKey) -> Maybe KeyExchangeSignatureAlg
findKeyExchangeSignatureAlg (PubKey
pub, PrivKey
priv)
        Just (ExtKeyUsage [ExtKeyUsageFlag]
flags)
            | ExtKeyUsageFlag
KeyUsage_digitalSignature forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ExtKeyUsageFlag]
flags -> (PubKey, PrivKey) -> Maybe KeyExchangeSignatureAlg
findKeyExchangeSignatureAlg (PubKey
pub, PrivKey
priv)
            | Bool
otherwise                              -> forall a. Maybe a
Nothing
    where cert :: Certificate
cert   = SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
signed
          pub :: PubKey
pub    = Certificate -> PubKey
certPubKey Certificate
cert
          signed :: SignedExact Certificate
signed = CertificateChain -> SignedExact Certificate
getCertificateChainLeaf CertificateChain
chain

credentialPublicPrivateKeys :: Credential -> (PubKey, PrivKey)
credentialPublicPrivateKeys :: Credential -> (PubKey, PrivKey)
credentialPublicPrivateKeys (CertificateChain
chain, PrivKey
priv) = PubKey
pub seq :: forall a b. a -> b -> b
`seq` (PubKey
pub, PrivKey
priv)
    where cert :: Certificate
cert   = SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
signed
          pub :: PubKey
pub    = Certificate -> PubKey
certPubKey Certificate
cert
          signed :: SignedExact Certificate
signed = CertificateChain -> SignedExact Certificate
getCertificateChainLeaf CertificateChain
chain

getHashSignature :: SignedCertificate -> Maybe TLS.HashAndSignatureAlgorithm
getHashSignature :: SignedExact Certificate -> Maybe HashAndSignatureAlgorithm
getHashSignature SignedExact Certificate
signed =
    case forall a. (Show a, Eq a, ASN1Object a) => Signed a -> SignatureALG
signedAlg forall a b. (a -> b) -> a -> b
$ forall a. (Show a, Eq a, ASN1Object a) => SignedExact a -> Signed a
getSigned SignedExact Certificate
signed of
        SignatureALG HashALG
hashAlg PubKeyALG
PubKeyALG_RSA    -> forall {b}. b -> HashALG -> Maybe (HashAlgorithm, b)
convertHash SignatureAlgorithm
TLS.SignatureRSA   HashALG
hashAlg
        SignatureALG HashALG
hashAlg PubKeyALG
PubKeyALG_DSA    -> forall {b}. b -> HashALG -> Maybe (HashAlgorithm, b)
convertHash SignatureAlgorithm
TLS.SignatureDSS   HashALG
hashAlg
        SignatureALG HashALG
hashAlg PubKeyALG
PubKeyALG_EC     -> forall {b}. b -> HashALG -> Maybe (HashAlgorithm, b)
convertHash SignatureAlgorithm
TLS.SignatureECDSA HashALG
hashAlg

        SignatureALG HashALG
X509.HashSHA256 PubKeyALG
PubKeyALG_RSAPSS -> forall a. a -> Maybe a
Just (HashAlgorithm
TLS.HashIntrinsic, SignatureAlgorithm
TLS.SignatureRSApssRSAeSHA256)
        SignatureALG HashALG
X509.HashSHA384 PubKeyALG
PubKeyALG_RSAPSS -> forall a. a -> Maybe a
Just (HashAlgorithm
TLS.HashIntrinsic, SignatureAlgorithm
TLS.SignatureRSApssRSAeSHA384)
        SignatureALG HashALG
X509.HashSHA512 PubKeyALG
PubKeyALG_RSAPSS -> forall a. a -> Maybe a
Just (HashAlgorithm
TLS.HashIntrinsic, SignatureAlgorithm
TLS.SignatureRSApssRSAeSHA512)

        SignatureALG_IntrinsicHash PubKeyALG
PubKeyALG_Ed25519  -> forall a. a -> Maybe a
Just (HashAlgorithm
TLS.HashIntrinsic, SignatureAlgorithm
TLS.SignatureEd25519)
        SignatureALG_IntrinsicHash PubKeyALG
PubKeyALG_Ed448    -> forall a. a -> Maybe a
Just (HashAlgorithm
TLS.HashIntrinsic, SignatureAlgorithm
TLS.SignatureEd448)

        SignatureALG
_                                     -> forall a. Maybe a
Nothing
  where
    convertHash :: b -> HashALG -> Maybe (HashAlgorithm, b)
convertHash b
sig HashALG
X509.HashMD5    = forall a. a -> Maybe a
Just (HashAlgorithm
TLS.HashMD5   , b
sig)
    convertHash b
sig HashALG
X509.HashSHA1   = forall a. a -> Maybe a
Just (HashAlgorithm
TLS.HashSHA1  , b
sig)
    convertHash b
sig HashALG
X509.HashSHA224 = forall a. a -> Maybe a
Just (HashAlgorithm
TLS.HashSHA224, b
sig)
    convertHash b
sig HashALG
X509.HashSHA256 = forall a. a -> Maybe a
Just (HashAlgorithm
TLS.HashSHA256, b
sig)
    convertHash b
sig HashALG
X509.HashSHA384 = forall a. a -> Maybe a
Just (HashAlgorithm
TLS.HashSHA384, b
sig)
    convertHash b
sig HashALG
X509.HashSHA512 = forall a. a -> Maybe a
Just (HashAlgorithm
TLS.HashSHA512, b
sig)
    convertHash b
_   HashALG
_               = forall a. Maybe a
Nothing

-- | Checks whether certificate signatures in the chain comply with a list of
-- hash/signature algorithm pairs.  Currently the verification applies only to
-- the signature of the leaf certificate, and when not self-signed.  This may
-- be extended to additional chain elements in the future.
credentialMatchesHashSignatures :: [TLS.HashAndSignatureAlgorithm] -> Credential -> Bool
credentialMatchesHashSignatures :: [HashAndSignatureAlgorithm] -> Credential -> Bool
credentialMatchesHashSignatures [HashAndSignatureAlgorithm]
hashSigs (CertificateChain
chain, PrivKey
_) =
    case CertificateChain
chain of
        CertificateChain []       -> Bool
True
        CertificateChain (SignedExact Certificate
leaf:[SignedExact Certificate]
_) -> SignedExact Certificate -> Bool
isSelfSigned SignedExact Certificate
leaf Bool -> Bool -> Bool
|| SignedExact Certificate -> Bool
matchHashSig SignedExact Certificate
leaf
  where
    matchHashSig :: SignedExact Certificate -> Bool
matchHashSig SignedExact Certificate
signed = case SignedExact Certificate -> Maybe HashAndSignatureAlgorithm
getHashSignature SignedExact Certificate
signed of
                              Maybe HashAndSignatureAlgorithm
Nothing -> Bool
False
                              Just HashAndSignatureAlgorithm
hs -> HashAndSignatureAlgorithm
hs forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [HashAndSignatureAlgorithm]
hashSigs

    isSelfSigned :: SignedExact Certificate -> Bool
isSelfSigned SignedExact Certificate
signed =
        let cert :: Certificate
cert = SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
signed
         in Certificate -> DistinguishedName
certSubjectDN Certificate
cert forall a. Eq a => a -> a -> Bool
== Certificate -> DistinguishedName
certIssuerDN Certificate
cert