/src/IrcBot.hs

  1{-# LANGUAGE UnicodeSyntax, PatternGuards, RecordWildCards #-}
  2import qualified Network.Socket as Net
  3import qualified System.Environment
  4import qualified Request
  5import qualified RequestEval
  6import qualified Sys
  7import qualified Data.Map as Map
  8import qualified Network.BSD
  9import qualified Cxx.Show
 10import qualified IRC
 11import qualified Data.ByteString
 12
 13import IRC (Command(..), Prefix(..))
 14import Control.Exception (bracketOnError)
 15import System.IO (hSetBinaryMode, hFlush, Handle, IOMode(..), stdout)
 16import Control.Monad (forever, when)
 17import Control.Arrow (first)
 18import Control.Monad.State (execStateT, lift, StateT, get)
 19import Control.Monad.Writer (execWriterT, tell)
 20import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..), getOpt, usageInfo)
 21import System.Locale.SetLocale (setLocale, Category(..))
 22import Text.Regex (Regex, subRegex, mkRegexWithOpts) -- Todo: Text.Regex truncates Char's >256. Get rid of it.
 23import Data.Char (isSpace, isPrint, isDigit)
 24import Data.List (isSuffixOf, isPrefixOf)
 25import Data.Map (Map)
 26import Data.SetOps
 27import Util ((.), elemBy, caselessStringEq, maybeM, describe_new_output,
 28  orElse, full_evaluate, withResource, mapState',
 29  strip_utf8_bom, none, takeBack, replaceInfix, classify_diagnostic)
 30import Sys (rate_limiter)
 31
 32import Prelude hiding ((.))
 33import Prelude.Unicode hiding ((∈))
 34
 35data IrcBotConfig = IrcBotConfig
 36  { server :: Net.HostName, port :: Net.PortNumber
 37  , password :: Maybe String
 38  , max_response_length :: Int
 39  , chans :: [String], key_chans :: [(String, String)]
 40  , nick :: String, nick_pass :: Maybe String, alternate_nick :: String
 41  , also_respond_to :: [String]
 42  , allow_nickless_requests_in :: [String]
 43  , blacklist :: [String]
 44  , no_output_msg :: String
 45  , channel_response_prefix :: String
 46      -- A first occurrence of the string "nick" is replaced with the nick of the requester.
 47  , join_trigger :: Maybe IRC.Message
 48      -- Defaults to RPL_WELCOME. Can be set to NickServ/cloak confirmations and such.
 49  , censor :: [Regex]
 50  , rate_limit_messages, rate_limit_window :: Int
 51  , serve_private_requests :: Bool
 52  , clang_by_default :: Bool
 53  } deriving Read
 54
 55instance Read Regex where
 56  readsPrec i s = first (\r → mkRegexWithOpts r True False) . readsPrec i s
 57
 58data Opt = Help deriving Eq
 59
 60optsDesc :: [OptDescr Opt]
 61optsDesc = [Option "h" ["help"] (NoArg Help) "Display this help and exit."]
 62
 63help :: String
 64help = usageInfo "Usage: sudo geordi-irc [option]...\nOptions:" optsDesc ++ "\nSee README.xhtml for more information."
 65
 66getArgs :: IO [Opt]
 67getArgs = do
 68  args ← System.Environment.getArgs
 69  case getOpt RequireOrder optsDesc args of
 70    (_, _, err:_) → fail $ init err
 71    (_, w:_, []) → fail $ "superfluous command line argument: " ++ w
 72    (opts, [], []) → return opts
 73
 74do_censor :: IrcBotConfig → String → String
 75do_censor cfg s = foldr (\r t → subRegex r t "<censored>") s (censor cfg)
 76
 77main :: IO ()
 78main = do
 79 setLocale LC_ALL (Just "")
 80 opts ← getArgs
 81 if Help ∈ opts then putStrLn help else do
 82  cfg@IrcBotConfig{..} ← read . getContents
 83  full_evaluate $ do_censor cfg "abc" -- So that any mkRegex failures occur before we start connecting.
 84  putStrLn $ "Connecting to " ++ server ++ ":" ++ show port
 85  withResource (connect server (fromIntegral port)) $ \h → do
 86   putStrLn "Connected"
 87   evalRequest ← RequestEval.evaluator
 88   limit_rate ← rate_limiter rate_limit_messages rate_limit_window
 89   let send m = limit_rate >> IRC.send h (IRC.Message Nothing m)
 90   maybeM password $ send . Pass
 91   send $ Nick nick
 92   send $ User nick 0 nick
 93   flip execStateT (∅) $ forever $ do
 94     l ← lift $ Data.ByteString.hGetLine h
 95     case IRC.decode l of
 96       Nothing → lift $ putStrLn "Malformed IRC message."
 97       Just m → do
 98         lift $ print m
 99         r ← on_msg evalRequest cfg (Data.ByteString.length l == 511) m
100         lift $ mapM_ print r >> hFlush stdout >> mapM_ send r
101   return ()
102
103discarded_lines_description :: Int → String
104discarded_lines_description s =
105  " [+ " ++ show s ++ " discarded line" ++ (if s == 1 then "" else "s") ++ "]"
106
107describe_lines :: [String] → String
108describe_lines [] = ""
109describe_lines (x:xs)
110  | xs == [] || classify_diagnostic x == Just "error" = x
111  | otherwise = x ++ discarded_lines_description (length xs)
112
113data ChannelMemory = ChannelMemory
114  { context :: Request.Context
115  , last_outputs :: [String]
116  , last_nonrequest :: String }
117type ChannelMemoryMap = Map String ChannelMemory
118
119emptyChannelMemory :: IrcBotConfig → ChannelMemory
120emptyChannelMemory IrcBotConfig{..} = ChannelMemory
121  { context = Request.Context Cxx.Show.noHighlighting clang_by_default []
122  , last_outputs = []
123  , last_nonrequest = "" }
124
125is_request :: IrcBotConfig → Where → String → Maybe String
126is_request IrcBotConfig{..} _ s
127  | Just (n, r) ← Request.is_addressed_request s
128  , any (caselessStringEq n) (nick : alternate_nick : also_respond_to)
129    = Just r
130is_request IrcBotConfig{..} (InChannel c) s
131  | elemBy caselessStringEq c allow_nickless_requests_in
132  , Just r ← Request.is_nickless_request s
133    = Just r
134is_request _ Private s = Just s
135is_request _ _ _ = Nothing
136
137type Reason = String
138data Permission = Allow | Deny (Maybe Reason)
139data Where = Private | InChannel String
140
141request_allowed :: IrcBotConfig → String → Maybe IRC.UserName → Maybe IRC.ServerName → Where → Permission
142request_allowed cfg _ _ _ Private | not (serve_private_requests cfg) =
143  Deny $ Just "This bot does not serve private requests."
144request_allowed cfg nickname _ _ _ | nickname ∈ blacklist cfg = Deny Nothing
145request_allowed _ _ _ _ _ = Allow
146
147type Eraser = String → Maybe String
148
149digits :: Eraser
150digits (x : y : s) | isDigit x, isDigit y = Just s
151digits (x : s) | isDigit x = Just s
152digits _ = Nothing
153
154color_code :: Eraser
155color_code ('\x3' : ',' : s) = digits s
156color_code ('\x3' : s) = case digits s of
157  Just (',' : s') → digits s'
158  Just s' → Just s'
159  Nothing → Just s
160color_code _ = Nothing
161
162apply_eraser :: Eraser → String → String
163apply_eraser _ [] = []
164apply_eraser p s@(h:t) = p s `orElse` (h : apply_eraser p t)
165
166strip_color_codes :: String → String
167strip_color_codes = apply_eraser color_code
168  {- Todo: The above is *much* more naturally expressed as:
169        subRegex r s "" where r = mkRegex "\x3(,[[:digit:]]{1,2}|[[:digit:]]{1,2}(,[[:digit:]]{1,2})?)?"
170  Unfortunately, Text.Regex is broken: it truncates Char's, resulting in spurious matches. -}
171
172version_response :: String
173version_response = "Geordi C++ bot - http://www.eelis.net/geordi/"
174
175on_msg :: (Functor m, Monad m) ⇒
176  (String → Request.Context → [(String, String)] → m Request.Response) → IrcBotConfig → Bool → IRC.Message → StateT ChannelMemoryMap m [IRC.Command]
177on_msg eval cfg@IrcBotConfig{..} full_size m@(IRC.Message prefix c) = execWriterT $ do
178  when (join_trigger == Just m) join
179  case c of
180    Quit | Just (NickName n _ _) ← prefix, n == nick → send $ Nick nick
181    PrivMsg _ "\1VERSION\1" | Just (NickName n _ _) ← prefix →
182      send $ Notice n $ "\1VERSION " ++ version_response ++ "\1"
183    NickNameInUse → send $ Nick alternate_nick
184    Ping x → send $ Pong x
185    PrivMsg _ ('\1':_) → return ()
186    PrivMsg to txt' | Just (NickName who muser mserver) ← prefix → do
187      let
188        txt = filter isPrint $ strip_color_codes $ strip_utf8_bom txt'
189        private = elemBy caselessStringEq to [nick, alternate_nick]
190        w = if private then Private else InChannel to
191        wher = if private then who else to
192        reply s = send $ PrivMsg wher $ take max_response_length $
193            (if private then id else (replaceInfix "nick" who channel_response_prefix ++)) $
194            if null s then no_output_msg else do_censor cfg s
195      mem@ChannelMemory{..} ← (`orElse` emptyChannelMemory cfg) . Map.lookup wher . lift get
196      case (dropWhile isSpace . is_request cfg w txt) of
197        Nothing → lift $ mapState' $ insert (wher, mem{last_nonrequest = txt'})
198        Just r' → case request_allowed cfg who muser mserver w of
199         Deny reason → maybeM reason reply
200         Allow → do
201          let r = if r' == "^" then last_nonrequest else r'
202          if full_size ∧ none (`isSuffixOf` r) ["}", ";"] then reply $ "Request likely truncated after `" ++ takeBack 15 r ++ "`." else do
203            -- The "}"/";" test gains a reduction in false positives at the cost of an increase in false negatives.
204          let extra_env = [("GEORDI_REQUESTER", who), ("GEORDI_WHERE", wher)]
205          Request.Response history_modification output ← lift $ lift $ eval r context extra_env
206          let output' = describe_lines $ dropWhile null $ lines output
207          let lo = take 50 last_outputs
208          lift $ mapState' $ insert (wher, mem
209            { context = maybe id Request.modify_history history_modification context
210            , last_outputs = output' : lo })
211          reply $ describe_new_output lo output'
212    Welcome → do
213      maybeM nick_pass $ send . PrivMsg "NickServ" . ("identify " ++)
214      when (join_trigger == Nothing) join
215    Invite _ _ → join
216    _ → return ()
217  where
218    send = tell . (:[])
219    join = send $ Join chans key_chans
220
221connect :: Net.HostName → Net.PortNumber → IO Handle
222  -- 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.
223connect host portn = do
224 proto ← Network.BSD.getProtocolNumber "tcp"
225 let hints = Net.defaultHints { Net.addrSocketType = Net.Stream, Net.addrProtocol = proto }
226 target ← head . Net.getAddrInfo (Just hints) (Just host) (Just $ show portn)
227 bracketOnError (Net.socket (Net.addrFamily target) Net.Stream proto) Net.close $ \sock → do
228  Sys.setKeepAlive sock 30 10 5
229  Net.connect sock (Net.addrAddress target)
230  h ← Net.socketToHandle sock ReadWriteMode
231  hSetBinaryMode h True
232  return h