content: {-# LANGUAGE PatternGuards, FlexibleContexts #-}
  -- | Lambdabot base module. Controls message send and receive
  module Lambdabot.Plugin.Core.Base (basePlugin) where
  
  import Lambdabot.Bot
  import Lambdabot.Command
  import Lambdabot.Config.Core
  import Lambdabot.IRC
  import Lambdabot.Logging
  import Lambdabot.Message
  import Lambdabot.Module
  import Lambdabot.Monad
  import Lambdabot.Nick
  import Lambdabot.Plugin
  import Lambdabot.Util
  
  import Control.Applicative
  import Control.Exception.Lifted as E
  import Control.Monad
  import Control.Monad.Reader
  import Control.Monad.State
  import Data.Char
  import Data.List
  import Data.List.Split
  import qualified Data.Map as M
  import Text.EditDistance
  import Text.Regex.TDFA
  
  type BaseState = GlobalPrivate () ()
  type Base = ModuleT BaseState LB
  
  basePlugin :: Module (GlobalPrivate () ())
  basePlugin = newModule
      { moduleDefState = return $ mkGlobalPrivate 20 ()
      , moduleInit = do
          registerOutputFilter cleanOutput
          registerOutputFilter lineify
          registerOutputFilter cleanOutput
          
          registerCallback "PING"    doPING
          registerCallback "NOTICE"  doNOTICE
          registerCallback "PART"    doPART
          registerCallback "KICK"    doKICK
          registerCallback "JOIN"    doJOIN
          registerCallback "NICK"    doNICK
          registerCallback "MODE"    doMODE
          registerCallback "TOPIC"   doTOPIC
          registerCallback "QUIT"    doQUIT
          registerCallback "PRIVMSG" doPRIVMSG
          registerCallback "001"     doRPL_WELCOME
          
          -- registerCallback "002"     doRPL_YOURHOST
          -- registerCallback "003"     doRPL_CREATED
          -- registerCallback "004"     doRPL_MYINFO
          
          registerCallback "005"     doRPL_BOUNCE
          
          -- registerCallback "250"     doRPL_STATSCONN
          -- registerCallback "251"     doRPL_LUSERCLIENT
          -- registerCallback "252"     doRPL_LUSEROP
          -- registerCallback "253"     doRPL_LUSERUNKNOWN
          -- registerCallback "254"     doRPL_LUSERCHANNELS
          -- registerCallback "255"     doRPL_LUSERME
          -- registerCallback "265"     doRPL_LOCALUSERS
          -- registerCallback "266"     doRPL_GLOBALUSERS
          
          registerCallback "332"     doRPL_TOPIC
          
          -- registerCallback "353"     doRPL_NAMRELY
          -- registerCallback "366"     doRPL_ENDOFNAMES
          -- registerCallback "372"     doRPL_MOTD
          -- registerCallback "375"     doRPL_MOTDSTART
          -- registerCallback "376"     doRPL_ENDOFMOTD
      }
  
  doIGNORE :: IrcMessage -> Base ()
  doIGNORE = debugM . show
  
  doPING :: IrcMessage -> Base ()
  doPING = noticeM . showPingMsg
      where showPingMsg msg = "PING! <" ++ ircMsgServer msg ++ (':' : ircMsgPrefix msg) ++
              "> [" ++ ircMsgCommand msg ++ "] " ++ show (ircMsgParams msg)
  
  -- If this is a "TIME" then we need to pass it over to the localtime plugin
  -- otherwise, dump it to stdout
  doNOTICE :: IrcMessage -> Base ()
  doNOTICE msg
      | isCTCPTimeReply   = doPRIVMSG (timeReply msg)
          -- TODO: need to say which module to run the privmsg in
      | otherwise         = noticeM (show body)
      where
          body = ircMsgParams msg
          isCTCPTimeReply = ":\SOHTIME" `isPrefixOf` (last body)
  
  doJOIN :: IrcMessage -> Base ()
  doJOIN msg 
      | lambdabotName msg /= nick msg = doIGNORE msg
      | otherwise                     = do
          let msgArg  = concat (take 1 (ircMsgParams msg))
              chan    = case dropWhile (/= ':') msgArg of
                  []      -> msgArg
                  aloc    -> aloc
              loc = Nick (server msg) (dropWhile (== ':') chan)
          
          -- the empty topic causes problems
          -- TODO: find out what they are and fix them properly
          lb . modify $ \s -> s
              { ircChannels = M.insert  (mkCN loc) "[currently unknown]" (ircChannels s)}
          lb . send $ getTopic loc -- initialize topic
     where 
  
  doPART :: IrcMessage -> Base ()
  doPART msg
    = when (lambdabotName msg == nick msg) $ do
          let body = ircMsgParams msg
              loc = Nick (server msg) (head body)
          lb . modify $ \s -> s
              { ircChannels = M.delete (mkCN loc) (ircChannels s) }
  
  doKICK :: IrcMessage -> Base ()
  doKICK msg
     = do let body = ircMsgParams msg
              loc = Nick (server msg) (body !! 0)
              who = Nick (server msg) (body !! 1)
          when (lambdabotName msg == who) $ do
              noticeM $ fmtNick "" (nick msg) ++ " KICK " ++ fmtNick (server msg) loc ++ " " ++ show (drop 2 body)
              lift $ modify $ \s ->
                  s { ircChannels = M.delete (mkCN loc) (ircChannels s) }
  
  doNICK :: IrcMessage -> Base ()
  doNICK msg
    = doIGNORE msg
  
  doMODE :: IrcMessage -> Base ()
  doMODE msg
    = doIGNORE msg
  
  
  doTOPIC :: IrcMessage -> Base ()
  doTOPIC msg = lb . modify $ \s -> s
      { ircChannels = M.insert (mkCN loc) (tail $ head $ tail $ ircMsgParams msg) (ircChannels s) }
      where loc = Nick (server msg) (head (ircMsgParams msg))
  
  doRPL_WELCOME :: IrcMessage -> Base ()
  doRPL_WELCOME msg = lb $ do
      modify $ \state' -> 
          let persists = if M.findWithDefault True (server msg) (ircPersists state')
                  then ircPersists state'
                  else M.delete (server msg) $ ircPersists state'
           in state' { ircPersists = persists }
      chans <- gets ircChannels
      forM_ (M.keys chans) $ \chan -> do
          let cn = getCN chan
          when (nTag cn == server msg) $ do
              modify $ \state' -> state' { ircChannels = M.delete chan $ ircChannels state' }
              lb $ send $ joinChannel cn
  
  doQUIT :: IrcMessage -> Base ()
  doQUIT msg = doIGNORE msg
  
  doRPL_BOUNCE :: IrcMessage -> Base ()
  doRPL_BOUNCE _msg = debugM "BOUNCE!"
  
  doRPL_TOPIC :: IrcMessage -> Base ()
  doRPL_TOPIC msg -- nearly the same as doTOPIC but has our nick on the front of body
      = do let body = ircMsgParams msg
               loc = Nick (server msg) (body !! 1)
           lb . modify $ \s -> s
              { ircChannels = M.insert (mkCN loc) (tail $ last body) (ircChannels s) }
  
  doPRIVMSG :: IrcMessage -> Base ()
  doPRIVMSG msg = do
      ignored     <- lift $ checkIgnore msg
      commands    <- getConfig commandPrefixes
      
      if ignored
          then doIGNORE msg
          else mapM_ (doPRIVMSG' commands (lambdabotName msg) msg) targets
      where
          alltargets = head (ircMsgParams msg)
          targets = map (parseNick (ircMsgServer msg)) $ splitOn "," alltargets
  
  --
  -- | What does the bot respond to?
  --
  doPRIVMSG' :: [String] -> Nick -> IrcMessage -> Nick -> Base ()
  doPRIVMSG' commands myname msg target
      | myname == target
      = let (cmd, params) = splitFirstWord text
        in doPersonalMsg commands msg target text cmd params
      
      | flip any ":," $ \c -> (fmtNick (ircMsgServer msg) myname ++ [c]) `isPrefixOf` text
      = let Just wholeCmd = maybeCommand (fmtNick (ircMsgServer msg) myname) text
            (cmd, params) = splitFirstWord wholeCmd
        in doPublicMsg commands msg target cmd params
      
      | (commands `arePrefixesOf` text)
      && length text > 1
      && (text !! 1 /= ' ') -- elem of prefixes
      && (not (commands `arePrefixesOf` [text !! 1]) ||
        (length text > 2 && text !! 2 == ' ')) -- ignore @@ prefix, but not the @@ command itself
      = let (cmd, params) = splitFirstWord (dropWhile (==' ') text)
        in doPublicMsg commands msg target cmd params
      
      | otherwise =  doContextualMsg msg target target text
      
      where
          text = tail (head (tail (ircMsgParams msg)))
  
  doPersonalMsg :: [String] -> IrcMessage -> Nick -> String -> String -> String -> Base ()
  doPersonalMsg commands msg target text s r
      | commands `arePrefixesOf` s  = doMsg msg (tail s) r who
      | otherwise                   = doContextualMsg msg target who text
      where
        who = nick msg
  
  doPublicMsg :: [String] -> IrcMessage -> Nick -> String -> String -> Base ()
  doPublicMsg commands msg target s r
      | commands `arePrefixesOf` s  = doMsg msg (tail s) r target
      | otherwise                   = doIGNORE msg
  
  --
  -- normal commands.
  --
  -- check privledges, do any spell correction, dispatch, handling
  -- possible timeouts.
  --
  -- todo, refactor
  --
  doMsg :: IrcMessage -> String -> String -> Nick -> Base ()
  doMsg msg cmd rest towhere = do
      let ircmsg = ircPrivmsg towhere
      allcmds <- lift (gets (M.keys . ircCommands))
      let ms      = filter (isPrefixOf cmd) allcmds
      e <- getConfig editDistanceLimit
      case ms of
          [s] -> docmd msg towhere rest s                  -- a unique prefix
          _ | cmd `elem` ms -> docmd msg towhere rest cmd  -- correct command (usual case)
          _ | otherwise     -> case closests cmd allcmds of
            (n,[s]) | n < e ,  ms == [] -> docmd msg towhere rest s -- unique edit match
            (n,ss)  | n < e || ms /= []            -- some possibilities
                -> lift . ircmsg $ "Maybe you meant: "++showClean(nub(ms++ss))
            _   -> docmd msg towhere rest cmd         -- no prefix, edit distance too far
  
  docmd :: IrcMessage -> Nick -> [Char] -> String -> Base ()
  docmd msg towhere rest cmd' = withPS towhere $ \_ _ -> do
      withCommand cmd'   -- Important.
          (ircPrivmsg towhere "Unknown command, try @list")
          (\theCmd -> do
              name'   <- asks moduleName
  
              hasPrivs <- lb (checkPrivs msg)
              
              -- TODO: handle disabled commands earlier
              -- users should probably see no difference between a
              -- command that is disabled and one that doesn't exist.
              disabled <- elem cmd' <$> getConfig disabledCommands
              let ok = not disabled && (not (privileged theCmd) || hasPrivs)
  
              response <- if not ok
                  then return ["Not enough privileges"]
                  else runCommand theCmd msg towhere cmd' rest
                      `E.catch` \exc@SomeException{} ->
                          return ["Plugin `" ++ name' ++ "' failed with: " ++ show exc]
              
              -- send off our response strings
              -- TODO: expandTab here should probably be an OutputFilter
              lift $ mapM_ (ircPrivmsg towhere . expandTab 8) response
          )
  
  --
  -- contextual messages are all input that isn't an explicit command.
  -- they're passed to all modules (todo, sounds inefficient) for
  -- scanning, and any that implement 'contextual' will reply.
  --
  -- we try to run the contextual functions from all modules, on every
  -- non-command. better hope this is efficient.
  --
  -- Note how we catch any plugin errors here, rather than letting
  -- them bubble back up to the mainloop
  --
  doContextualMsg :: IrcMessage -> Nick -> Nick -> [Char] -> Base ()
  doContextualMsg msg target towhere r = lb (withAllModules (withHandler invokeContextual))
      where
          withHandler x = E.catch x $ \e@SomeException{} -> do
              mName   <- asks moduleName
              debugM ("Module " ++ show mName ++ " failed in contextual handler: " ++ show e)
          
          invokeContextual = do
              m       <- asks theModule
              reply   <- execCmd (contextual m r) msg target "contextual"
              lb $ mapM_ (ircPrivmsg towhere) reply
  
  ------------------------------------------------------------------------
  
  closests :: String -> [String] -> (Int,[String])
  closests pat ss = M.findMin m
      where
          m = M.fromListWith (++) ls
          ls = [ (levenshteinDistance defaultEditCosts pat s, [s]) | s <- ss ]
  
  maybeCommand :: String -> String -> Maybe String
  maybeCommand nm text = mrAfter <$> matchM re text
      where
          re :: Regex
          re = makeRegex (nm ++ "[.:,]*[[:space:]]*")
  
  --
  -- And stuff we don't care about
  --
  
  {-
  doRPL_YOURHOST :: IrcMessage -> LB ()
  doRPL_YOURHOST _msg = return ()
  
  doRPL_CREATED :: IrcMessage -> LB ()
  doRPL_CREATED _msg = return ()
  
  doRPL_MYINFO :: IrcMessage -> LB ()
  doRPL_MYINFO _msg = return ()
  
  doRPL_STATSCONN :: IrcMessage -> LB ()
  doRPL_STATSCONN _msg = return ()
  
  doRPL_LUSERCLIENT :: IrcMessage -> LB ()
  doRPL_LUSERCLIENT _msg = return ()
  
  doRPL_LUSEROP :: IrcMessage -> LB ()
  doRPL_LUSEROP _msg = return ()
  
  doRPL_LUSERUNKNOWN :: IrcMessage -> LB ()
  doRPL_LUSERUNKNOWN _msg = return ()
  
  doRPL_LUSERCHANNELS :: IrcMessage -> LB ()
  doRPL_LUSERCHANNELS _msg = return ()
  
  doRPL_LUSERME :: IrcMessage -> LB ()
  doRPL_LUSERME _msg = return ()
  
  doRPL_LOCALUSERS :: IrcMessage -> LB ()
  doRPL_LOCALUSERS _msg = return ()
  
  doRPL_GLOBALUSERS :: IrcMessage -> LB ()
  doRPL_GLOBALUSERS _msg = return ()
  
  doUNKNOWN :: IrcMessage -> Base ()
  doUNKNOWN msg
      = debugM $ "UNKNOWN> <" ++ msgPrefix msg ++
        "> [" ++ msgCommand msg ++ "] " ++ show (body msg)
  
  doRPL_NAMREPLY :: IrcMessage -> LB ()
  doRPL_NAMREPLY _msg = return ()
  
  doRPL_ENDOFNAMES :: IrcMessage -> LB ()
  doRPL_ENDOFNAMES _msg = return ()
  
  doRPL_MOTD :: IrcMessage -> LB ()
  doRPL_MOTD _msg = return ()
  
  doRPL_MOTDSTART :: IrcMessage -> LB ()
  doRPL_MOTDSTART _msg = return ()
  
  doRPL_ENDOFMOTD :: IrcMessage -> LB ()
  doRPL_ENDOFMOTD _msg = return ()
  -}
  
  -- Initial output filters
  
  -- | For now, this just checks for duplicate empty lines.
  cleanOutput :: Monad m => a -> [String] -> m [String]
  cleanOutput _ msg = return $ remDups True msg'
      where
          remDups True  ([]:xs) =    remDups True xs
          remDups False ([]:xs) = []:remDups True xs
          remDups _     (x: xs) = x: remDups False xs
          remDups _     []      = []
          msg' = map (dropFromEnd isSpace) msg
  
  -- | wrap long lines.
  lineify :: MonadConfig m => a -> [String] -> m [String]
  lineify _ msg = do
      w <- getConfig textWidth
      return (lines (unlines msg) >>= mbreak w)
      where
          -- | break into lines
          mbreak w xs
              | null bs   = [as]
              | otherwise = (as++cs) : filter (not . null) (mbreak w ds)
              where
                  (as,bs) = splitAt (w-n) xs
                  breaks  = filter (not . isAlphaNum . last . fst) $ drop 1 $
                                    take n $ zip (inits bs) (tails bs)
                  (cs,ds) = last $ (take n bs, drop n bs): breaks
                  n = 10
  