    -- |
    -- 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
        l <- [(ServiceID, Fingerprint)] -> IO (MVar [(ServiceID, Fingerprint)])
    forall a. a -> IO (MVar a)
    newMVar [(ServiceID, Fingerprint)]
    fingerprints
        return $
            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)