-- |
-- Module      : Network.TLS.Handshake.Certificate
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unknown
--
module Network.TLS.Handshake.Certificate
    ( certificateRejected
    , badCertificate
    , rejectOnException
    , verifyLeafKeyUsage
    , extractCAname
    ) where

import Network.TLS.Context.Internal
import Network.TLS.Struct
import Network.TLS.X509
import Control.Monad (unless)
import Control.Monad.State.Strict
import Control.Exception (SomeException)
import Data.X509 (ExtKeyUsage(..), ExtKeyUsageFlag, extensionGet)

-- on certificate reject, throw an exception with the proper protocol alert error.
certificateRejected :: MonadIO m => CertificateRejectReason -> m a
certificateRejected :: forall (m :: * -> *) a. MonadIO m => CertificateRejectReason -> m a
certificateRejected CertificateRejectReason
CertificateRejectRevoked =
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ String -> AlertDescription -> TLSError
Error_Protocol String
"certificate is revoked" AlertDescription
CertificateRevoked
certificateRejected CertificateRejectReason
CertificateRejectExpired =
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ String -> AlertDescription -> TLSError
Error_Protocol String
"certificate has expired" AlertDescription
CertificateExpired
certificateRejected CertificateRejectReason
CertificateRejectUnknownCA =
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ String -> AlertDescription -> TLSError
Error_Protocol String
"certificate has unknown CA" AlertDescription
UnknownCa
certificateRejected CertificateRejectReason
CertificateRejectAbsent =
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ String -> AlertDescription -> TLSError
Error_Protocol String
"certificate is missing" AlertDescription
CertificateRequired
certificateRejected (CertificateRejectOther String
s) =
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ String -> AlertDescription -> TLSError
Error_Protocol (String
"certificate rejected: " forall a. [a] -> [a] -> [a]
++ String
s) AlertDescription
CertificateUnknown

badCertificate :: MonadIO m => String -> m a
badCertificate :: forall (m :: * -> *) a. MonadIO m => String -> m a
badCertificate String
msg = forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ String -> AlertDescription -> TLSError
Error_Protocol String
msg AlertDescription
BadCertificate

rejectOnException :: SomeException -> IO CertificateUsage
rejectOnException :: SomeException -> IO CertificateUsage
rejectOnException SomeException
e = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CertificateRejectReason -> CertificateUsage
CertificateUsageReject forall a b. (a -> b) -> a -> b
$ String -> CertificateRejectReason
CertificateRejectOther forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show SomeException
e

verifyLeafKeyUsage :: MonadIO m => [ExtKeyUsageFlag] -> CertificateChain -> m ()
verifyLeafKeyUsage :: forall (m :: * -> *).
MonadIO m =>
[ExtKeyUsageFlag] -> CertificateChain -> m ()
verifyLeafKeyUsage [ExtKeyUsageFlag]
_          (CertificateChain [])         = forall (m :: * -> *) a. Monad m => a -> m a
return ()
verifyLeafKeyUsage [ExtKeyUsageFlag]
validFlags (CertificateChain (SignedExact Certificate
signed:[SignedExact Certificate]
_)) =
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
verified forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => String -> m a
badCertificate forall a b. (a -> b) -> a -> b
$
        String
"certificate is not allowed for any of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [ExtKeyUsageFlag]
validFlags
  where
    cert :: Certificate
cert     = SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
signed
    verified :: Bool
verified =
        case forall a. Extension a => Extensions -> Maybe a
extensionGet (Certificate -> Extensions
certExtensions Certificate
cert) of
            Maybe ExtKeyUsage
Nothing                          -> Bool
True -- unrestricted cert
            Just (ExtKeyUsage [ExtKeyUsageFlag]
flags)         -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ExtKeyUsageFlag]
validFlags) [ExtKeyUsageFlag]
flags

extractCAname :: SignedCertificate -> DistinguishedName
extractCAname :: SignedExact Certificate -> DistinguishedName
extractCAname SignedExact Certificate
cert = Certificate -> DistinguishedName
certSubjectDN forall a b. (a -> b) -> a -> b
$ SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
cert