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