{-# LANGUAGE CPP #-}
module Data.X509.CertificateStore
    ( CertificateStore
    , makeCertificateStore
    , readCertificateStore
    -- * 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 Data.PEM (pemParseBS, pemContent)
import Data.X509
import qualified Data.Map as M
import Control.Applicative ((<$>))
import Control.Monad (mplus, filterM)
import System.Directory (getDirectoryContents, doesFileExist, doesDirectoryExist)
import System.FilePath ((</>))
import qualified Control.Exception as E
import qualified Data.ByteString as B


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

#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 (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 (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Maybe SignedCertificate
-> Maybe SignedCertificate -> Maybe SignedCertificate
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
    Bool
isDir  <- FilePath -> IO Bool
doesDirectoryExist FilePath
path
    Bool
isFile <- FilePath -> IO Bool
doesFileExist FilePath
path
    [SignedCertificate] -> Maybe CertificateStore
wrapStore ([SignedCertificate] -> Maybe CertificateStore)
-> IO [SignedCertificate] -> IO (Maybe CertificateStore)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (if Bool
isDir then IO [SignedCertificate]
makeDirStore else if Bool
isFile then IO [SignedCertificate]
makeFileStore else [SignedCertificate] -> IO [SignedCertificate]
forall (m :: * -> *) a. Monad m => a -> m a
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
        [FilePath]
certFiles <- FilePath -> IO [FilePath]
listDirectoryCerts FilePath
path
        [[SignedCertificate]] -> [SignedCertificate]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[SignedCertificate]] -> [SignedCertificate])
-> IO [[SignedCertificate]] -> IO [SignedCertificate]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO [SignedCertificate])
-> [FilePath] -> IO [[SignedCertificate]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO [SignedCertificate]
readCertificates [FilePath]
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 (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 (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 (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. [a] -> Int -> a
!! Int
9)
                  Bool -> Bool -> Bool
&& (FilePath
s FilePath -> Int -> Char
forall a. [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 (m :: * -> *) a. Monad m => a -> m a
return []