content: {-# 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
    { _stsExpiration :: !UTCTime
    , _stsPort       :: !Int
    }
    deriving (Show)
  
  type StsPolicies = HashMap Text StsPolicy
  
  makeLenses ''StsPolicy
  
  policySpec :: ValueSpec StsPolicies
  policySpec = HashMap.fromList <$> listSpec policyEntry
  
  policyEntry :: ValueSpec (Text, StsPolicy)
  policyEntry =
    sectionsSpec "sts-policy" $
    do hostname   <- reqSection "host" "Hostname"
       expiration <- reqSection' "until" dateTimeSpec "Expiration date"
       port       <- reqSection "port" "Port number"
       return (hostname, StsPolicy expiration port)
  
  encodePolicy :: StsPolicies -> String
  encodePolicy p =
    show $ pretty $
    List ()
      [ Sections ()
          [ Section () "host"
              (Text () k),
            Section () "port"
              (Number () (integerToNumber (fromIntegral (_stsPort v)))),
            Section () "until"
              (Text ()
                 (Text.pack
                   (formatShow iso8601Format
                     (_stsExpiration v))))
          ]
      | (k, v) <- HashMap.toList p ]
  
  decodePolicy :: Text -> Maybe StsPolicies
  decodePolicy txt =
    case parse txt of
      Left _ -> Nothing
      Right rawval ->
        case loadValue policySpec rawval of
          Left _ -> Nothing
          Right policy -> Just policy
  
  getPolicyFilePath :: IO FilePath
  getPolicyFilePath =
    do dir <- getXdgDirectory XdgConfig "glirc"
       return (dir </> "sts.cfg")
  
  readPolicyFile :: IO StsPolicies
  readPolicyFile =
    do path <- getPolicyFilePath
       res <- try (Text.readFile path) :: IO (Either IOError Text)
       return $! case res of
         Left {}   -> HashMap.empty
         Right txt -> fromMaybe HashMap.empty (decodePolicy txt)
  
  savePolicyFile :: StsPolicies -> IO ()
  savePolicyFile sts =
    do path <- getPolicyFilePath
       try (do createDirectoryIfMissing True (takeDirectory path)
               writeFile path (encodePolicy sts ++ "\n")) :: IO (Either IOError ())
       return ()
  
  dateTimeSpec :: ValueSpec UTCTime
  dateTimeSpec
    = customSpec "date-time" stringSpec
    $ maybe (Left "unable to parse") Right
    . formatParseM iso8601Format
  