fix logical inversion of overwrite check
[diohsc.git] / ServiceCerts.hs
blob3263b4f876fc96a47c93cbcd1e8c88e5af022a70
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/.
11 {-# LANGUAGE LambdaCase #-}
13 module ServiceCerts where
15 import Data.List (elemIndex)
16 import Data.PEM
17 import Data.X509
18 import Data.X509.Validation
19 import System.FilePath
21 import qualified Data.ByteString as BS
22 import qualified Data.Text as TS
23 import qualified Data.Text.Encoding as TS
25 import Mundanities
26 import Util
28 serviceToString :: ServiceID -> String
29 serviceToString (host, suffix) = host ++ TS.unpack (TS.decodeUtf8 suffix)
31 -- |service suffix must start with ':'
32 stringToService :: String -> ServiceID
33 stringToService s = maybe
34 (s, BS.empty)
35 (\i -> (take i s, TS.encodeUtf8 . TS.pack . drop i $ s))
36 (elemIndex ':' s)
38 loadServiceCert :: FilePath -> ServiceID -> IO (Maybe SignedCertificate)
39 loadServiceCert path service =
40 let filepath = path </> serviceToString service
41 in ignoreIOErrAlt $ (\case
42 Right [PEM _ _ content] -> case decodeSignedCertificate content of
43 Right cert -> Just cert
44 _ -> Nothing
45 _ -> Nothing) . pemParseBS <$> BS.readFile filepath
47 saveServiceCert :: FilePath -> ServiceID -> SignedCertificate -> IO ()
48 saveServiceCert path service cert =
49 let filepath = path </> serviceToString service
50 in isSubPath path filepath >>? BS.writeFile filepath .
51 pemWriteBS . PEM "CERTIFICATE" [] . encodeSignedObject $ cert