{-# 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
credentialLoadX509 :: FilePath
-> FilePath
-> IO (Either String Credential)
credentialLoadX509 :: String -> String -> IO (Either String Credential)
credentialLoadX509 String
certFile = String -> [String] -> String -> IO (Either String Credential)
credentialLoadX509Chain String
certFile []
credentialLoadX509FromMemory :: ByteString
-> ByteString
-> Either String Credential
credentialLoadX509FromMemory :: ByteString -> ByteString -> Either String Credential
credentialLoadX509FromMemory ByteString
certData =
ByteString
-> [ByteString] -> ByteString -> Either String Credential
credentialLoadX509ChainFromMemory ByteString
certData []
credentialLoadX509Chain ::
FilePath
-> [FilePath]
-> FilePath
-> 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)
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
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
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