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

{-# LANGUAGE OverloadedStrings #-}

module Pipes.IRC.Server.IrcMonad
where

import           Control.Lens
import           Control.Monad.RWS
import           Data.ByteString.Char8    (ByteString)
import qualified Data.ByteString.Char8    as BS
import qualified Data.Map                 as M
import           Data.Maybe               (catMaybes, fromJust, isJust)
import qualified Data.Set                 as S

import           Pipes.IRC.Message.Types
import           Pipes.IRC.Server.Channel
import           Pipes.IRC.Server.Types
import           Pipes.IRC.Server.User

-- * IrcUser management

mkUser :: IrcMonad IrcUser
mkUser = do
  conn <- use clientConn
  srvname <- view ircHostName
  return $ newUser srvname conn

-- * Pretty Printing

ppServiceName :: ServiceName -> ByteString
ppServiceName = BS.pack

ppHostPreference :: HostPreference -> ByteString
ppHostPreference hp = case hp of
  HostAny  -> "*"
  HostIPv4 -> "*4"
  HostIPv6 -> "*6"
  Host hn  -> BS.pack hn

-- * Monadic utilities

useChan :: ChanKey -> IrcMonad (Maybe IrcChannel)
useChan cname = fmap (M.lookup cname) $ use (clientServer . ircChannels)

useNick :: IrcMonad (Maybe NickKey)
useNick = do
  regState <- use clientReg
  return $ case regState of
    Unreg _ (Just nn) _       -> Just nn
    RegUser (NickName nn _ _) -> Just nn
    _                         -> Nothing

validateNick :: NickKey -> IrcMonad Bool
validateNick nickname = do
  nickSet <- use $ clientServer . ircNicks
  if S.member nickname nickSet
   then do
      tellNumeric err_nicknameinuse [nickname, ":Nickname is already in use."]
      return False
   else return True

channelTargets :: ChanKey -> IrcMonad [Int]
channelTargets chname = do
  srv <- use clientServer
  Just mynick <- useNick
  let cUsers chan = S.elems (S.delete mynick $ chan ^. chanUsers)
  let chmap = srv ^. ircChannels
  case M.lookup chname chmap of
    Just chan -> fmap catMaybes $ forM (cUsers chan) userTarget
    _         -> do tellNumeric err_nosuchnick [chname, ":No such nick/channel"]
                    return []

userTarget :: NickKey -> IrcMonad (Maybe Int)
userTarget uname = do
  srv <- use clientServer
  let umap = srv ^. ircUsers
  case M.lookup uname umap of
    Just u -> return . Just $ u ^. userConn
    _      -> do tellNumeric err_nosuchnick [uname, ":No such nick/channel"]
                 return Nothing

findReceivers :: [ByteString] -> IrcMonad [([Int], ByteString)]
findReceivers rcvNames =
  fmap catMaybes $ forM rcvNames $ \name ->
    if BS.head name == '#'
     then do
      cids <- channelTargets name
      return $ case cids of
        [] -> Nothing
        cs -> Just (cs, name)
     else do
      cid <- userTarget name
      return $ case cid of
        Just c  -> Just ([c], name)
        Nothing -> Nothing

fwdMsg :: IrcMessage -> [([Int], ByteString)] -> IrcMonad ()
fwdMsg msg rcvs = forM_ rcvs $ \(cId, n) -> do
  -- replace multiple targets with the single target we're doing
  let m = msg{ params = n : tail (params msg) }
  tell [Msg m cId]

fwdMsgNoReplace :: IrcMessage -> [([Int], ByteString)] -> IrcMonad ()
fwdMsgNoReplace msg rcvs = do
  m <- addUserPrefix msg
  forM_ rcvs $ \(cId, _) -> tell [Msg m cId]


addUserPrefix :: IrcMessage -> IrcMonad IrcMessage
addUserPrefix msg = do
  regState <- use clientReg
  return $ case regState ^? regdNick of
    Just nickname -> msg{ prefix = Just . Right $ nickname }
    _             -> msg{ prefix = Nothing }

chanEcho :: [ChanKey] -> IrcMessage -> IrcMonad ()
chanEcho chans iMsg = do
  msg <- addUserPrefix iMsg
  findReceivers chans >>= fwdMsg msg

allChanEcho :: IrcMessage -> IrcMonad ()
allChanEcho iMsg = do
  mNick <- useNick
  when (isJust mNick) $ do
    let nn = fromJust mNick
    mUser <- use $ clientServer . ircUsers . at nn
    when (isJust mUser) $ do
      let usr = fromJust mUser
      let chans = S.elems $ usr ^. userChannels
      chanEcho chans iMsg

-- * Adding responses to the Writer portion of the monad

tellYOURHOST :: NickKey -> IrcMonad ()
tellYOURHOST nickname = do
  srvname <- view ircHostName
  srvhost <- view ircHost
  srvport <- view ircPort
  version <- use $ clientServer . ircVersion
  let hostStr = ppHostPreference srvhost
      portStr = ppServiceName srvport
  tellNumeric rpl_yourhost
    [ nickname
    , BS.concat [ ":Your host is ", srvname
                , "[", hostStr, "/", portStr, "], "
                , "running version ", version ]
    ]

tellMOTD :: NickKey -> IrcMonad ()
tellMOTD nickname = do
  motd <- view ircMotd
  tellNumeric rpl_motdstart [nickname, ":- Message of the Day -"]
  forM_ motd $ \line ->
    tellNumeric rpl_motd [nickname, ":- " `BS.append` line]
  tellNumeric rpl_endofmotd [nickname, ":End of MOTD"]

tellWELCOME :: NickKey -> IrcMonad ()
tellWELCOME nickname = do
  srvname <- view ircHostName
  tellNumeric rpl_welcome [ nickname
                          , BS.append ":Welcome to IRC on " srvname ]

tellTOPIC :: ChanKey -> IrcMonad ()
tellTOPIC cname = do
  chan <- use $ clientServer . ircChannels . at cname
  case chan of
    Just ch -> when (isJust $ ch ^. chanTopic) $
                 tellNumeric rpl_topic [cname, fromJust $ ch ^. chanTopic]
    Nothing -> return ()

tellNAMES :: [ChanKey] -> IrcMonad ()
tellNAMES cnames = do
  Just nn <- useNick
  forM_ cnames $ \cname -> do
    mChan <- use $ clientServer . ircChannels . at cname
    case mChan of
      Just chan -> do
        let chanType = chanSigil chan
        nickL <- forM (S.elems $ chan ^. chanUsers) $ \uname ->
          return $ BS.append (chanUserSigil uname chan) uname
        let cUsers = BS.append ":" (BS.intercalate " " nickL)
        tellNumeric rpl_namreply [nn, chanType, cname, cUsers]
        tellNumeric rpl_endofnames [nn, head cnames, ":End of /NAMES list"]
      Nothing -> return ()

tellPrefixedCommand :: IrcCommand -> [IrcParam] -> IrcMonad ()
tellPrefixedCommand reply desc = do
  srvname <- view ircHostName
  connId <- use clientConn
  let msg = IrcMessage (Just $ Left srvname) (Left reply) desc
  tell [Msg msg [connId]]

tellCommand :: IrcCommand -> [IrcParam] -> IrcMonad ()
tellCommand reply desc = do
  connId <- use clientConn
  let msg = IrcMessage Nothing (Left reply) desc
  tell [Msg msg [connId]]

tellNumeric :: IrcReply -> [IrcParam] -> IrcMonad ()
tellNumeric reply desc = do
  srvname <- view ircHostName
  connId  <- use clientConn
  let msg = IrcMessage (Just $ Left srvname) (Right reply) desc
  tell [Msg msg [connId]]
  return ()