-- |
-- 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 (..),
    defaultValidationCache,

    -- * Simple instances of cache mechanism
    exceptionValidationCache,
    tofuValidationCache,
) where

import Control.Concurrent
import Data.Default
import Data.X509
import Data.X509.Validation.Fingerprint
import Data.X509.Validation.Types

-- | The result of a cache query
data ValidationCacheResult
    = -- | cache allow this fingerprint to go through
      ValidationCachePass
    | -- | cache denied this fingerprint for further validation
      ValidationCacheDenied String
    | -- | unknown fingerprint in cache
      ValidationCacheUnknown
    deriving (Int -> ValidationCacheResult -> ShowS
[ValidationCacheResult] -> ShowS
ValidationCacheResult -> String
(Int -> ValidationCacheResult -> ShowS)
-> (ValidationCacheResult -> String)
-> ([ValidationCacheResult] -> ShowS)
-> Show ValidationCacheResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValidationCacheResult -> ShowS
showsPrec :: Int -> ValidationCacheResult -> ShowS
$cshow :: ValidationCacheResult -> String
show :: ValidationCacheResult -> String
$cshowList :: [ValidationCacheResult] -> ShowS
showList :: [ValidationCacheResult] -> ShowS
Show, ValidationCacheResult -> ValidationCacheResult -> Bool
(ValidationCacheResult -> ValidationCacheResult -> Bool)
-> (ValidationCacheResult -> ValidationCacheResult -> Bool)
-> Eq ValidationCacheResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ValidationCacheResult -> ValidationCacheResult -> Bool
== :: ValidationCacheResult -> ValidationCacheResult -> Bool
$c/= :: ValidationCacheResult -> ValidationCacheResult -> Bool
/= :: ValidationCacheResult -> ValidationCacheResult -> Bool
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
    { ValidationCache -> ValidationCacheQueryCallback
cacheQuery :: ValidationCacheQueryCallback
    -- ^ cache querying callback
    , ValidationCache -> ValidationCacheAddCallback
cacheAdd :: ValidationCacheAddCallback
    -- ^ cache adding callback
    }

defaultValidationCache :: ValidationCache
defaultValidationCache :: ValidationCache
defaultValidationCache = [(ServiceID, Fingerprint)] -> ValidationCache
exceptionValidationCache []

instance Default ValidationCache where
    def :: ValidationCache
def = ValidationCache
defaultValidationCache

-- | 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 :: [(ServiceID, Fingerprint)] -> ValidationCache
exceptionValidationCache [(ServiceID, Fingerprint)]
fingerprints =
    ValidationCacheQueryCallback
-> ValidationCacheAddCallback -> ValidationCache
ValidationCache
        ([(ServiceID, Fingerprint)] -> ValidationCacheQueryCallback
queryListCallback [(ServiceID, Fingerprint)]
fingerprints)
        (\ServiceID
_ Fingerprint
_ Certificate
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
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 :: [(ServiceID, Fingerprint)] -> IO ValidationCache
tofuValidationCache [(ServiceID, Fingerprint)]
fingerprints = do
    MVar [(ServiceID, Fingerprint)]
l <- [(ServiceID, Fingerprint)] -> IO (MVar [(ServiceID, Fingerprint)])
forall a. a -> IO (MVar a)
newMVar [(ServiceID, Fingerprint)]
fingerprints
    ValidationCache -> IO ValidationCache
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidationCache -> IO ValidationCache)
-> ValidationCache -> IO ValidationCache
forall a b. (a -> b) -> a -> b
$
        ValidationCacheQueryCallback
-> ValidationCacheAddCallback -> ValidationCache
ValidationCache
            (\ServiceID
s Fingerprint
f Certificate
c -> MVar [(ServiceID, Fingerprint)] -> IO [(ServiceID, Fingerprint)]
forall a. MVar a -> IO a
readMVar MVar [(ServiceID, Fingerprint)]
l IO [(ServiceID, Fingerprint)]
-> ([(ServiceID, Fingerprint)] -> IO ValidationCacheResult)
-> IO ValidationCacheResult
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[(ServiceID, Fingerprint)]
list -> ([(ServiceID, Fingerprint)] -> ValidationCacheQueryCallback
queryListCallback [(ServiceID, Fingerprint)]
list) ServiceID
s Fingerprint
f Certificate
c)
            (\ServiceID
s Fingerprint
f Certificate
_ -> MVar [(ServiceID, Fingerprint)]
-> ([(ServiceID, Fingerprint)] -> IO [(ServiceID, Fingerprint)])
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar [(ServiceID, Fingerprint)]
l (\[(ServiceID, Fingerprint)]
list -> [(ServiceID, Fingerprint)] -> IO [(ServiceID, Fingerprint)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((ServiceID
s, Fingerprint
f) (ServiceID, Fingerprint)
-> [(ServiceID, Fingerprint)] -> [(ServiceID, Fingerprint)]
forall a. a -> [a] -> [a]
: [(ServiceID, Fingerprint)]
list)))

-- | a cache query function working on list.
-- don't use when the list grows a lot.
queryListCallback :: [(ServiceID, Fingerprint)] -> ValidationCacheQueryCallback
queryListCallback :: [(ServiceID, Fingerprint)] -> ValidationCacheQueryCallback
queryListCallback [(ServiceID, Fingerprint)]
list = ValidationCacheQueryCallback
forall {m :: * -> *} {p}.
Monad m =>
ServiceID -> Fingerprint -> p -> m ValidationCacheResult
query
  where
    query :: ServiceID -> Fingerprint -> p -> m ValidationCacheResult
query ServiceID
serviceID Fingerprint
fingerprint p
_ = ValidationCacheResult -> m ValidationCacheResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidationCacheResult -> m ValidationCacheResult)
-> ValidationCacheResult -> m ValidationCacheResult
forall a b. (a -> b) -> a -> b
$
        case ServiceID -> [(ServiceID, Fingerprint)] -> Maybe Fingerprint
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ServiceID
serviceID [(ServiceID, Fingerprint)]
list of
            Maybe Fingerprint
Nothing -> ValidationCacheResult
ValidationCacheUnknown
            Just Fingerprint
f
                | Fingerprint
fingerprint Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
f -> ValidationCacheResult
ValidationCachePass
                | Bool
otherwise ->
                    String -> ValidationCacheResult
ValidationCacheDenied
                        (ServiceID -> String
forall a. Show a => a -> String
show ServiceID
serviceID String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" expected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Fingerprint -> String
forall a. Show a => a -> String
show Fingerprint
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" but got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Fingerprint -> String
forall a. Show a => a -> String
show Fingerprint
fingerprint)