diohsc-0.1.1: ServiceCerts.hs

-- This file is part of Diohsc
-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of version 3 of the GNU General Public License as
-- published by the Free Software Foundation, or any later version.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see http://www.gnu.org/licenses/.

module ServiceCerts where

import Data.List (elemIndex)
import Data.PEM
import Data.X509
import Data.X509.Validation
import System.FilePath

import qualified Data.ByteString as BS
import qualified Data.Text as TS
import qualified Data.Text.Encoding as TS

import Mundanities
import Util

serviceToString :: ServiceID -> String
serviceToString (host, suffix) = host ++ TS.unpack (TS.decodeUtf8 suffix)

-- |service suffix must start with ':'
stringToService :: String -> ServiceID
stringToService s = maybe
    (s, BS.empty)
    (\i -> (take i s, TS.encodeUtf8 . TS.pack . drop i $ s))
    (elemIndex ':' s)

loadServiceCert :: FilePath -> ServiceID -> IO (Maybe SignedCertificate)
loadServiceCert path service =
    let filepath = path </> serviceToString service
    in ignoreIOErrAlt $
        pemParseBS <$> BS.readFile filepath >>= \pem -> return $ case pem of
            Right [PEM _ _ content] -> case decodeSignedCertificate content of
                Right cert -> Just cert
                _ -> Nothing
            _ -> Nothing

saveServiceCert :: FilePath -> ServiceID -> SignedCertificate -> IO ()
saveServiceCert path service cert =
    let filepath = path </> serviceToString service
    in isSubPath path filepath >>? BS.writeFile filepath .
            pemWriteBS . PEM "CERTIFICATE" [] . encodeSignedObject $ cert