content: {-# Language OverloadedStrings #-}
  
  {-|
  Module      : Irc.Message
  Description : High-level representation of IRC messages
  Copyright   : (c) Eric Mertens, 2016
  License     : ISC
  Maintainer  : emertens@gmail.com
  
  This module defines high-level IRC commands. Commands are interpreted
  and their arguments are extracted into the appropriate types.
  
  -}
  
  module Irc.Message
    (
    -- * High-level messages
      IrcMsg(..)
    , CapCmd(..)
    , CapMore(..)
    , cookIrcMsg
  
    -- * Properties of messages
    , MessageTarget(..)
    , ircMsgText
    , msgTarget
    , msgActor
    , msgSource
  
    -- * Helper functions
    , isNickChar
    , nickSplit
    , computeMaxMessageLength
    , capCmdText
  
    , Source(..)
    , srcFromUserInfo
    ) where
  
  import           Control.Monad
  import           Data.Function
  import           Data.Maybe
  import           Data.Text (Text)
  import qualified Data.Text as Text
  import           Data.Text.Read as Text
  import           Irc.Identifier
  import           Irc.RawIrcMsg
  import           Irc.UserInfo
  import           Irc.Codes
  import           View
  
  -- | High-level IRC message representation
  data IrcMsg
    = UnknownMsg !RawIrcMsg -- ^ pass-through for unhandled messages
    | Reply !Text !ReplyCode [Text] -- ^ server code arguments
    | Nick !Source !Identifier -- ^ old new
    | Join !Source !Identifier !Text !Text -- ^ user channel account account gecos
    | Part !Source !Identifier (Maybe Text) -- ^ user channel reason
    | Quit !Source (Maybe Text) -- ^ user reason
    | Kick !Source !Identifier !Identifier !Text -- ^ kicker channel kickee comment
    | Kill !Source !Identifier !Text -- ^ killer killee reason
    | Topic !Source !Identifier !Text -- ^ user channel topic
    | Privmsg !Source !Identifier !Text -- ^ source target txt
    | Ctcp !Source !Identifier !Text !Text -- ^ source target command txt
    | CtcpNotice !Source !Identifier !Text !Text -- ^ source target command txt
    | Notice !Source !Identifier !Text -- ^ source target txt
    | Mode !Source !Identifier [Text] -- ^ source target txt
    | Authenticate !Text -- ^ parameters
    | Cap !CapCmd -- ^ cap command and parameters
    | Ping [Text] -- ^ parameters
    | Pong [Text] -- ^ parameters
    | Error !Text -- ^ message
    | BatchStart !Text !Text [Text] -- ^ reference-id type parameters
    | BatchEnd !Text -- ^ reference-id
    | Account !Source !Text -- ^ user account name changed (account-notify extension)
    | Chghost !Source !Text !Text -- ^ Target, new username and new hostname
    | Wallops  !Source !Text -- ^ Braodcast message: Source, message
    | Invite !Source !Identifier !Identifier -- ^ sender target channel
    | Away !Source (Maybe Text)
    | Tagmsg !Source !Identifier -- ^ source target
    deriving Show
  
  data Source = Source { srcUser :: {-# UNPACK #-}!UserInfo, srcAcct :: !Text, srcOper :: !Text, srcIdentified :: !Bool }
    deriving Show
  
  data CapMore = CapMore | CapDone
    deriving (Show, Read, Eq, Ord)
  
  -- | Sub-commands of the CAP command sent by server
  data CapCmd
    = CapLs !CapMore [(Text, Maybe Text)] -- ^ list of supported caps
    | CapList [Text] -- ^ list of active caps
    | CapAck [Text] -- ^ request accepted
    | CapNak [Text] -- ^ request denied
    | CapNew [(Text, Maybe Text)] -- ^ new capability available (cap-notify extension)
    | CapDel [Text] -- ^ capability removed (cap-notify extension)
    deriving (Show, Read, Eq, Ord)
  
  -- | Match command text to structured cap sub-command
  cookCapCmd :: Text -> [Text] -> Maybe CapCmd
  cookCapCmd cmd args =
    case (cmd, args) of
      ("LS"  , ["*", caps]) -> Just (CapLs CapMore (splitCapList caps))
      ("LS"  , [     caps]) -> Just (CapLs CapDone (splitCapList caps))
      ("LIST", [     caps]) -> Just (CapList (Text.words caps))
      ("ACK" , [     caps]) -> Just (CapAck (Text.words caps))
      ("NAK" , [     caps]) -> Just (CapNak (Text.words caps))
      ("NEW" , [     caps]) -> Just (CapNew (splitCapList caps))
      ("DEL" , [     caps]) -> Just (CapDel (Text.words caps))
      _                     -> Nothing
  
  msgSource :: RawIrcMsg -> Maybe Source
  msgSource msg =
    case view msgPrefix msg of
      Nothing -> Nothing
      Just p -> Just Source{ srcUser = p, srcAcct = acct, srcIdentified = identified, srcOper = oper }
        where
          acct = 
            case [a | TagEntry "account" a <- view msgTags msg ] of
              []  -> ""
              a:_ -> a
          identified = not (null [() | TagEntry "solanum.chat/identified" _ <- view msgTags msg ])
          oper =
            case [a | TagEntry "solanum.chat/oper" a <- view msgTags msg ] of
              []  -> ""
              a:_ -> a
  
  -- | Wrap a 'UserInfo' in a 'Source' with all other fields of the 'Source'
  -- set to defualts.
  srcFromUserInfo :: UserInfo -> Source
  srcFromUserInfo ui =
    Source { srcUser = ui, srcAcct = "", srcIdentified = False, srcOper = ""}
  
  -- | Interpret a low-level 'RawIrcMsg' as a high-level 'IrcMsg'.
  -- Messages that can't be understood are wrapped in 'UnknownMsg'.
  cookIrcMsg :: RawIrcMsg -> IrcMsg
  cookIrcMsg msg =
    case view msgCommand msg of
      cmd | Just user <- view msgPrefix msg
          , Right (n,"") <- decimal cmd ->
          Reply (idText (userNick user)) (ReplyCode n) (view msgParams msg)
      "CAP" | _target:cmdTxt:rest <- view msgParams msg
            , Just cmd <- cookCapCmd cmdTxt rest -> Cap cmd
  
      "AUTHENTICATE" | x:_ <- view msgParams msg ->
          Authenticate x
  
      "PING" -> Ping (view msgParams msg)
      "PONG" -> Pong (view msgParams msg)
  
      "PRIVMSG" | Just source <- msgSource msg
             , [chan,txt]   <- view msgParams msg ->
  
             case parseCtcp txt of
               Just (cmd,args) -> Ctcp source (mkId chan) (Text.toUpper cmd) args
               Nothing         -> Privmsg source (mkId chan) txt
  
      "NOTICE" | Just source <- msgSource msg
             , [chan,txt]    <- view msgParams msg ->
  
             case parseCtcp txt of
               Just (cmd,args) -> CtcpNotice source (mkId chan) (Text.toUpper cmd) args
               Nothing         -> Notice source (mkId chan) txt
  
      "JOIN" | Just source <- msgSource msg
             , chan:rest <- view msgParams msg
             , let (a, r) = case rest of
                              [acct, real] -> (acct, real)
                              _            -> ("", "") ->
             Join source (mkId chan) a r
  
      "QUIT" | Just source <- msgSource msg
             , reasons   <- view msgParams msg ->
             Quit source (listToMaybe reasons)
  
      "PART" | Just source <- msgSource msg
             , chan:reasons <- view msgParams msg ->
             Part source (mkId chan) (listToMaybe reasons)
  
      "NICK"  | Just source <- msgSource msg
              , newNick:_ <- view msgParams msg ->
             Nick source (mkId newNick)
  
      "KICK"  | Just source <- msgSource msg
              , [chan,nick,reason] <- view msgParams msg ->
             Kick source (mkId chan) (mkId nick) reason
  
      "KILL"  | Just source <- msgSource msg
              , [nick,reason] <- view msgParams msg ->
             Kill source (mkId nick) reason
  
      "TOPIC" | Just source <- msgSource msg
              , [chan,topic] <- view msgParams msg ->
              Topic source (mkId chan) topic
  
      "MODE"  | Just source <- msgSource msg
              , target:modes <- view msgParams msg ->
              Mode source (mkId target) modes
  
      "ERROR" | [reason] <- view msgParams msg ->
              Error reason
  
      "BATCH" | refid : ty : params <- view msgParams msg
              , Just ('+',refid') <- Text.uncons refid ->
              BatchStart refid' ty params
  
      "BATCH" | [refid] <- view msgParams msg
              , Just ('-',refid') <- Text.uncons refid ->
              BatchEnd refid'
  
      "ACCOUNT" | Just source <- msgSource msg
                , [acct] <- view msgParams msg ->
        Account source (if acct == "*" then "" else acct)
  
      "CHGHOST" | Just source <- msgSource msg
                , [newuser, newhost] <- view msgParams msg ->
        Chghost source newuser newhost
  
      "WALLOPS" | Just source <- msgSource msg
                , [txt] <- view msgParams msg ->
        Wallops source txt
  
      "INVITE" | Just source <- msgSource msg
               , [target, channel] <- view msgParams msg ->
        Invite source (mkId target) (mkId channel)
  
      "AWAY" | Just source <- msgSource msg
             , message <- view msgParams msg ->
             Away source (listToMaybe message)
  
      "TAGMSG"
        | Just source <- msgSource msg
        , [target] <- view msgParams msg ->
        Tagmsg source (mkId target)
  
  
      _      -> UnknownMsg msg
  
  -- | Parse a CTCP encoded message:
  --
  -- @\^ACOMMAND arguments\^A@
  parseCtcp :: Text -> Maybe (Text, Text)
  parseCtcp txt =
    do txt1 <- Text.stripSuffix "\^A" =<< Text.stripPrefix "\^A" txt
       let (cmd,args) = Text.break (==' ') txt1
       guard (not (Text.null cmd))
       return (cmd, Text.drop 1 args)
  
  
  -- | Targets used to direct a message to a window for display
  data MessageTarget
    = TargetUser     !Identifier -- ^ Metadata update for a user
    | TargetWindow   !Identifier -- ^ Directed message to channel or from user
    | TargetNetwork              -- ^ Network-level message
    deriving (Show)
  
  -- | Target information for the window that could be appropriate to
  -- display this message in.
  msgTarget :: Identifier -> IrcMsg -> MessageTarget
  msgTarget me msg =
    case msg of
      UnknownMsg{}             -> TargetNetwork
      Nick user _              -> TargetUser (userNick (srcUser user))
      Mode _ tgt _ | tgt == me -> TargetNetwork
                   | otherwise -> TargetWindow tgt
      Join _ chan _ _          -> TargetWindow chan
      Part _ chan _            -> TargetWindow chan
      Quit user _              -> TargetUser (userNick (srcUser user))
      Kick _ chan _ _          -> TargetWindow chan
      Kill{}                   -> TargetNetwork
      Topic _ chan _           -> TargetWindow chan
      Invite{}                 -> TargetNetwork
      Privmsg src tgt _        -> directed (srcUser src) tgt
      Ctcp src tgt _ _         -> directed (srcUser src) tgt
      CtcpNotice src tgt _ _   -> directed (srcUser src) tgt
      Notice  src tgt _        -> directed (srcUser src) tgt
      Authenticate{}           -> TargetNetwork
      Ping{}                   -> TargetNetwork
      Pong{}                   -> TargetNetwork
      Error{}                  -> TargetNetwork
      Cap{}                    -> TargetNetwork
      Reply _ code args        -> replyTarget code args
      BatchStart{}             -> TargetNetwork
      BatchEnd{}               -> TargetNetwork
      Account user _           -> TargetUser (userNick (srcUser user))
      Chghost user _ _         -> TargetUser (userNick (srcUser user))
      Wallops _ _              -> TargetNetwork
      Away user _              -> TargetUser (userNick (srcUser user))
      Tagmsg src tgt           -> directed (srcUser src) tgt
    where
      directed src tgt
        | Text.null (userHost src) = TargetNetwork -- server message
        | tgt == me = TargetWindow (userNick src)
        | otherwise = TargetWindow tgt
  
      replyTarget RPL_TOPIC    (_:chan:_)   = TargetWindow (mkId chan)
      replyTarget RPL_INVITING (_:_:chan:_) = TargetWindow (mkId chan)
      replyTarget RPL_NOWAWAY  (who:_)      = TargetUser (mkId who)
      replyTarget RPL_UNAWAY   (who:_)      = TargetUser (mkId who)
      replyTarget _             _           = TargetNetwork
  
  -- | 'UserInfo' of the user responsible for a message.
  msgActor :: IrcMsg -> Maybe Source
  msgActor msg =
    case msg of
      UnknownMsg{}  -> Nothing
      Reply{}       -> Nothing
      Nick x _      -> Just x
      Join x _ _ _  -> Just x
      Part x _ _    -> Just x
      Quit x _      -> Just x
      Kick x _ _ _  -> Just x
      Kill x _ _    -> Just x
      Topic x _ _   -> Just x
      Privmsg x _ _ -> Just x
      Invite x _ _  -> Just x
      Ctcp x _ _ _  -> Just x
      CtcpNotice x _ _ _ -> Just x
      Notice x _ _  -> Just x
      Mode x _ _    -> Just x
      Account x _   -> Just x
      Authenticate{}-> Nothing
      Ping{}        -> Nothing
      Pong{}        -> Nothing
      Error{}       -> Nothing
      Cap{}         -> Nothing
      BatchStart{}  -> Nothing
      BatchEnd{}    -> Nothing
      Chghost x _ _ -> Just x
      Wallops x _   -> Just x
      Away x _      -> Just x
      Tagmsg x _    -> Just x
  
  renderSource :: Source -> Text
  renderSource (Source u "" _ _) = renderUserInfo u
  renderSource (Source u a _ _) = renderUserInfo u <> "(" <> a <> ")"
  
  -- | Text representation of an IRC message to be used for matching with
  -- regular expressions.
  ircMsgText :: IrcMsg -> Text
  ircMsgText msg =
    case msg of
      UnknownMsg raw -> Text.unwords (view msgCommand raw : view msgParams raw)
      Reply srv (ReplyCode n) xs -> Text.unwords (srv : Text.pack (show n) : xs)
      Nick x y       -> Text.unwords [renderSource x, idText y]
      Join x _ _ _   -> renderSource x
      Part x _ mb    -> Text.unwords (renderSource x : maybeToList mb)
      Quit x mb      -> Text.unwords (renderSource x : maybeToList mb)
      Kick x _ z r   -> Text.unwords [renderSource x, idText z, r]
      Kill x z r     -> Text.unwords [renderSource x, idText z, r]
      Topic x _ t    -> Text.unwords [renderSource x, t]
      Privmsg x _ t  -> Text.unwords [renderSource x, t]
      Ctcp x _ c t   -> Text.unwords [renderSource x, c, t]
      CtcpNotice x _ c t -> Text.unwords [renderSource x, c, t]
      Notice x _ t   -> Text.unwords [renderSource x, t]
      Mode x _ xs    -> Text.unwords (renderSource x:"set mode":xs)
      Ping xs        -> Text.unwords xs
      Pong xs        -> Text.unwords xs
      Cap cmd        -> capCmdText cmd
      Error t        -> t
      Account x a    -> Text.unwords [renderSource x, a]
      Authenticate{} -> ""
      BatchStart{}   -> ""
      BatchEnd{}     -> ""
      Invite{}       -> ""
      Chghost x a b  -> Text.unwords [renderSource x, a, b]
      Wallops x t    -> Text.unwords [renderSource x, t]
      Away x (Just t) -> Text.unwords [renderSource x, "away", t]
      Away x Nothing  -> Text.unwords [renderSource x, "back"]
      Tagmsg x _     -> renderSource x
  
  capCmdText :: CapCmd -> Text
  capCmdText cmd =
    case cmd of
      CapLs more caps -> capMoreText more <> capUnsplitCaps caps
      CapNew     caps -> capUnsplitCaps caps
      CapList    caps -> Text.unwords caps
      CapAck     caps -> Text.unwords caps
      CapNak     caps -> Text.unwords caps
      CapDel     caps -> Text.unwords caps
  
  capMoreText :: CapMore -> Text
  capMoreText CapDone = ""
  capMoreText CapMore = "* "
  
  capUnsplitCaps :: [(Text, Maybe Text)] -> Text
  capUnsplitCaps xs = Text.unwords [ k <> maybe "" ("=" <>) v | (k, v) <- xs ]
  
  -- nickname   =  ( letter / special ) *8( letter / digit / special / "-" )
  -- letter     =  %x41-5A / %x61-7A       ; A-Z / a-z
  -- digit      =  %x30-39                 ; 0-9
  -- special    =  %x5B-60 / %x7B-7D
  isNickChar :: Char -> Bool
  isNickChar x = '0' <= x && x <= '9'
                || 'A' <= x && x <= '}'
                || '-' == x
  
  -- | Split a nick into text parts group by whether or not those parts are valid
  -- nickname characters.
  nickSplit :: Text -> [Text]
  nickSplit = Text.groupBy ((==) `on` isNickChar)
  
  -- | Maximum length computation for the message part for
  -- privmsg and notice. Note that the need for the limit is because
  -- the server will limit the length of the message sent out to each
  -- client, not just the length of the messages it will recieve.
  --
  -- Note that the length is on the *encoded message* which is UTF-8
  -- The calculation isn't using UTF-8 on the userinfo part because
  -- I'm assuming that the channel name and userinfo are all ASCII
  --
  -- @
  -- :my!user@info PRIVMSG #channel :messagebody\r\n
  -- @
  computeMaxMessageLength :: UserInfo -> Text -> Int
  computeMaxMessageLength myUserInfo target
    = 512 -- max IRC command
    - Text.length (renderUserInfo myUserInfo)
    - length (": PRIVMSG  :\r\n"::String)
    - Text.length target
  
  splitCapList :: Text -> [(Text, Maybe Text)]
  splitCapList caps =
    [ (name, value)
      | kv <- Text.words caps
      , let (name, v) = Text.break ('=' ==) kv
      , let value | Text.null v = Nothing
                  | otherwise   = Just $! Text.tail v
      ]
  