{-# 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]
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