diohsc-0.1.3: 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/.

{-# LANGUAGE LambdaCase #-}

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 $ (\case
            Right [PEM _ _ content] -> case decodeSignedCertificate content of
                Right cert -> Just cert
                _          -> Nothing
            _ -> Nothing) . pemParseBS <$> BS.readFile filepath

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