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