{-# Language OverloadedStrings #-}
{-# Language TemplateHaskell #-}
{-# Language BangPatterns #-}
{-# Language RecordWildCards #-}

{-|
Module      : Client.Configuration
Description : Client configuration format and operations
Copyright   : (c) Eric Mertens, 2016
License     : ISC
Maintainer  : emertens@gmail.com

This module defines the top-level configuration information for the client.
-}

module Client.Configuration
  (
  -- * Configuration type
    Configuration(..)
  , ConfigurationFailure(..)
  , configDefaults
  , configServers
  , configPalette
  , configWindowNames
  , configNickPadding
  , configConfigPath
  , configMacros
  , configExtensions

  -- * Loading configuration
  , loadConfiguration

  -- * Resolving paths
  , resolveConfigurationPath
  ) where

import           Client.Image.Palette
import           Client.Configuration.Colors
import           Client.Configuration.ServerSettings
import           Client.Commands.Interpolation
import           Control.Exception
import           Control.Monad
import           Config
import           Config.FromConfig
import           Control.Lens hiding (List)
import           Data.Foldable (for_)
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import           Data.Maybe
import           Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Data.Vector as Vector
import           Irc.Identifier (Identifier, mkId)
import           System.Directory
import           System.FilePath
import           System.IO.Error

-- | Top-level client configuration information. When connecting to a
-- server configuration from '_configServers' is used where possible,
-- otherwise '_configDefaults' is used.
data Configuration = Configuration
  { _configDefaults :: ServerSettings -- ^ Default connection settings
  , _configServers  :: (HashMap Text ServerSettings) -- ^ Host-specific settings
  , _configPalette  :: Palette
  , _configWindowNames :: Text -- ^ Names of windows, used when alt-jumping)
  , _configNickPadding :: Maybe Integer -- ^ Padding of nicks
  , _configConfigPath :: Maybe FilePath
        -- ^ manually specified configuration path, used for reloading
  , _configMacros :: HashMap Text [[ExpansionChunk]] -- ^ command macros
  , _configExtensions :: [FilePath] -- ^ paths to shared library
  }
  deriving Show

makeLenses ''Configuration

data ConfigurationFailure
  = ConfigurationParseFailed String
  | ConfigurationMalformed String
  | ConfigurationReadFailed String
  deriving Show

instance Exception ConfigurationFailure

defaultWindowNames :: Text
defaultWindowNames = "1234567890qwertyuiop!@#$%^&*()QWERTYUIOP"

-- | Uses 'getAppUserDataDirectory' to find @.glirc/config@
getOldConfigPath :: IO FilePath
getOldConfigPath =
  do dir <- getAppUserDataDirectory "glirc"
     return (dir </> "config")

-- | Uses 'getXdgDirectory' 'XdgConfig' to find @.config/glirc/config@
getNewConfigPath :: IO FilePath
getNewConfigPath =
  do dir <- getXdgDirectory XdgConfig "glirc"
     return (dir </> "config")

-- | Empty configuration file used when no path is specified
-- and the configuration file is missing.
emptyConfigFile :: Text
emptyConfigFile = "{}\n"

-- | Attempt to read a file using the given handler when
-- a file does not exist. On failure a 'ConfigurationReadFailed'
-- exception is throw.
readFileCatchNotFound ::
  FilePath {- ^ file to read -} ->
  (IOError -> IO Text) {- ^ error handler for not found case -} ->
  IO Text
readFileCatchNotFound path onNotFound =
  do res <- try (Text.readFile path)
     case res of
       Left e | isDoesNotExistError e -> onNotFound e
              | otherwise -> throwIO (ConfigurationReadFailed (show e))
       Right txt -> return txt

-- | Either read a configuration file from one of the default
-- locations, in which case no configuration found is equivalent
-- to an empty configuration, or from the specified file where
-- no configuration found is an error.
readConfigurationFile ::
  Maybe FilePath {- ^ just file or use default search paths -} ->
  IO Text
readConfigurationFile mbPath =
  case mbPath of

    Just path ->
      readFileCatchNotFound path $ \e ->
        throwIO (ConfigurationReadFailed (show e))

    Nothing ->
      do newPath <- getNewConfigPath
         readFileCatchNotFound newPath $ \_ ->
           do oldPath <- getOldConfigPath
              readFileCatchNotFound oldPath $ \_ ->
                return emptyConfigFile


-- | Load the configuration file defaulting to @~/.glirc/config@.
loadConfiguration ::
  Maybe FilePath {- ^ path to configuration file -} ->
  IO (Either ConfigurationFailure Configuration)
loadConfiguration mbPath = try $
  do file <- readConfigurationFile mbPath
     def  <- loadDefaultServerSettings

     rawcfg <-
       case parse file of
         Left parseError -> throwIO (ConfigurationParseFailed parseError)
         Right rawcfg -> return rawcfg

     case runConfigParser (parseConfiguration mbPath def rawcfg) of
       Left loadError -> throwIO (ConfigurationMalformed (Text.unpack loadError))
       Right cfg -> return cfg


parseConfiguration ::
  Maybe FilePath {- ^ optionally specified path to config -} ->
  ServerSettings {- ^ prepopulated default server settings -} ->
  Value ->
  ConfigParser Configuration
parseConfiguration _configConfigPath def = parseSections $

  do _configDefaults <- fromMaybe def
                    <$> sectionOptWith (parseServerSettings def) "defaults"

     _configServers  <- fromMaybe HashMap.empty
                    <$> sectionOptWith (parseServers _configDefaults) "servers"

     _configPalette <- fromMaybe defaultPalette
                    <$> sectionOptWith parsePalette "palette"

     _configWindowNames <- fromMaybe defaultWindowNames
                    <$> sectionOpt "window-names"

     _configMacros <- fromMaybe HashMap.empty
                    <$> sectionOptWith parseMacroMap "macros"

     _configExtensions <- fromMaybe []
                    <$> sectionOptWith (parseList parseString) "extensions"

     _configNickPadding <- sectionOpt "nick-padding"
     for_ _configNickPadding (\padding ->
       when (padding < 0)
            (liftConfigParser $
               failure "nick-padding has to be a non negative number"))

     return Configuration{..}

parsePalette :: Value -> ConfigParser Palette
parsePalette = parseSectionsWith paletteHelper defaultPalette

paletteHelper :: Palette -> Text -> Value -> ConfigParser Palette
paletteHelper p k v =
  case k of
    "nick-colors" -> do xs <- Vector.fromList <$> parseList parseAttr v
                        when (null xs) (failure "Empty palette")
                        return $! set palNicks xs p

    "self"           -> setAttr palSelf
    "self-highlight" -> setAttrMb palSelfHighlight
    "time"           -> setAttr palTime
    "meta"           -> setAttr palMeta
    "sigil"          -> setAttr palSigil
    "label"          -> setAttr palLabel
    "latency"        -> setAttr palLatency
    "error"          -> setAttr palError
    "textbox"        -> setAttr palTextBox
    "window-name"    -> setAttr palWindowName
    "activity"       -> setAttr palActivity
    "mention"        -> setAttr palMention
    _                -> failure "Unknown palette entry"
  where
    setAttr l =
      do !attr <- parseAttr v
         return $! set l attr p

    setAttrMb l =
      do !attr <- parseAttr v
         return $! set l (Just attr) p

parseServers :: ServerSettings -> Value -> ConfigParser (HashMap Text ServerSettings)
parseServers def v =
  do sss <- parseList (parseServerSettings def) v
     return (HashMap.fromList [(serverSettingName ss, ss) | ss <- sss])
  where
    serverSettingName ss =
      fromMaybe (views ssHostName Text.pack ss)
                (view ssName ss)

parseServerSettings :: ServerSettings -> Value -> ConfigParser ServerSettings
parseServerSettings = parseSectionsWith parseServerSetting

parseServerSetting :: ServerSettings -> Text -> Value -> ConfigParser ServerSettings
parseServerSetting ss k v =
  case k of
    "nick"                -> setField       ssNick
    "username"            -> setField       ssUser
    "realname"            -> setField       ssReal
    "userinfo"            -> setField       ssUserInfo
    "password"            -> setFieldMb     ssPassword
    "sasl-username"       -> setFieldMb     ssSaslUsername
    "sasl-password"       -> setFieldMb     ssSaslPassword
    "hostname"            -> setFieldWith   ssHostName      parseString
    "port"                -> setFieldWithMb ssPort          parseNum
    "tls"                 -> setFieldWith   ssTls           parseBoolean
    "tls-insecure"        -> setFieldWith   ssTlsInsecure   parseBoolean
    "tls-client-cert"     -> setFieldWithMb ssTlsClientCert parseString
    "tls-client-key"      -> setFieldWithMb ssTlsClientKey  parseString
    "server-certificates" -> setFieldWith   ssServerCerts   (parseList parseString)
    "connect-cmds"        -> setField       ssConnectCmds
    "socks-host"          -> setFieldWithMb ssSocksHost     parseString
    "socks-port"          -> setFieldWith   ssSocksPort     parseNum
    "chanserv-channels"   -> setFieldWith   ssChanservChannels (parseList parseIdentifier)
    "flood-penalty"       -> setField       ssFloodPenalty
    "flood-threshold"     -> setField       ssFloodThreshold
    "message-hooks"       -> setField       ssMessageHooks
    "name"                -> setFieldMb     ssName
    _                     -> failure "Unknown section"
  where
    setField   l = setFieldWith   l parseConfig
    setFieldMb l = setFieldWithMb l parseConfig

    setFieldWith l p =
      do x <- p v
         return $! set l x ss

    setFieldWithMb l p =
      do x <- p v
         return $! set l (Just x) ss

parseBoolean :: Value -> ConfigParser Bool
parseBoolean (Atom "yes") = return True
parseBoolean (Atom "no")  = return False
parseBoolean _            = failure "expected yes or no"

parseNum :: Num a => Value -> ConfigParser a
parseNum v = fromInteger <$> parseConfig v

parseIdentifier :: Value -> ConfigParser Identifier
parseIdentifier v = mkId <$> parseConfig v

parseString :: Value -> ConfigParser String
parseString v = Text.unpack <$> parseConfig v

-- | Resolve relative paths starting at the home directory rather than
-- the current directory of the client.
resolveConfigurationPath :: FilePath -> IO FilePath
resolveConfigurationPath path
  | isAbsolute path = return path
  | otherwise = do home <- getHomeDirectory
                   return (home </> path)

parseMacroMap :: Value -> ConfigParser (HashMap Text [[ExpansionChunk]])
parseMacroMap v = HashMap.fromList <$> parseList parseMacro v

parseMacro :: Value -> ConfigParser (Text, [[ExpansionChunk]])
parseMacro = parseSections $
  do name     <- sectionReq "name"
     commands <- sectionReqWith (parseList parseMacroCommand) "commands"
     return (name, commands)

parseMacroCommand :: Value -> ConfigParser [ExpansionChunk]
parseMacroCommand v =
  do txt <- parseConfig v
     case parseExpansion txt of
       Nothing -> failure "bad macro line"
       Just ex -> return ex