ServiceCerts.hs

   1 -- This file is part of Diohsc
   2 -- Copyright (C) 2020 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 {-# LANGUAGE LambdaCase #-}
  12
  13 module ServiceCerts where
  14
  15 import           Data.List            (elemIndex)
  16 import           Data.PEM
  17 import           Data.X509
  18 import           Data.X509.Validation
  19 import           System.Directory     (doesFileExist, removeFile, renamePath)
  20 import           System.FilePath
  21
  22 import qualified Data.ByteString      as BS
  23 import qualified Data.Text            as TS
  24 import qualified Data.Text.Encoding   as TS
  25
  26 import           Mundanities
  27 import           Util
  28
  29 serviceToString :: ServiceID -> String
  30 serviceToString (host, suffix) = host ++ TS.unpack (TS.decodeUtf8 suffix)
  31
  32 -- |service suffix must start with ':'
  33 stringToService :: String -> ServiceID
  34 stringToService s = maybe
  35     (s, BS.empty)
  36     (\i -> (take i s, TS.encodeUtf8 . TS.pack . drop i $ s))
  37     (elemIndex ':' s)
  38
  39 loadServiceCert :: FilePath -> ServiceID -> IO (Maybe SignedCertificate)
  40 loadServiceCert path service =
  41     let filepath = path </> serviceToString service
  42     in ignoreIOErrAlt $ (\case
  43             Right [PEM _ _ content] -> case decodeSignedCertificate content of
  44                 Right cert -> Just cert
  45                 _          -> Nothing
  46             _ -> Nothing) . pemParseBS <$> BS.readFile filepath
  47
  48 -- |'#' is illegal in a hostname, so this avoids clashes
  49 tempSuffix :: String
  50 tempSuffix = "#temp"
  51
  52 saveServiceCert :: FilePath -> ServiceID -> SignedCertificate -> IO ()
  53 saveServiceCert path service cert =
  54     let filepath = path </> serviceToString service
  55     in isSubPath path filepath >>? do
  56         doesFileExist filepath >>? renamePath filepath (filepath ++ ".bk")
  57         ignoreIOErr . removeFile $ filepath <> tempSuffix
  58         BS.writeFile filepath .
  59             pemWriteBS . PEM "CERTIFICATE" [] . encodeSignedObject $ cert
  60
  61 type TempServiceInfo = (Int,String)
  62
  63 loadTempServiceInfo :: FilePath -> ServiceID -> IO (Maybe TempServiceInfo)
  64 loadTempServiceInfo path service =
  65     readReadFile $ path </> serviceToString service <> tempSuffix
  66
  67 saveTempServiceInfo :: FilePath -> ServiceID -> TempServiceInfo -> IO ()
  68 saveTempServiceInfo path service =
  69     writeReadFile (path </> serviceToString service <> tempSuffix)