irc-core-1.0: driver/CommandArgs.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
module CommandArgs where

import Config
import Config.Lens
import Control.Applicative
import Control.Exception
import Control.Monad (when)
import Data.Foldable (traverse_)
import Data.Maybe
import Data.Text (Text)
import Data.Text.Lens (unpacked)
import System.Console.GetOpt
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.IO
import System.IO.Error
import Control.Lens
import qualified Data.Text as Text
import qualified Data.Text.IO as Text

import ServerSettings

defaultConfigPath :: IO FilePath
defaultConfigPath =
  do dir <- getAppUserDataDirectory "glirc"
     return (dir </> "config")

data CommandArgs = CommandArgs
  { _cmdArgNick     :: Maybe String
  , _cmdArgServer   :: String
  , _cmdArgPort     :: Maybe Int
  , _cmdArgHelp     :: Bool
  , _cmdArgReal     :: Maybe String
  , _cmdArgUser     :: Maybe String
  , _cmdArgSaslUser :: Maybe String
  , _cmdArgDebug    :: Maybe FilePath
  , _cmdArgUserInfo :: Maybe String
  , _cmdArgTls      :: Bool
  , _cmdArgTlsClientCert :: Maybe FilePath
  , _cmdArgTlsClientKey  :: Maybe FilePath
  , _cmdArgTlsInsecure   :: Bool
  , _cmdArgConfigFile :: Maybe FilePath
  , _cmdArgConfigValue:: Value
  }

makeLenses ''CommandArgs

getCommandArgs :: IO CommandArgs
getCommandArgs =
  do args <- getArgs

     r <- case getOpt RequireOrder optDescrs args of
            (fs, [server], []) ->
               do let r0 = CommandArgs
                           { _cmdArgServer   = server
                           , _cmdArgReal     = Nothing
                           , _cmdArgUser     = Nothing
                           , _cmdArgNick     = Nothing
                           , _cmdArgUserInfo = Nothing

                           , _cmdArgSaslUser = Nothing
                           , _cmdArgPort     = Nothing
                           , _cmdArgHelp     = False
                           , _cmdArgDebug    = Nothing
                           , _cmdArgTls      = False
                           , _cmdArgTlsClientCert = Nothing
                           , _cmdArgTlsClientKey  = Nothing
                           , _cmdArgTlsInsecure   = False
                           , _cmdArgConfigFile    = Nothing
                           , _cmdArgConfigValue   = Sections []
                           }
                  return (foldl (\acc f -> f acc) r0 fs)

            (_ , _, errs) ->
                 do traverse_ (hPutStrLn stderr) errs
                    help

     when (view cmdArgHelp r) help

     v <- loadConfigValue (view cmdArgConfigFile r)
     return (set cmdArgConfigValue v r)

help :: IO a
help =
  do prog <- getProgName
     let txt = prog ++ " <options> SERVER"
     hPutStr stderr (usageInfo txt optDescrs)
     exitFailure

optDescrs :: [OptDescr (CommandArgs -> CommandArgs)]
optDescrs =
  [ Option "c" [ "config"]   (ReqArg (set cmdArgConfigFile . Just) "FILENAME") "Configuration file path (default ~/.glirc/config)"
  , Option "p" [ "port"]     (ReqArg (set cmdArgPort     . Just . read) "PORT") "IRC Server Port"
  , Option "n" [ "nick"]     (ReqArg (set cmdArgNick     . Just) "NICK") "Nickname"
  , Option "u" [ "user"]     (ReqArg (set cmdArgUser     . Just) "USER") "Username"
  , Option "r" [ "real"]     (ReqArg (set cmdArgReal     . Just) "REAL") "Real Name"
  , Option ""  ["sasl-user"] (ReqArg (set cmdArgSaslUser . Just) "USER") "SASL username"
  , Option "d" [ "debug"]    (ReqArg (set cmdArgDebug    . Just) "FILE") "Debug log filename"
  , Option "i" [ "userinfo"] (ReqArg (set cmdArgUserInfo . Just) "USERINFO") "CTCP USERINFO Response"
  , Option "t" [ "tls"]      (NoArg  (set cmdArgTls True)) "Enable TLS"
  , Option ""  [ "tls-client-cert"] (ReqArg (set cmdArgTlsClientCert . Just) "PATH") "Path to PEM encoded client certificate"
  , Option ""  [ "tls-client-key"] (ReqArg (set cmdArgTlsClientKey . Just) "PATH") "Path to PEM encoded client key"
  , Option ""  [ "tls-insecure"] (NoArg (set cmdArgTlsInsecure True)) "Disable server certificate verification"
  , Option "h" [ "help"]      (NoArg  (set cmdArgHelp True))   "Show help"
  ]

initialServerSettings :: CommandArgs -> IO ServerSettings
initialServerSettings !args =
  do env  <- getEnvironment
     let username     = fromMaybe "" (lookup "USER" env)
         password     = lookup "IRCPASSWORD" env
         saslpassword = lookup "SASLPASSWORD" env
         nick         = fromMaybe username (view cmdArgNick args)
         hostTxt      = Text.pack (view cmdArgServer args)

     return ServerSettings
       { _ssNick           = nick
       , _ssUser           = fromMaybe username
                           $ view cmdArgUser args
                         <|> defaultStr hostTxt "username" args

       , _ssReal           = fromMaybe username
                           $ view cmdArgReal args
                         <|> defaultStr hostTxt "realname" args

       , _ssUserInfo       = fromMaybe username
                           $ view cmdArgUserInfo args
                         <|> defaultStr hostTxt "userinfo" args

       , _ssPassword       = password
                         <|> defaultStr hostTxt "password" args

       , _ssSaslCredential = (saslpassword <|> defaultStr hostTxt "sasl-password" args)
                         <&> \p -> (fromMaybe nick (view cmdArgSaslUser args
                                                <|> defaultStr hostTxt "sasl-username" args), p)

       , _ssHostName       = view cmdArgServer args

       , _ssPort           = fromIntegral <$> view cmdArgPort args
                         <|> fromIntegral <$> defaultNum hostTxt "port" args

       , _ssTls            = view cmdArgTls args
                          || fromMaybe False (defaultBool hostTxt "tls" args)

       , _ssTlsInsecure    = view cmdArgTlsInsecure args

       , _ssTlsClientCert  = view cmdArgTlsClientCert args
                         <|> defaultStr hostTxt "tls-client-cert" args

       , _ssTlsClientKey   = view cmdArgTlsClientKey args
                         <|> defaultStr hostTxt "tls-client-key" args
       }


loadConfigValue :: Maybe FilePath -> IO Value
loadConfigValue mbFp =
  case mbFp of
    Just fp -> process fp
    Nothing ->
      do fp <- defaultConfigPath
         process fp
           `catch` \e ->
           if isDoesNotExistError e
             then return emptyConfig
             else throwIO e
  where
  emptyConfig = Sections []

  process fp =
    do raw <- Text.readFile fp
       case parse raw of
         Right v -> return v
         Left errMsg ->
           do hPutStrLn stderr "Configuration error"
              hPutStrLn stderr (fp ++ ":" ++ errMsg)
              exitFailure

-- | Apply a function to the 'Bool' contained inside the given
-- 'Value' when it is a @Bool@.
bool :: Applicative f => (Bool -> f Bool) -> Value -> f Value
bool = atom . _Bool

-- | Map 'True' to @"yes"@ and 'False' to @"no"@
_Bool :: Prism' Atom Bool
_Bool = prism'
          (\b -> if b then "yes" else "no")
          (\a -> case a of
                   "yes" -> Just True
                   "no"  -> Just False
                   _     -> Nothing)

------------------------------------------------------------------------
-- Look up settings for a given server from the config
------------------------------------------------------------------------

hostnameMatch :: Text -> Value -> Bool
hostnameMatch = elemOf (key "hostname" . text)

configPath :: (Applicative f, Contravariant f) => Text -> Text -> LensLike' f Value Value
configPath hostname name =
  failing (key "servers" . values . filtered (hostnameMatch hostname) . key name)
          (key "defaults" . key name)

defaultStr :: Text -> Text -> CommandArgs -> Maybe String
defaultStr  hostname i = preview (cmdArgConfigValue . configPath hostname i . text . unpacked)

defaultBool :: Text -> Text -> CommandArgs -> Maybe Bool
defaultBool hostname i = preview (cmdArgConfigValue . configPath hostname i . bool)

defaultNum :: Text -> Text -> CommandArgs -> Maybe Integer
defaultNum  hostname i = preview (cmdArgConfigValue . configPath hostname i . number)