{-# LANGUAGE ApplicativeDo, TemplateHaskell, OverloadedStrings #-}
module Client.Configuration.Sts
( StsPolicy(..)
, stsExpiration
, stsPort
, readPolicyFile
, savePolicyFile
) where
import Config (Value(..), Section(..), parse, pretty)
import Config.Number (integerToNumber)
import Config.Schema.Load (loadValue)
import Config.Schema.Spec
import Control.Exception (try)
import Control.Lens (makeLenses)
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.IO qualified as Text
import Data.Time (UTCTime)
import Data.Time.Format.ISO8601 (formatParseM, formatShow, ISO8601(iso8601Format))
import System.Directory (getXdgDirectory, XdgDirectory(XdgConfig), createDirectoryIfMissing)
import System.FilePath ((</>), takeDirectory)
data StsPolicy = StsPolicy
{ StsPolicy -> UTCTime
_stsExpiration :: !UTCTime
, StsPolicy -> Int
_stsPort :: !Int
}
deriving (Int -> StsPolicy -> ShowS
[StsPolicy] -> ShowS
StsPolicy -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [StsPolicy] -> ShowS
$cshowList :: [StsPolicy] -> ShowS
show :: StsPolicy -> [Char]
$cshow :: StsPolicy -> [Char]
showsPrec :: Int -> StsPolicy -> ShowS
$cshowsPrec :: Int -> StsPolicy -> ShowS
Show)
type StsPolicies = HashMap Text StsPolicy
makeLenses ''StsPolicy
policySpec :: ValueSpec StsPolicies
policySpec :: ValueSpec StsPolicies
policySpec = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ValueSpec a -> ValueSpec [a]
listSpec ValueSpec (Text, StsPolicy)
policyEntry
policyEntry :: ValueSpec (Text, StsPolicy)
policyEntry :: ValueSpec (Text, StsPolicy)
policyEntry =
forall a. Text -> SectionsSpec a -> ValueSpec a
sectionsSpec Text
"sts-policy" forall a b. (a -> b) -> a -> b
$
do Text
hostname <- forall a. HasSpec a => Text -> Text -> SectionsSpec a
reqSection Text
"host" Text
"Hostname"
UTCTime
expiration <- forall a. Text -> ValueSpec a -> Text -> SectionsSpec a
reqSection' Text
"until" ValueSpec UTCTime
dateTimeSpec Text
"Expiration date"
Int
port <- forall a. HasSpec a => Text -> Text -> SectionsSpec a
reqSection Text
"port" Text
"Port number"
return (Text
hostname, UTCTime -> Int -> StsPolicy
StsPolicy UTCTime
expiration Int
port)
encodePolicy :: StsPolicies -> String
encodePolicy :: StsPolicies -> [Char]
encodePolicy StsPolicies
p =
forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a. Value a -> Doc
pretty forall a b. (a -> b) -> a -> b
$
forall a. a -> [Value a] -> Value a
List ()
[ forall a. a -> [Section a] -> Value a
Sections ()
[ forall a. a -> Text -> Value a -> Section a
Section () Text
"host"
(forall a. a -> Text -> Value a
Text () Text
k),
forall a. a -> Text -> Value a -> Section a
Section () Text
"port"
(forall a. a -> Number -> Value a
Number () (Integer -> Number
integerToNumber (forall a b. (Integral a, Num b) => a -> b
fromIntegral (StsPolicy -> Int
_stsPort StsPolicy
v)))),
forall a. a -> Text -> Value a -> Section a
Section () Text
"until"
(forall a. a -> Text -> Value a
Text ()
([Char] -> Text
Text.pack
(forall t. Format t -> t -> [Char]
formatShow forall t. ISO8601 t => Format t
iso8601Format
(StsPolicy -> UTCTime
_stsExpiration StsPolicy
v))))
]
| (Text
k, StsPolicy
v) <- forall k v. HashMap k v -> [(k, v)]
HashMap.toList StsPolicies
p ]
decodePolicy :: Text -> Maybe StsPolicies
decodePolicy :: Text -> Maybe StsPolicies
decodePolicy Text
txt =
case Text -> Either ParseError (Value Position)
parse Text
txt of
Left ParseError
_ -> forall a. Maybe a
Nothing
Right Value Position
rawval ->
case forall a p.
ValueSpec a -> Value p -> Either (ValueSpecMismatch p) a
loadValue ValueSpec StsPolicies
policySpec Value Position
rawval of
Left ValueSpecMismatch Position
_ -> forall a. Maybe a
Nothing
Right StsPolicies
policy -> forall a. a -> Maybe a
Just StsPolicies
policy
getPolicyFilePath :: IO FilePath
getPolicyFilePath :: IO [Char]
getPolicyFilePath =
do [Char]
dir <- XdgDirectory -> [Char] -> IO [Char]
getXdgDirectory XdgDirectory
XdgConfig [Char]
"glirc"
return ([Char]
dir [Char] -> ShowS
</> [Char]
"sts.cfg")
readPolicyFile :: IO StsPolicies
readPolicyFile :: IO StsPolicies
readPolicyFile =
do [Char]
path <- IO [Char]
getPolicyFilePath
Either IOError Text
res <- forall e a. Exception e => IO a -> IO (Either e a)
try ([Char] -> IO Text
Text.readFile [Char]
path) :: IO (Either IOError Text)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! case Either IOError Text
res of
Left {} -> forall k v. HashMap k v
HashMap.empty
Right Text
txt -> forall a. a -> Maybe a -> a
fromMaybe forall k v. HashMap k v
HashMap.empty (Text -> Maybe StsPolicies
decodePolicy Text
txt)
savePolicyFile :: StsPolicies -> IO ()
savePolicyFile :: StsPolicies -> IO ()
savePolicyFile StsPolicies
sts =
do [Char]
path <- IO [Char]
getPolicyFilePath
forall e a. Exception e => IO a -> IO (Either e a)
try (do Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True (ShowS
takeDirectory [Char]
path)
[Char] -> [Char] -> IO ()
writeFile [Char]
path (StsPolicies -> [Char]
encodePolicy StsPolicies
sts forall a. [a] -> [a] -> [a]
++ [Char]
"\n")) :: IO (Either IOError ())
return ()
dateTimeSpec :: ValueSpec UTCTime
dateTimeSpec :: ValueSpec UTCTime
dateTimeSpec
= forall a b.
Text -> ValueSpec a -> (a -> Either Text b) -> ValueSpec b
customSpec Text
"date-time" ValueSpec [Char]
stringSpec
forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left Text
"unable to parse") forall a b. b -> Either a b
Right
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) t. MonadFail m => Format t -> [Char] -> m t
formatParseM forall t. ISO8601 t => Format t
iso8601Format