    {-# LANGUAGE CPP #-}

    module Data.X509.CertificateStore (
        CertificateStore,
        isEmptyCertificateStore,
        makeCertificateStore,
        readCertificateStore,
        readCertificates,

        -- * Queries
        findCertificate,
        listCertificates,
    ) where

    import Data.Char (isDigit, isHexDigit)
    import Data.Either (rights)
    import Data.List (foldl', isPrefixOf)
    #if MIN_VERSION_base(4,9,0)
    import           Data.Semigroup
    #else
    import           Data.Monoid
    #endif
    import Control.Applicative ((<$>))
    import qualified Control.Exception as E
    import Control.Monad (filterM, mplus)
    import qualified Data.ByteString as B
    import qualified Data.Map as M
    import Data.PEM (pemContent, pemParseBS)
    import Data.X509
    import System.Directory (
        doesDirectoryExist,
        doesFileExist,
        getDirectoryContents,
     )
    import System.FilePath ((</>))

    -- | A Collection of certificate or store of certificates.
    data CertificateStore
        = CertificateStore (M.Map DistinguishedName SignedCertificate)
        | CertificateStores [CertificateStore]

    isEmptyCertificateStore :: CertificateStore -> Bool
    isEmptyCertificateStore :: CertificateStore -> Bool
    isEmptyCertificateStore (CertificateStore Map DistinguishedName SignedCertificate
    m) = Map DistinguishedName SignedCertificate -> Bool
    forall k a. Map k a -> Bool
    M.null Map DistinguishedName SignedCertificate
    m
    isEmptyCertificateStore (CertificateStores []) = Bool
    True
    isEmptyCertificateStore CertificateStore
    _ = Bool
    False

    #if MIN_VERSION_base(4,9,0)
    instance Semigroup CertificateStore where
        <> :: CertificateStore -> CertificateStore -> CertificateStore
    (<>) = CertificateStore -> CertificateStore -> CertificateStore
    append
    #endif

    instance Monoid CertificateStore where
        mempty :: CertificateStore
    mempty = Map DistinguishedName SignedCertificate -> CertificateStore
    CertificateStore Map DistinguishedName SignedCertificate
    forall k a. Map k a
    M.empty
    #if !(MIN_VERSION_base(4,11,0))
        mappend = append
    #endif

    append :: CertificateStore -> CertificateStore -> CertificateStore
    append :: CertificateStore -> CertificateStore -> CertificateStore
    append s1 :: CertificateStore
    s1@(CertificateStore Map DistinguishedName SignedCertificate
    _) s2 :: CertificateStore
    s2@(CertificateStore Map DistinguishedName SignedCertificate
    _) = [CertificateStore] -> CertificateStore
    CertificateStores [CertificateStore
    s1, CertificateStore
    s2]
    append (CertificateStores [CertificateStore]
    l) s2 :: CertificateStore
    s2@(CertificateStore Map DistinguishedName SignedCertificate
    _) = [CertificateStore] -> CertificateStore
    CertificateStores ([CertificateStore]
    l [CertificateStore] -> [CertificateStore] -> [CertificateStore]
    forall a. [a] -> [a] -> [a]
    ++ [CertificateStore
    s2])
    append s1 :: CertificateStore
    s1@(CertificateStore Map DistinguishedName SignedCertificate
    _) (CertificateStores [CertificateStore]
    l) = [CertificateStore] -> CertificateStore
    CertificateStores ([CertificateStore
    s1] [CertificateStore] -> [CertificateStore] -> [CertificateStore]
    forall a. [a] -> [a] -> [a]
    ++ [CertificateStore]
    l)
    append (CertificateStores [CertificateStore]
    l1) (CertificateStores [CertificateStore]
    l2) = [CertificateStore] -> CertificateStore
    CertificateStores ([CertificateStore]
    l1 [CertificateStore] -> [CertificateStore] -> [CertificateStore]
    forall a. [a] -> [a] -> [a]
    ++ [CertificateStore]
    l2)

    -- | Create a certificate store out of a list of X509 certificate
    makeCertificateStore :: [SignedCertificate] -> CertificateStore
    makeCertificateStore :: [SignedCertificate] -> CertificateStore
    makeCertificateStore = Map DistinguishedName SignedCertificate -> CertificateStore
    CertificateStore (Map DistinguishedName SignedCertificate -> CertificateStore)
    -> ([SignedCertificate] -> Map DistinguishedName SignedCertificate)
    -> [SignedCertificate]
    -> CertificateStore
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Map DistinguishedName SignedCertificate
     -> SignedCertificate -> Map DistinguishedName SignedCertificate)
    -> Map DistinguishedName SignedCertificate
    -> [SignedCertificate]
    -> Map DistinguishedName SignedCertificate
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' Map DistinguishedName SignedCertificate
    -> SignedCertificate -> Map DistinguishedName SignedCertificate
    accumulate Map DistinguishedName SignedCertificate
    forall k a. Map k a
    M.empty
      where
        accumulate :: Map DistinguishedName SignedCertificate
    -> SignedCertificate -> Map DistinguishedName SignedCertificate
    accumulate Map DistinguishedName SignedCertificate
    m SignedCertificate
    x509 = DistinguishedName
    -> SignedCertificate
    -> Map DistinguishedName SignedCertificate
    -> Map DistinguishedName SignedCertificate
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    M.insert (Certificate -> DistinguishedName
    certSubjectDN (Certificate -> DistinguishedName)
    -> Certificate -> DistinguishedName
    forall a b. (a -> b) -> a -> b
    $ SignedCertificate -> Certificate
    getCertificate SignedCertificate
    x509) SignedCertificate
    x509 Map DistinguishedName SignedCertificate
    m

    -- | Find a certificate using the subject distinguished name
    findCertificate
        :: DistinguishedName -> CertificateStore -> Maybe SignedCertificate
    findCertificate :: DistinguishedName -> CertificateStore -> Maybe SignedCertificate
    findCertificate DistinguishedName
    dn CertificateStore
    store = CertificateStore -> Maybe SignedCertificate
    lookupIn CertificateStore
    store
      where
        lookupIn :: CertificateStore -> Maybe SignedCertificate
    lookupIn (CertificateStore Map DistinguishedName SignedCertificate
    m) = DistinguishedName
    -> Map DistinguishedName SignedCertificate
    -> Maybe SignedCertificate
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup DistinguishedName
    dn Map DistinguishedName SignedCertificate
    m
        lookupIn (CertificateStores [CertificateStore]
    l) = (Maybe SignedCertificate
     -> Maybe SignedCertificate -> Maybe SignedCertificate)
    -> Maybe SignedCertificate
    -> [Maybe SignedCertificate]
    -> Maybe SignedCertificate
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Maybe SignedCertificate
    -> Maybe SignedCertificate -> Maybe SignedCertificate
    forall a. Maybe a -> Maybe a -> Maybe a
    forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
    mplus Maybe SignedCertificate
    forall a. Maybe a
    Nothing ([Maybe SignedCertificate] -> Maybe SignedCertificate)
    -> [Maybe SignedCertificate] -> Maybe SignedCertificate
    forall a b. (a -> b) -> a -> b
    $ (CertificateStore -> Maybe SignedCertificate)
    -> [CertificateStore] -> [Maybe SignedCertificate]
    forall a b. (a -> b) -> [a] -> [b]
    map CertificateStore -> Maybe SignedCertificate
    lookupIn [CertificateStore]
    l

    -- | List all certificates in a store
    listCertificates :: CertificateStore -> [SignedCertificate]
    listCertificates :: CertificateStore -> [SignedCertificate]
    listCertificates (CertificateStore Map DistinguishedName SignedCertificate
    store) = ((DistinguishedName, SignedCertificate) -> SignedCertificate)
    -> [(DistinguishedName, SignedCertificate)] -> [SignedCertificate]
    forall a b. (a -> b) -> [a] -> [b]
    map (DistinguishedName, SignedCertificate) -> SignedCertificate
    forall a b. (a, b) -> b
    snd ([(DistinguishedName, SignedCertificate)] -> [SignedCertificate])
    -> [(DistinguishedName, SignedCertificate)] -> [SignedCertificate]
    forall a b. (a -> b) -> a -> b
    $ Map DistinguishedName SignedCertificate
    -> [(DistinguishedName, SignedCertificate)]
    forall k a. Map k a -> [(k, a)]
    M.toList Map DistinguishedName SignedCertificate
    store
    listCertificates (CertificateStores [CertificateStore]
    l) = (CertificateStore -> [SignedCertificate])
    -> [CertificateStore] -> [SignedCertificate]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap CertificateStore -> [SignedCertificate]
    listCertificates [CertificateStore]
    l

    -- | Create certificate store by reading certificates from file or directory
    --
    -- This function can be used to read multiple certificates from either
    -- single file (multiple PEM formatted certificates concanated) or
    -- directory (one certificate per file, file names are hashes from
    -- certificate).
    readCertificateStore :: FilePath -> IO (Maybe CertificateStore)
    readCertificateStore :: FilePath -> IO (Maybe CertificateStore)
    readCertificateStore FilePath
    path = do
        isDir <- FilePath -> IO Bool
    doesDirectoryExist FilePath
    path
        isFile <- doesFileExist path
        wrapStore
            <$> (if isDir then makeDirStore else if isFile then makeFileStore else return [])
      where
        wrapStore :: [SignedCertificate] -> Maybe CertificateStore
        wrapStore :: [SignedCertificate] -> Maybe CertificateStore
    wrapStore [] = Maybe CertificateStore
    forall a. Maybe a
    Nothing
        wrapStore [SignedCertificate]
    l = CertificateStore -> Maybe CertificateStore
    forall a. a -> Maybe a
    Just (CertificateStore -> Maybe CertificateStore)
    -> CertificateStore -> Maybe CertificateStore
    forall a b. (a -> b) -> a -> b
    $ [SignedCertificate] -> CertificateStore
    makeCertificateStore [SignedCertificate]
    l

        makeFileStore :: IO [SignedCertificate]
    makeFileStore = FilePath -> IO [SignedCertificate]
    readCertificates FilePath
    path
        makeDirStore :: IO [SignedCertificate]
    makeDirStore = do
            certFiles <- FilePath -> IO [FilePath]
    listDirectoryCerts FilePath
    path
            concat <$> mapM readCertificates certFiles

    -- Try to read certificate from the content of a file.
    --
    -- The file may contains multiple certificates
    readCertificates :: FilePath -> IO [SignedCertificate]
    readCertificates :: FilePath -> IO [SignedCertificate]
    readCertificates FilePath
    file =
        IO [SignedCertificate]
    -> (IOException -> IO [SignedCertificate])
    -> IO [SignedCertificate]
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    E.catch
            ((FilePath -> [SignedCertificate])
    -> ([PEM] -> [SignedCertificate])
    -> Either FilePath [PEM]
    -> [SignedCertificate]
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either ([SignedCertificate] -> FilePath -> [SignedCertificate]
    forall a b. a -> b -> a
    const []) ([Either FilePath SignedCertificate] -> [SignedCertificate]
    forall a b. [Either a b] -> [b]
    rights ([Either FilePath SignedCertificate] -> [SignedCertificate])
    -> ([PEM] -> [Either FilePath SignedCertificate])
    -> [PEM]
    -> [SignedCertificate]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (PEM -> Either FilePath SignedCertificate)
    -> [PEM] -> [Either FilePath SignedCertificate]
    forall a b. (a -> b) -> [a] -> [b]
    map PEM -> Either FilePath SignedCertificate
    getCert) (Either FilePath [PEM] -> [SignedCertificate])
    -> (ByteString -> Either FilePath [PEM])
    -> ByteString
    -> [SignedCertificate]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> Either FilePath [PEM]
    pemParseBS (ByteString -> [SignedCertificate])
    -> IO ByteString -> IO [SignedCertificate]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> FilePath -> IO ByteString
    B.readFile FilePath
    file)
            IOException -> IO [SignedCertificate]
    skipIOError
      where
        getCert :: PEM -> Either FilePath SignedCertificate
    getCert = ByteString -> Either FilePath SignedCertificate
    decodeSignedCertificate (ByteString -> Either FilePath SignedCertificate)
    -> (PEM -> ByteString) -> PEM -> Either FilePath SignedCertificate
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . PEM -> ByteString
    pemContent
        skipIOError :: E.IOException -> IO [SignedCertificate]
        skipIOError :: IOException -> IO [SignedCertificate]
    skipIOError IOException
    _ = [SignedCertificate] -> IO [SignedCertificate]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []

    -- List all the path susceptible to contains a certificate in a directory
    --
    -- if the parameter is not a directory, hilarity follows.
    listDirectoryCerts :: FilePath -> IO [FilePath]
    listDirectoryCerts :: FilePath -> IO [FilePath]
    listDirectoryCerts FilePath
    path =
        IO [FilePath]
    getDirContents IO [FilePath] -> ([FilePath] -> IO [FilePath]) -> IO [FilePath]
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
    forall (m :: * -> *) a.
    Applicative m =>
    (a -> m Bool) -> [a] -> m [a]
    filterM FilePath -> IO Bool
    doesFileExist
      where
        isHashedFile :: FilePath -> Bool
    isHashedFile FilePath
    s =
            FilePath -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length FilePath
    s Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    10
                Bool -> Bool -> Bool
    && Char -> Bool
    isDigit (FilePath
    s FilePath -> Int -> Char
    forall a. HasCallStack => [a] -> Int -> a
    !! Int
    9)
                Bool -> Bool -> Bool
    && (FilePath
    s FilePath -> Int -> Char
    forall a. HasCallStack => [a] -> Int -> a
    !! Int
    8) Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '.'
                Bool -> Bool -> Bool
    && (Char -> Bool) -> FilePath -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Char -> Bool
    isHexDigit (Int -> FilePath -> FilePath
    forall a. Int -> [a] -> [a]
    take Int
    8 FilePath
    s)
        isCert :: FilePath -> Bool
    isCert FilePath
    x = (Bool -> Bool
    not (Bool -> Bool) -> Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $ FilePath -> FilePath -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    isPrefixOf FilePath
    "." FilePath
    x) Bool -> Bool -> Bool
    && (Bool -> Bool
    not (Bool -> Bool) -> Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $ FilePath -> Bool
    isHashedFile FilePath
    x)

        getDirContents :: IO [FilePath]
    getDirContents =
            IO [FilePath] -> (IOException -> IO [FilePath]) -> IO [FilePath]
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    E.catch
                ((FilePath -> FilePath) -> [FilePath] -> [FilePath]
    forall a b. (a -> b) -> [a] -> [b]
    map (FilePath
    path FilePath -> FilePath -> FilePath
    </>) ([FilePath] -> [FilePath])
    -> ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (FilePath -> Bool) -> [FilePath] -> [FilePath]
    forall a. (a -> Bool) -> [a] -> [a]
    filter FilePath -> Bool
    isCert ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> FilePath -> IO [FilePath]
    getDirectoryContents FilePath
    path)
                IOException -> IO [FilePath]
    emptyPaths
          where
            emptyPaths :: E.IOException -> IO [FilePath]
            emptyPaths :: IOException -> IO [FilePath]
    emptyPaths IOException
    _ = [FilePath] -> IO [FilePath]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []