{-# 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.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]
(Int -> StsPolicy -> ShowS)
-> (StsPolicy -> [Char])
-> ([StsPolicy] -> ShowS)
-> Show StsPolicy
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StsPolicy -> ShowS
showsPrec :: Int -> StsPolicy -> ShowS
$cshow :: StsPolicy -> [Char]
show :: StsPolicy -> [Char]
$cshowList :: [StsPolicy] -> ShowS
showList :: [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 -> [Char]
encodePolicy StsPolicies
p =
  Doc -> [Char]
forall a. Show a => a -> [Char]
show (Doc -> [Char]) -> Doc -> [Char]
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 ()
               ([Char] -> Text
Text.pack
                 (Format UTCTime -> UTCTime -> [Char]
forall t. Format t -> t -> [Char]
formatShow Format UTCTime
forall t. ISO8601 t => Format t
iso8601Format
                   (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 [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 <- IO Text -> IO (Either IOError Text)
forall e a. Exception e => IO a -> IO (Either e a)
try ([Char] -> IO Text
Text.readFile [Char]
path) :: IO (Either IOError Text)
     StsPolicies -> IO StsPolicies
forall a. a -> IO a
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 [Char]
path <- IO [Char]
getPolicyFilePath
     IO () -> IO (Either IOError ())
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 [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n")) :: IO (Either IOError ())
     return ()

dateTimeSpec :: ValueSpec UTCTime
dateTimeSpec :: ValueSpec UTCTime
dateTimeSpec
  = Text
-> ValueSpec [Char]
-> ([Char] -> Either Text UTCTime)
-> ValueSpec UTCTime
forall a b.
Text -> ValueSpec a -> (a -> Either Text b) -> ValueSpec b
customSpec Text
"date-time" ValueSpec [Char]
stringSpec
  (([Char] -> Either Text UTCTime) -> ValueSpec UTCTime)
-> ([Char] -> 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)
-> ([Char] -> Maybe UTCTime) -> [Char] -> Either Text UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Format UTCTime -> [Char] -> Maybe UTCTime
forall (m :: * -> *) t. MonadFail m => Format t -> [Char] -> m t
formatParseM Format UTCTime
forall t. ISO8601 t => Format t
iso8601Format