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
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
|
-- |
-- Module : Data.X509.Validation.Cache
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unknown
--
-- X.509 Validation cache
--
-- Define all the types necessary for the validation cache,
-- and some simples instances of cache mechanism
module Data.X509.Validation.Cache
(
-- * Cache for validation
ValidationCacheResult(..)
, ValidationCacheQueryCallback
, ValidationCacheAddCallback
, ValidationCache(..)
-- * Simple instances of cache mechanism
, exceptionValidationCache
, tofuValidationCache
) where
import Control.Concurrent
import Data.Default.Class
import Data.X509
import Data.X509.Validation.Types
import Data.X509.Validation.Fingerprint
-- | The result of a cache query
data ValidationCacheResult =
ValidationCachePass -- ^ cache allow this fingerprint to go through
| ValidationCacheDenied String -- ^ cache denied this fingerprint for further validation
| ValidationCacheUnknown -- ^ unknown fingerprint in cache
deriving (Show,Eq)
-- | Validation cache query callback type
type ValidationCacheQueryCallback = ServiceID -- ^ connection's identification
-> Fingerprint -- ^ fingerprint of the leaf certificate
-> Certificate -- ^ leaf certificate
-> IO ValidationCacheResult -- ^ return if the operation is succesful or not
-- | Validation cache callback type
type ValidationCacheAddCallback = ServiceID -- ^ connection's identification
-> Fingerprint -- ^ fingerprint of the leaf certificate
-> Certificate -- ^ leaf certificate
-> IO ()
-- | All the callbacks needed for querying and adding to the cache.
data ValidationCache = ValidationCache
{ cacheQuery :: ValidationCacheQueryCallback -- ^ cache querying callback
, cacheAdd :: ValidationCacheAddCallback -- ^ cache adding callback
}
instance Default ValidationCache where
def = exceptionValidationCache []
-- | create a simple constant cache that list exceptions to the certification
-- validation. Typically this is use to allow self-signed certificates for
-- specific use, with out-of-bounds user checks.
--
-- No fingerprints will be added after the instance is created.
--
-- The underlying structure for the check is kept as a list, as
-- usually the exception list will be short, but when the list go above
-- a dozen exceptions it's recommended to use another cache mechanism with
-- a faster lookup mechanism (hashtable, map, etc).
--
-- Note that only one fingerprint is allowed per ServiceID, for other use,
-- another cache mechanism need to be use.
exceptionValidationCache :: [(ServiceID, Fingerprint)] -> ValidationCache
exceptionValidationCache fingerprints =
ValidationCache (queryListCallback fingerprints)
(\_ _ _ -> return ())
-- | Trust on first use (TOFU) cache with an optional list of exceptions
--
-- this is similar to the exceptionCache, except that after
-- each succesfull validation it does add the fingerprint
-- to the database. This prevent any further modification of the
-- fingerprint for the remaining
tofuValidationCache :: [(ServiceID, Fingerprint)] -- ^ a list of exceptions
-> IO ValidationCache
tofuValidationCache fingerprints = do
l <- newMVar fingerprints
return $ ValidationCache (\s f c -> readMVar l >>= \list -> (queryListCallback list) s f c)
(\s f _ -> modifyMVar_ l (\list -> return ((s,f) : list)))
-- | a cache query function working on list.
-- don't use when the list grows a lot.
queryListCallback :: [(ServiceID, Fingerprint)] -> ValidationCacheQueryCallback
queryListCallback list = query
where query serviceID fingerprint _ = return $
case lookup serviceID list of
Nothing -> ValidationCacheUnknown
Just f | fingerprint == f -> ValidationCachePass
| otherwise -> ValidationCacheDenied (show serviceID ++ " expected " ++ show f ++ " but got: " ++ show fingerprint)
|
