pipes-irc-server/src/Pipes/IRC/Server/MessageHandler.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

module Pipes.IRC.Server.MessageHandler
  ( ircMessageHandler )
where

import           Control.Applicative       ((<|>))
import           Control.Error
import           Control.Lens
import           Control.Monad.RWS
import qualified Data.ByteString.Char8     as BS
import           Data.Set                  as S

import           Pipes.IRC.Message.Types
import           Pipes.IRC.Server.IrcMonad
import           Pipes.IRC.Server.Types
import           Pipes.IRC.Server.Util

ircMessageHandler :: IrcMessage -> IrcMonad ()
ircMessageHandler msg =
  -- drop messages that have prefixes (until we have Server links)
  when (isNothing $ prefix msg) $ do
    cReg <- use clientReg
    case cReg of
      Unreg   {} -> unregHandler msg
      RegUser {} -> regHandler   msg
    return ()

unregHandler :: IrcMessage -> IrcMonad ()
unregHandler msg@IrcMessage{..} =
  case command of
    Left PASS -> unregPASS msg
    Left NICK -> unregNICK msg
    Left USER -> unregUSER msg
    Left PONG -> handlePONG msg
    Left PING -> handlePING msg
    Left QUIT -> handleQUIT msg
    _         -> return ()

regHandler :: IrcMessage -> IrcMonad ()
regHandler msg@IrcMessage{..} = do
  pMsg <- addUserPrefix msg
  case command of
    Left AWAY    -> return ()
    Left INVITE  -> return ()
    Left JOIN    -> handleJOIN pMsg
    Left KICK    -> return ()
    Left KILL    -> return ()
    Left LIST    -> return ()
    Left MODE    -> return ()
    Left NAMES   -> return ()
    Left NICK    -> handleNICK pMsg
    Left NOTICE  -> return ()
    Left PART    -> handlePART pMsg
    Left PING    -> handlePING pMsg
    Left PONG    -> handlePONG pMsg
    Left PRIVMSG -> handlePRIVMSG pMsg
    Left TOPIC   -> return ()
    Left QUIT    -> handleQUIT pMsg
    Left WHO     -> return ()
    Left WHOIS   -> return ()
    Left WHOWAS  -> return ()
    _            -> return ()

-- * Handlers for messages coming from unregistered users

unregPASS :: IrcMessage -> IrcMonad ()
unregPASS IrcMessage{..} = runValidation $ do
  checkParamLength "PASS" params 1
  lift $ storePassKey (head params)

unregNICK :: IrcMessage -> IrcMonad ()
unregNICK IrcMessage{..} = runValidation $ do
  nickname <- checkSuppliedNickname params
  checkNickFree nickname
  lift $ do
    storeNickKey nickname
    reserveNick nickname
    tryRegistration

unregUSER :: IrcMessage -> IrcMonad ()
unregUSER IrcMessage{..} = runValidation $ do
  checkParamLength "USER" params 4
  lift $ do
    storeUserName (head params)
    tryRegistration

tryRegistration :: IrcMonad ()
tryRegistration = do
  regState <- use clientReg
  hostname <- use clientHost
  case regState of
    Unreg _ (Just nickname) (Just name) -> do
      usr <- mkUser
      registerUser (RegUser $ NickName nickname (Just name) hostname)
      associateUserWithNick usr nickname

      tellWELCOME  nickname
      tellYOURHOST nickname
      tellMOTD     nickname
    _                                   -> return ()

-- * Handlers for messages coming from registered users

handlePING :: IrcMessage -> IrcMonad ()
handlePING _ = do
  srvname <- view ircHostName
  tellCommand PONG [":" <> srvname]

handlePONG :: IrcMessage -> IrcMonad ()
handlePONG _ = do
  cid <- use clientConn
  tell [Pong cid]

-- JOIN, MODE, KICK, PART, QUIT and of course PRIVMSG/NOTICE need to be
-- echoed to channels that the user belongs to

handleQUIT :: IrcMessage -> IrcMonad ()
handleQUIT IrcMessage{..} = doQuit (headMay params)

handleJOIN :: IrcMessage -> IrcMonad ()
handleJOIN msg@IrcMessage{..} = runValidation $ do
  checkParamLength "JOIN" params 1
  nn <- checkRegistration
  lift $ case params of
    -- Joining channel "0" really means to PART all channels
    ["0"]   -> do cs <- useUserChans nn
                  doPart msg{command=Left PART} (S.elems cs) Nothing
    -- No passwords were supplied
    [cs]    -> doJoin msg $ zipParams (parseParamList cs) []
    -- Some number of passwords were supplied
    cs:ks:_ -> doJoin msg $ zipParams (parseParamList cs) (parseParamList ks)

handlePART :: IrcMessage -> IrcMonad ()
handlePART msg@IrcMessage{..} = runValidation $ do
  checkParamLength "PART" params 1
  lift $ case params of
    [cs]    -> doPart msg (parseParamList cs) Nothing
    cs:pm:_ -> doPart msg (parseParamList cs) (Just pm)

doJoin :: IrcMessage -> [(ChanKey, Maybe PassKey)] -> IrcMonad ()
doJoin msg chans = forM_ chans $ \(c, k) -> runValidation $ do
  nick <- checkRegistration
  -- If the channel is absent, joining it will create it
  checkChannelAbsence c
  -- If it already exists, do some sanity checks first
    <|> do chan <- checkChannelPresence c
           checkUserNotOnChan nick c chan
           checkInvitation nick c chan
           checkPassKey k c chan

  lift $ do
    joinNickToChan nick c
    tellTOPIC c
    tellNAMES [c]
    chanEcho [c] msg
    findReceivers [nick] >>= fwdMsgNoReplace msg

doPart :: IrcMessage -> [BS.ByteString] -> Maybe BS.ByteString -> IrcMonad ()
doPart msg chans pmsg = forM_ chans $ \c -> runValidation $ do
  nn <- checkRegistration
  ch <- checkChannelPresence c
  checkUserOnChan nn c ch
  let newMsg = msg{params = c : maybe [] ((:[]) . BS.append ":") pmsg}

  lift $ do
    chanEcho [c] newMsg
    findReceivers [nn] >>= fwdMsgNoReplace msg
    partNickFromChan nn c

handlePRIVMSG :: IrcMessage -> IrcMonad ()
handlePRIVMSG msg@IrcMessage{..} = do
  case params of
    []       -> tellNumeric err_norecipient []
    [_]      -> tellNumeric err_notexttosend []
    rsp:_:_  -> let rs = parseParamList rsp
                in findReceivers rs >>= fwdMsg msg
  return ()

handleNICK :: IrcMessage -> IrcMonad ()
handleNICK msg@IrcMessage{..} = runValidation $ do
  nn <- checkRegistration
  newNick <- checkSuppliedNickname params
  checkNickFree newNick
  lift $ do
    cs <- allChans
    findReceivers (cs <> [nn]) >>= fwdMsgNoReplace msg
    changeNick nn newNick