content: {-# LANGUAGE UnicodeSyntax, PatternGuards, RecordWildCards #-}
  import qualified Network.Socket as Net
  import qualified System.Environment
  import qualified Request
  import qualified RequestEval
  import qualified Sys
  import qualified Data.Map as Map
  import qualified Network.BSD
  import qualified Cxx.Show
  import qualified IRC
  import qualified Data.ByteString
  
  import IRC (Command(..), Prefix(..))
  import Control.Exception (bracketOnError)
  import System.IO (hSetBinaryMode, hFlush, Handle, IOMode(..), stdout)
  import Control.Monad (forever, when)
  import Control.Arrow (first)
  import Control.Monad.State (execStateT, lift, StateT, get)
  import Control.Monad.Writer (execWriterT, tell)
  import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..), getOpt, usageInfo)
  import System.Locale.SetLocale (setLocale, Category(..))
  import Text.Regex (Regex, subRegex, mkRegexWithOpts) -- Todo: Text.Regex truncates Char's >256. Get rid of it.
  import Data.Char (isSpace, isPrint, isDigit)
  import Data.List (isSuffixOf, isPrefixOf)
  import Data.Map (Map)
  import Data.SetOps
  import Util ((.), elemBy, caselessStringEq, maybeM, describe_new_output,
    orElse, full_evaluate, withResource, mapState',
    strip_utf8_bom, none, takeBack, replaceInfix, classify_diagnostic)
  import Sys (rate_limiter)
  
  import Prelude hiding ((.))
  import Prelude.Unicode hiding ((∈))
  
  data IrcBotConfig = IrcBotConfig
    { server :: Net.HostName, port :: Net.PortNumber
    , password :: Maybe String
    , max_response_length :: Int
    , chans :: [String], key_chans :: [(String, String)]
    , nick :: String, nick_pass :: Maybe String, alternate_nick :: String
    , also_respond_to :: [String]
    , allow_nickless_requests_in :: [String]
    , blacklist :: [String]
    , no_output_msg :: String
    , channel_response_prefix :: String
        -- A first occurrence of the string "nick" is replaced with the nick of the requester.
    , join_trigger :: Maybe IRC.Message
        -- Defaults to RPL_WELCOME. Can be set to NickServ/cloak confirmations and such.
    , censor :: [Regex]
    , rate_limit_messages, rate_limit_window :: Int
    , serve_private_requests :: Bool
    , clang_by_default :: Bool
    } deriving Read
  
  instance Read Regex where
    readsPrec i s = first (\r → mkRegexWithOpts r True False) . readsPrec i s
  
  data Opt = Help deriving Eq
  
  optsDesc :: [OptDescr Opt]
  optsDesc = [Option "h" ["help"] (NoArg Help) "Display this help and exit."]
  
  help :: String
  help = usageInfo "Usage: sudo geordi-irc [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
  
  do_censor :: IrcBotConfig → String → String
  do_censor cfg s = foldr (\r t → subRegex r t "<censored>") s (censor cfg)
  
  main :: IO ()
  main = do
   setLocale LC_ALL (Just "")
   opts ← getArgs
   if Help ∈ opts then putStrLn help else do
    cfg@IrcBotConfig{..} ← read . getContents
    full_evaluate $ do_censor cfg "abc" -- So that any mkRegex failures occur before we start connecting.
    putStrLn $ "Connecting to " ++ server ++ ":" ++ show port
    withResource (connect server (fromIntegral port)) $ \h → do
     putStrLn "Connected"
     evalRequest ← RequestEval.evaluator
     limit_rate ← rate_limiter rate_limit_messages rate_limit_window
     let send m = limit_rate >> IRC.send h (IRC.Message Nothing m)
     maybeM password $ send . Pass
     send $ Nick nick
     send $ User nick 0 nick
     flip execStateT (∅) $ forever $ do
       l ← lift $ Data.ByteString.hGetLine h
       case IRC.decode l of
         Nothing → lift $ putStrLn "Malformed IRC message."
         Just m → do
           lift $ print m
           r ← on_msg evalRequest cfg (Data.ByteString.length l == 511) m
           lift $ mapM_ print r >> hFlush stdout >> mapM_ send r
     return ()
  
  discarded_lines_description :: Int → String
  discarded_lines_description s =
    " [+ " ++ show s ++ " discarded line" ++ (if s == 1 then "" else "s") ++ "]"
  
  describe_lines :: [String] → String
  describe_lines [] = ""
  describe_lines (x:xs)
    | xs == [] || classify_diagnostic x == Just "error" = x
    | otherwise = x ++ discarded_lines_description (length xs)
  
  data ChannelMemory = ChannelMemory
    { context :: Request.Context
    , last_outputs :: [String]
    , last_nonrequest :: String }
  type ChannelMemoryMap = Map String ChannelMemory
  
  emptyChannelMemory :: IrcBotConfig → ChannelMemory
  emptyChannelMemory IrcBotConfig{..} = ChannelMemory
    { context = Request.Context Cxx.Show.noHighlighting clang_by_default []
    , last_outputs = []
    , last_nonrequest = "" }
  
  is_request :: IrcBotConfig → Where → String → Maybe String
  is_request IrcBotConfig{..} _ s
    | Just (n, r) ← Request.is_addressed_request s
    , any (caselessStringEq n) (nick : alternate_nick : also_respond_to)
      = Just r
  is_request IrcBotConfig{..} (InChannel c) s
    | elemBy caselessStringEq c allow_nickless_requests_in
    , Just r ← Request.is_nickless_request s
      = Just r
  is_request _ Private s = Just s
  is_request _ _ _ = Nothing
  
  type Reason = String
  data Permission = Allow | Deny (Maybe Reason)
  data Where = Private | InChannel String
  
  request_allowed :: IrcBotConfig → String → Maybe IRC.UserName → Maybe IRC.ServerName → Where → Permission
  request_allowed cfg _ _ _ Private | not (serve_private_requests cfg) =
    Deny $ Just "This bot does not serve private requests."
  request_allowed cfg nickname _ _ _ | nickname ∈ blacklist cfg = Deny Nothing
  request_allowed _ _ _ _ _ = Allow
  
  type Eraser = String → Maybe String
  
  digits :: Eraser
  digits (x : y : s) | isDigit x, isDigit y = Just s
  digits (x : s) | isDigit x = Just s
  digits _ = Nothing
  
  color_code :: Eraser
  color_code ('\x3' : ',' : s) = digits s
  color_code ('\x3' : s) = case digits s of
    Just (',' : s') → digits s'
    Just s' → Just s'
    Nothing → Just s
  color_code _ = Nothing
  
  apply_eraser :: Eraser → String → String
  apply_eraser _ [] = []
  apply_eraser p s@(h:t) = p s `orElse` (h : apply_eraser p t)
  
  strip_color_codes :: String → String
  strip_color_codes = apply_eraser color_code
    {- Todo: The above is *much* more naturally expressed as:
          subRegex r s "" where r = mkRegex "\x3(,[[:digit:]]{1,2}|[[:digit:]]{1,2}(,[[:digit:]]{1,2})?)?"
    Unfortunately, Text.Regex is broken: it truncates Char's, resulting in spurious matches. -}
  
  version_response :: String
  version_response = "Geordi C++ bot - http://www.eelis.net/geordi/"
  
  on_msg :: (Functor m, Monad m) ⇒
    (String → Request.Context → [(String, String)] → m Request.Response) → IrcBotConfig → Bool → IRC.Message → StateT ChannelMemoryMap m [IRC.Command]
  on_msg eval cfg@IrcBotConfig{..} full_size m@(IRC.Message prefix c) = execWriterT $ do
    when (join_trigger == Just m) join
    case c of
      Quit | Just (NickName n _ _) ← prefix, n == nick → send $ Nick nick
      PrivMsg _ "\1VERSION\1" | Just (NickName n _ _) ← prefix →
        send $ Notice n $ "\1VERSION " ++ version_response ++ "\1"
      NickNameInUse → send $ Nick alternate_nick
      Ping x → send $ Pong x
      PrivMsg _ ('\1':_) → return ()
      PrivMsg to txt' | Just (NickName who muser mserver) ← prefix → do
        let
          txt = filter isPrint $ strip_color_codes $ strip_utf8_bom txt'
          private = elemBy caselessStringEq to [nick, alternate_nick]
          w = if private then Private else InChannel to
          wher = if private then who else to
          reply s = send $ PrivMsg wher $ take max_response_length $
              (if private then id else (replaceInfix "nick" who channel_response_prefix ++)) $
              if null s then no_output_msg else do_censor cfg s
        mem@ChannelMemory{..} ← (`orElse` emptyChannelMemory cfg) . Map.lookup wher . lift get
        case (dropWhile isSpace . is_request cfg w txt) of
          Nothing → lift $ mapState' $ insert (wher, mem{last_nonrequest = txt'})
          Just r' → case request_allowed cfg who muser mserver w of
           Deny reason → maybeM reason reply
           Allow → do
            let r = if r' == "^" then last_nonrequest else r'
            if full_size ∧ none (`isSuffixOf` r) ["}", ";"] then reply $ "Request likely truncated after `" ++ takeBack 15 r ++ "`." else do
              -- The "}"/";" test gains a reduction in false positives at the cost of an increase in false negatives.
            let extra_env = [("GEORDI_REQUESTER", who), ("GEORDI_WHERE", wher)]
            Request.Response history_modification output ← lift $ lift $ eval r context extra_env
            let output' = describe_lines $ dropWhile null $ lines output
            let lo = take 50 last_outputs
            lift $ mapState' $ insert (wher, mem
              { context = maybe id Request.modify_history history_modification context
              , last_outputs = output' : lo })
            reply $ describe_new_output lo output'
      Welcome → do
        maybeM nick_pass $ send . PrivMsg "NickServ" . ("identify " ++)
        when (join_trigger == Nothing) join
      Invite _ _ → join
      _ → return ()
    where
      send = tell . (:[])
      join = send $ Join chans key_chans
  
  connect :: Net.HostName → Net.PortNumber → IO Handle
    -- Mostly copied from Network.connectTo. We can't use that one because we want to set SO_KEEPALIVE (and related) options on the socket, which can't be done on a Handle.
  connect host portn = do
   proto ← Network.BSD.getProtocolNumber "tcp"
   let hints = Net.defaultHints { Net.addrSocketType = Net.Stream, Net.addrProtocol = proto }
   target ← head . Net.getAddrInfo (Just hints) (Just host) (Just $ show portn)
   bracketOnError (Net.socket (Net.addrFamily target) Net.Stream proto) Net.close $ \sock → do
    Sys.setKeepAlive sock 30 10 5
    Net.connect sock (Net.addrAddress target)
    h ← Net.socketToHandle sock ReadWriteMode
    hSetBinaryMode h True
    return h
  