1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
|
-- | X509 helpers
module Network.TLS.X509 (
CertificateChain (..),
Certificate (..),
SignedCertificate,
getCertificate,
isNullCertificateChain,
getCertificateChainLeaf,
CertificateRejectReason (..),
CertificateUsage (..),
CertificateStore,
ValidationCache,
defaultValidationCache,
exceptionValidationCache,
validateDefault,
FailedReason,
ServiceID,
wrapCertificateChecks,
pubkeyType,
validateClientCertificate,
) where
import Data.X509
import Data.X509.CertificateStore
import Data.X509.Validation
isNullCertificateChain :: CertificateChain -> Bool
isNullCertificateChain (CertificateChain l) = null l
getCertificateChainLeaf :: CertificateChain -> SignedExact Certificate
getCertificateChainLeaf (CertificateChain []) = error "empty certificate chain"
getCertificateChainLeaf (CertificateChain (x : _)) = x
-- | Certificate and Chain rejection reason
data CertificateRejectReason
= CertificateRejectExpired
| CertificateRejectRevoked
| CertificateRejectUnknownCA
| CertificateRejectAbsent
| CertificateRejectOther String
deriving (Show, Eq)
-- | Certificate Usage callback possible returns values.
data CertificateUsage
= -- | usage of certificate accepted
CertificateUsageAccept
| -- | usage of certificate rejected
CertificateUsageReject CertificateRejectReason
deriving (Show, Eq)
wrapCertificateChecks :: [FailedReason] -> CertificateUsage
wrapCertificateChecks [] = CertificateUsageAccept
wrapCertificateChecks l
| Expired `elem` l = CertificateUsageReject CertificateRejectExpired
| InFuture `elem` l = CertificateUsageReject CertificateRejectExpired
| UnknownCA `elem` l = CertificateUsageReject CertificateRejectUnknownCA
| SelfSigned `elem` l = CertificateUsageReject CertificateRejectUnknownCA
| EmptyChain `elem` l = CertificateUsageReject CertificateRejectAbsent
| otherwise = CertificateUsageReject $ CertificateRejectOther (show l)
pubkeyType :: PubKey -> String
pubkeyType = show . pubkeyToAlg
-- | A utility function for client authentication which can be used
-- `onClientCertificate`.
--
-- Since: 2.1.7
validateClientCertificate
:: CertificateStore
-> ValidationCache
-> CertificateChain
-> IO CertificateUsage
validateClientCertificate store cache cc =
wrapCertificateChecks
<$> validate
HashSHA256
defaultHooks
defaultChecks{checkFQHN = False}
store
cache
("", mempty)
cc
|
