1-- |
2-- Module      : Network.TLS.Handshake.Certificate
3-- License     : BSD-style
4-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
5-- Stability   : experimental
6-- Portability : unknown
7--
8module Network.TLS.Handshake.Certificate
9    ( certificateRejected
10    , badCertificate
11    , rejectOnException
12    , verifyLeafKeyUsage
13    , extractCAname
14    ) where
15
16import Network.TLS.Context.Internal
17import Network.TLS.Struct
18import Network.TLS.X509
19import Control.Monad.State.Strict
20import Control.Exception (SomeException)
21import Data.X509 (ExtKeyUsage(..), ExtKeyUsageFlag, extensionGet)
22
23-- on certificate reject, throw an exception with the proper protocol alert error.
24certificateRejected :: MonadIO m => CertificateRejectReason -> m a
25certificateRejected CertificateRejectRevoked =
26    throwCore $ Error_Protocol ("certificate is revoked", True, CertificateRevoked)
27certificateRejected CertificateRejectExpired =
28    throwCore $ Error_Protocol ("certificate has expired", True, CertificateExpired)
29certificateRejected CertificateRejectUnknownCA =
30    throwCore $ Error_Protocol ("certificate has unknown CA", True, UnknownCa)
31certificateRejected CertificateRejectAbsent =
32    throwCore $ Error_Protocol ("certificate is missing", True, CertificateRequired)
33certificateRejected (CertificateRejectOther s) =
34    throwCore $ Error_Protocol ("certificate rejected: " ++ s, True, CertificateUnknown)
35
36badCertificate :: MonadIO m => String -> m a
37badCertificate msg = throwCore $ Error_Protocol (msg, True, BadCertificate)
38
39rejectOnException :: SomeException -> IO CertificateUsage
40rejectOnException e = return $ CertificateUsageReject $ CertificateRejectOther $ show e
41
42verifyLeafKeyUsage :: MonadIO m => [ExtKeyUsageFlag] -> CertificateChain -> m ()
43verifyLeafKeyUsage _          (CertificateChain [])         = return ()
44verifyLeafKeyUsage validFlags (CertificateChain (signed:_)) =
45    unless verified $ badCertificate $
46        "certificate is not allowed for any of " ++ show validFlags
47  where
48    cert     = getCertificate signed
49    verified =
50        case extensionGet (certExtensions cert) of
51            Nothing                          -> True -- unrestricted cert
52            Just (ExtKeyUsage flags)         -> any (`elem` validFlags) flags
53
54extractCAname :: SignedCertificate -> DistinguishedName
55extractCAname cert = certSubjectDN $ getCertificate cert
56