{-# LANGUAGE OverloadedStrings #-}

module Pipes.IRC.Server.IrcMonad
where

import           Control.Error
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               (fromJust)
import qualified Data.Set                 as S

import           Pipes.IRC.Message.Types
import           Pipes.IRC.Server.Channel
import           Pipes.IRC.Server.Server
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 = use $ clientServer . ircChannels . at cname

useUserChans :: NickKey -> IrcMonad (S.Set ChanKey)
useUserChans nn =
  use (clientServer . ircUsers . at nn . traverse . userChannels)

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

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

disconnectUser :: Int -> IrcMessage -> IrcMonad ()
disconnectUser cid msg = do
  allChanEcho msg
  tell [Close cid]

-- * Command validation utilities

type ErrParam    = (IrcReply, [IrcParam])
type IrcMonadErr = EitherT ErrParam IrcMonad

tellErr :: Either (IrcReply, [IrcParam]) a -> IrcMonad ()
tellErr (Left (r, ps)) = void $ tellNumeric r ps
tellErr _ = return ()

runValidation :: IrcMonadErr () -> IrcMonad ()
runValidation = tellErr <=< runEitherT

ensure :: Bool -> IrcReply -> [IrcParam] -> IrcMonadErr ()
ensure p r ps = when p $ left (r, ps)

ensureUse :: IrcMonad (Maybe a)  -> ErrParam -> IrcMonadErr a
ensureUse u e = lift u >>= hoistEither . note e

checkParamLength :: BS.ByteString -> [IrcParam] -> Int -> IrcMonadErr ()
checkParamLength cmd ps n =
  ensure (length ps >= n)
    err_needmoreparams [cmd, ":Need more parameters"]

checkSuppliedNickname :: [IrcParam] -> IrcMonadErr NickKey
checkSuppliedNickname ps = do
  ensure (not . null $ ps) err_nonicknamegiven [":must supply a nickname"]
  return (head ps)

checkRegistration :: IrcMonadErr NickKey
checkRegistration =
  ensureUse useNick (err_notregistered, [":You have not registered"])

checkChannelPresence :: ChanKey -> IrcMonadErr IrcChannel
checkChannelPresence ckey =
  ensureUse (useChan ckey) (err_badchannelkey, [ckey, ":No such channel"])

checkUserOnChan :: NickKey -> ChanKey -> IrcChannel -> IrcMonadErr ()
checkUserOnChan nn c ch =
  ensure (chanHasUser nn ch) err_notonchannel [c, ":Not on channel"]

checkUserNotOnChan :: NickKey -> ChanKey -> IrcChannel -> IrcMonadErr ()
checkUserNotOnChan nn c ch =
  ensure (not . chanHasUser nn $ ch) err_notonchannel [c, ":Already on channel"]

checkInvitation :: NickKey -> ChanKey -> IrcChannel -> IrcMonadErr ()
checkInvitation nn c ch = ensure (ircInviteCheck nn ch)
                            err_inviteonlychan [c, ":Cannot join channel (+i)"]

checkPassKey :: Maybe PassKey -> ChanKey -> IrcChannel -> IrcMonadErr ()
checkPassKey k c chan = ensure (ircPassCheck k chan)
                          err_badchannelkey [c, ":Cannot join channel (+k)"]

checkNickFree :: NickKey -> IrcMonadErr ()
checkNickFree nickname = do
  nickSet <- lift (use $ clientServer . ircNicks)
  ensure (S.member nickname nickSet)
         err_nicknameinuse [nickname, ":Nickname is already in use."]

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

renderQuitMsg :: Maybe BS.ByteString -> IrcMonad BS.ByteString
renderQuitMsg (Just msg) = return $ BS.append "Quit: " msg
renderQuitMsg Nothing    = useNick >>= \nickname ->
  return $ case nickname of
    Just n -> BS.append "Quit: " n
    Nothing   -> ""

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 ()