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)
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, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"certificate is revoked", Bool
True, AlertDescription
CertificateRevoked)
certificateRejected CertificateRejectReason
CertificateRejectExpired =
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"certificate has expired", Bool
True, AlertDescription
CertificateExpired)
certificateRejected CertificateRejectReason
CertificateRejectUnknownCA =
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"certificate has unknown CA", Bool
True, AlertDescription
UnknownCa)
certificateRejected CertificateRejectReason
CertificateRejectAbsent =
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"certificate is missing", Bool
True, AlertDescription
CertificateRequired)
certificateRejected (CertificateRejectOther String
s) =
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"certificate rejected: " forall a. [a] -> [a] -> [a]
++ String
s, Bool
True, 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, Bool, AlertDescription) -> TLSError
Error_Protocol (String
msg, Bool
True, 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
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
SignedExact Certificate
cert = Certificate -> DistinguishedName
certSubjectDN forall a b. (a -> b) -> a -> b
$ SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
cert