-- |
-- 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 (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
    }

defaultValidationCache :: ValidationCache
defaultValidationCache = exceptionValidationCache []

instance Default ValidationCache where
    def = 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 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)
