{-# LANGUAGE ApplicativeDo, TemplateHaskell, OverloadedStrings #-}

{-|
Module      : Client.Configuration.Sts
Description : STS policy configuration
Copyright   : (c) Eric Mertens, 2019
License     : ISC
Maintainer  : emertens@gmail.com

https://ircv3.net/specs/extensions/sts.html

-}
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")