content: -- | The plugin-level IRC interface.
  
  module Lambdabot.Plugin.IRC.IRC (ircPlugin) where
  
  import Lambdabot.IRC
  import Lambdabot.Logging
  import Lambdabot.Monad
  import Lambdabot.Plugin
  import Lambdabot.Util
  import Lambdabot.Config.IRC
  
  import Control.Concurrent.Lifted
  import qualified Control.Concurrent.SSem as SSem
  import Control.Exception.Lifted as E (SomeException(..), throwIO, catch)
  import Control.Monad
  import Control.Monad.Trans
  import Control.Monad.State
  import qualified Data.ByteString.Char8 as P
  import Data.List
  import Data.List.Split
  import qualified Data.Map as M
  import Lambdabot.Util.Network (connectTo')
  import Network.Socket (PortNumber)
  import System.IO
  import System.Timeout.Lifted
  import Data.IORef
  
  data IRCState =
      IRCState {
          password :: Maybe String
      }
  
  type IRC = ModuleT IRCState LB
  
  ircPlugin :: Module IRCState
  ircPlugin = newModule
      { moduleCmds = return
          [ (command "irc-connect")
              { privileged = True
              , help = say "irc-connect tag host portnum nickname userinfo.  connect to an irc server"
              , process = \rest ->
                  case splitOn " " rest of
                      tag:hostn:portn:nickn:uix -> do
                          pn <- fromInteger `fmap` readM portn
                          lift (online tag hostn pn nickn (intercalate " " uix))
                      _ -> say "Not enough parameters!"
              }
          , (command "irc-persist-connect")
              { privileged = True
              , help = say "irc-persist-connect tag host portnum nickname userinfo.  connect to an irc server and reconnect on network failures"
              , process = \rest ->
                  case splitOn " " rest of
                      tag:hostn:portn:nickn:uix -> do
                          pn <- fromInteger `fmap` readM portn
                          lift (online tag hostn pn nickn (intercalate " " uix))
                          lift $ lift $ modify $ \state' -> state' { ircPersists = M.insert tag True $ ircPersists state' }
                      _ -> say "Not enough parameters!"
              }
          , (command "irc-password")
              { privileged = True
              , help = say "irc-password pwd.  set password for next irc-connect command"
              , process = \rest ->
                  case splitOn " " rest of
                      pwd:_ -> do
                          modifyMS (\ms -> ms{ password = Just pwd })
                      _ -> say "Not enough parameters!"
              }
          ]
      , moduleDefState = return $ IRCState{ password = Nothing }
      }
  
  ----------------------------------------------------------------------
  -- Encoding and decoding of messages
  
  -- | 'encodeMessage' takes a message and converts it to a function.
  --   giving this function a string will attach the string to the message
  --   and output a string containing IRC protocol commands ready for writing
  --   on the outgoing stream socket.
  encodeMessage :: IrcMessage -> String -> String
  encodeMessage msg
    = encodePrefix (ircMsgPrefix msg) . encodeCommand (ircMsgCommand msg)
            . encodeParams (ircMsgParams msg)
    where
      encodePrefix [] = id
      encodePrefix prefix = showChar ':' . showString' prefix . showChar ' '
  
      encodeCommand cmd = showString cmd
  
      encodeParams [] = id
      encodeParams (p:ps) = showChar ' ' . showString' p . encodeParams ps
  
      -- IrcMessage is supposed to contain strings that are lists of bytes, but
      -- if a plugin messes up the encoding then we may end up with arbitrary
      -- Unicode codepoints. This is dangerous (\x10a would produce a newline!),
      -- so we sanitize the message here.
      showString' = showString . map (\c -> if c > '\xFF' then '?' else c)
  
  -- | 'decodeMessage' Takes an input line from the IRC protocol stream
  --   and decodes it into a message.  TODO: this has too many parameters.
  decodeMessage :: String -> String -> String -> IrcMessage
  decodeMessage svr lbn line =
      let (prefix, rest1) = decodePrefix (,) line
          (cmd, rest2)    = decodeCmd (,) rest1
          params          = decodeParams rest2
      in IrcMessage { ircMsgServer = svr, ircMsgLBName = lbn, ircMsgPrefix = prefix,
                      ircMsgCommand = cmd, ircMsgParams = params }
    where
      decodePrefix k (':':cs) = decodePrefix' k cs
        where decodePrefix' j ""       = j "" ""
              decodePrefix' j (' ':ds) = j "" ds
              decodePrefix' j (c:ds)   = decodePrefix' (j . (c:)) ds
  
      decodePrefix k cs = k "" cs
  
      decodeCmd k []       = k "" ""
      decodeCmd k (' ':cs) = k "" cs
      decodeCmd k (c:cs)   = decodeCmd (k . (c:)) cs
  
      decodeParams :: String -> [String]
      decodeParams xs = decodeParams' [] [] xs
        where
          decodeParams' param params []
            | null param = reverse params
            | otherwise  = reverse (reverse param : params)
          decodeParams' param params (' ' : cs)
            | null param = decodeParams' [] params cs
            | otherwise  = decodeParams' [] (reverse param : params) cs
          decodeParams' param params rest@(c@':' : cs)
            | null param = reverse (rest : params)
            | otherwise  = decodeParams' (c:param) params cs
          decodeParams' param params (c:cs) = decodeParams' (c:param) params cs
  
  ircSignOn :: String -> Nick -> Maybe String -> String -> LB ()
  ircSignOn svr nickn pwd ircname = do
      maybe (return ()) (\pwd' -> send $ pass (nTag nickn) pwd') pwd
      send $ user (nTag nickn) (nName nickn) svr ircname
      send $ setNick nickn
  
  ------------------------------------------------------------------------
  --
  -- Lambdabot is mostly synchronous.  We have a main loop, which reads
  -- messages and forks threads to execute commands (which write responses).
  -- OR
  -- We have a main loop which reads offline commands, and synchronously
  -- interprets them.
  
  online :: String -> String -> PortNumber -> String -> String -> IRC ()
  online tag hostn portnum nickn ui = do
      pwd <- password `fmap` readMS
      modifyMS $ \ms -> ms{ password = Nothing }
  
      let online' = do
          sock    <- io $ connectTo' hostn portnum
          io $ hSetBuffering sock NoBuffering
          -- Implements flood control: RFC 2813, section 5.8
          sem1    <- io $ SSem.new 0
          sem2    <- io $ SSem.new 4 -- one extra token stays in the MVar
          sendmv  <- io newEmptyMVar
          pongref <- io $ newIORef False
          io . void . fork . forever $ do
              SSem.wait sem1
              threadDelay 2000000
              SSem.signal sem2
          io . void . fork . forever $ do
              SSem.wait sem2
              putMVar sendmv ()
              SSem.signal sem1
          fin <- io $ SSem.new 0
          E.catch
              (registerServer tag (io . sendMsg sock sendmv fin))
              (\err@SomeException{} -> io (hClose sock) >> E.throwIO err)
          lb $ ircSignOn hostn (Nick tag nickn) pwd ui
          ready <- io $ SSem.new 0
          lb $ void $ forkFinally
              (E.catch
                  (readerLoop tag nickn pongref sock ready)
                  (\e@SomeException{} -> errorM (show e)))
              (const $ io $ SSem.signal fin)
          void $ forkFinally
              (E.catch
                  (pingPongDelay >> pingPongLoop tag hostn pongref sock)
                  (\e@SomeException{} -> errorM (show e)))
              (const $ io $ SSem.signal fin)
          void $ fork $ do
              io $ SSem.wait fin
              unregisterServer tag
              io $ hClose sock
              io $ SSem.signal ready
              delay <- getConfig reconnectDelay
              let retry = do
                  continue <- lift $ gets $ \st -> (M.member tag $ ircPersists st) && not (M.member tag $ ircServerMap st)
                  if continue
                      then do
                          E.catch online'
                              (\e@SomeException{} -> do
                                  errorM (show e)
                                  io $ threadDelay delay
                                  retry
                              )
                      else do
                          chans <- lift $ gets ircChannels
                          forM_ (M.keys chans) $ \chan ->
                              when (nTag (getCN chan) == tag) $
                              lift $ modify $ \state' -> state' { ircChannels = M.delete chan $ ircChannels state' }
  
              retry
          watch <- io $ fork $ do
              threadDelay 10000000
              errorM "Welcome timeout!"
              SSem.signal fin
          io $ SSem.wait ready
          killThread watch
  
      online'
  
  pingPongDelay :: IRC ()
  pingPongDelay = io $ threadDelay 120000000
  
  pingPongLoop :: String -> String -> IORef Bool -> Handle -> IRC ()
  pingPongLoop tag hostn pongref sock = do
      io $ writeIORef pongref False
      io $ P.hPut sock $ P.pack $ "PING " ++ hostn ++ "\r\n"
      pingPongDelay
      pong <- io $ readIORef pongref
      if pong
          then pingPongLoop tag hostn pongref sock
          else errorM "Ping timeout."
  
  readerLoop :: String -> String -> IORef Bool -> Handle -> SSem.SSem -> LB ()
  readerLoop tag nickn pongref sock ready = forever $ do
      line <- io $ hGetLine sock
      let line' = filter (`notElem` "\r\n") line
      if "PING " `isPrefixOf` line'
          then io $ P.hPut sock $ P.pack $ "PONG " ++ drop 5 line' ++ "\r\n"
          else void . fork . void . timeout 15000000 $ do
              let msg = decodeMessage tag nickn line'
              if ircMsgCommand msg == "PONG"
                  then io $ writeIORef pongref True
                  else do
                      when (ircMsgCommand msg == "001") $ io $ SSem.signal ready
                      received msg
  
  sendMsg :: Handle -> MVar () -> SSem.SSem -> IrcMessage -> IO ()
  sendMsg sock mv fin msg =
      E.catch (do takeMVar mv
                  P.hPut sock $ P.pack $ encodeMessage msg "\r\n")
              (\err -> do errorM (show (err :: IOError))
                          SSem.signal fin)
  