{-# LANGUAGE UnicodeSyntax, PatternGuards #-}

import qualified System.Environment
import qualified XMPP
import qualified MUC
import qualified Sys
import qualified Cxx.Show
import qualified Request
import qualified RequestEval

import Data.Char (ord, toLower, toUpper)
import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..), getOpt, usageInfo)
import System.IO (putStrLn)
import Control.Monad (guard, when, forM_, forever)

import Prelude hiding (catch, (.), readFile, putStrLn, putStr, print)
import Util

type JID = String
type Nick = String

data RoomConfig = RoomConfig { room_nick :: Nick, allow_nickless_requests :: Bool } deriving Read

data BotConfig = BotConfig
  { server, user, pass :: String
  , max_msg_length :: Int
  , no_output_msg :: String
  , blacklist :: [JID] -- These may include a resource part, so that room users may be specified.
  , rate_limit_messages, rate_limit_window :: Int
  , rooms :: [(JID, RoomConfig)]
  } deriving Read

data Opt = Config String | Help deriving Eq

optsDesc :: [OptDescr Opt]
optsDesc =
  [ Option "c" ["config"] (ReqArg Config "<file>") "Load configuration from <file> instead of \"xmpp-config\"."
  , Option "h" ["help"] (NoArg Help) "Display this help and exit."
  ]

help :: String
help = usageInfo "Usage: sudo geordi-xmpp [option]...\nOptions:" optsDesc ++ "\nSee README.xhtml for more information."

getArgs :: IO [Opt]
getArgs = do
  args ← System.Environment.getArgs
  case getOpt RequireOrder optsDesc args of
    (_, _, err:_) → fail $ init err
    (_, w:_, []) → fail $ "superfluous command line argument: " ++ w
    (opts, [], []) → return opts

nicks_match :: Nick → Nick → Bool
nicks_match n (h:t) = n == toLower h : t ∨ n == toUpper h : t
nicks_match _ "" = error "empty nick"

is_request :: RoomConfig → String → Maybe String
is_request (RoomConfig mynick allow_nickless) s
  | Just (n, r) ← Request.is_addressed_request s, nicks_match n mynick = Just r
  | allow_nickless, Just r ← Request.is_short_request s = Just r
  | otherwise = Nothing

output_body :: BotConfig → Request.Response → String
output_body cfg r = xmlEntities $ take (max_msg_length cfg) $ takeWhile (/= '\n') $
  case Request.response_output r of "" → no_output_msg cfg; s → s

main :: IO ()
main = do
  Sys.setlocale_ALL_env
  opts ← getArgs
  if Help `elem` opts then putStrLn help else do
  cfg ← readTypedFile $ findMaybe (\o → case o of Config cf → Just cf; _ → Nothing) opts `orElse` "xmpp-config"
  conn ← XMPP.openStream $ server cfg
  XMPP.getStreamStart conn
  evalRequest ← RequestEval.evaluator Cxx.Show.noHighlighting
  limit_rate ← Sys.rate_limiter (rate_limit_messages cfg) (rate_limit_window cfg)
  XMPP.runXMPP conn $ do
  XMPP.startAuth (user cfg) (server cfg) (pass cfg)
  XMPP.sendPresence
  XMPP.handleVersion "Geordi C++ bot - http://www.eelis.net/geordi/" "-" "-"
  forM_ (rooms cfg) $ \(jid, RoomConfig nick _) → MUC.joinGroupchat nick jid
  forever $ do
  msg ← XMPP.waitForStanza (XMPP.isMessage .&&. XMPP.hasBody .&&. (not . isDelay))
  maybeM (XMPP.getAttr "from" msg) $ \from → do
  when (not $ from `elem` blacklist cfg) $ do
  maybeM (XMPP.getMessageBody msg) $ \body → do
  let
    eval r = XMPP.liftIO $ limit_rate >> output_body cfg . evalRequest r (Request.Context [])
  case XMPP.getAttr "type" msg of
    Just "groupchat"
      | (room, '/' : from_nick) ← span (/= '/') from, Just request ← do
          room_cfg ← lookup room $ rooms cfg
          guard $ room_nick room_cfg /= from_nick
          is_request room_cfg body
        → eval request >>= MUC.sendGroupchatMessage room
    Just "chat" → eval body >>= XMPP.sendMessage from
    Nothing → eval body >>= XMPP.sendMessage from
    _ → return ()

xmlEntities :: String → String
xmlEntities = concatMap (\c → "&#" ++ show (ord c) ++ ";")

isDelay :: XMPP.StanzaPredicate
isDelay = maybe False ((== Just "jabber:x:delay") . XMPP.getAttr "xmlns") . XMPP.xmlPath ["x"]