{- This file is part of irc-fun-messages.
 -
 - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

{-# LANGUAGE OverloadedStrings #-}

module Network.Irc.Messages.Internal.Serialize
    ( -- * Building
      buildMessage
    , buildReply
    , messageFromReply
      -- * Serializing
    , serializeMessage
    , serializeReply
    )
where

import Data.Bits (bit, zeroBits, (.|.))
import Data.Maybe (maybeToList)
import Data.Monoid ((<>))
import Data.Text (Text)
import Network.Irc.Messages.Mask (serializeMask)
import Network.Irc.Messages.Internal.Util
import Network.Irc.Types

import qualified Data.Text as T

-------------------------------------------------------------------------------
-- Building
-------------------------------------------------------------------------------

showAddr :: Address -> Text
showAddr (IPv4 t) = t
showAddr (IPv6 t) = t

showHost :: Host -> Text
showHost (HostByName hn)   = unHostname hn
showHost (HostByAddr addr) = showAddr addr
showHost (HostCloak t)     = t

showTargetMask :: TargetMask -> Text
showTargetMask (HostMask m)   = '#' `T.cons` serializeMask m
showTargetMask (ServerMask m) = '$' `T.cons` serializeMask m

showTarget :: MessageTarget -> Text
showTarget (ChannelTarget chan) = unChannel chan
showTarget
    (UserTarget
        Nothing
        (Just (UserAddress (Username user) mhost))
        (Just server)
    ) =
    let u = case mhost of
                Nothing   -> user
                Just host -> user <> "%" <> showHost host
    in  u <> "@" <> unHostname server
showTarget
    (UserTarget
        Nothing
        (Just (UserAddress (Username user) (Just host)))
        Nothing
    ) =
    user <> "%" <> showHost host
showTarget
    (UserTarget
        (Just (Nickname nick))
        Nothing
        Nothing
    ) =
    nick
showTarget
    (UserTarget
        (Just (Nickname nick))
        (Just (UserAddress (Username user) (Just host)))
        Nothing
    ) =
    nick <> "!" <> user <> "@" <> showHost host
showTarget (MaskTarget mt) = showTargetMask mt
showTarget _ = "invalid_target"

-- Fill command name and parameters from specific message
buildMessage' :: Message -> (Text, [Parameter])
buildMessage' msg =
    case msg of
        PassMessage pass ->
            ("PASS", [unPassword pass])
        NickMessage nn ->
            ("NICK", [unNickname nn])
        UserMessage un i w rn ->
            ( "USER"
            , [ unUsername un
              , showt $ modebit 3 i .|. modebit 2 w
              , "*"
              , unRealName rn
              ]
            )
            where
            modebit n b = if b then bit n else zeroBits :: Int
        OperMessage _un _p ->
            ("????", error "Not implemented")
        UserModeMessage _n _remove _add ->
            ("????", error "Not implemented")
        ServiceMessage _n _m _s ->
            ("????", error "Not implemented")
        QuitMessage reason ->
            ("QUIT", perhaps $ fmap unComment reason)
        SQuitMessage _s _t ->
            ("????", error "Not implemented")
        JoinMessage Nothing ->
            ("JOIN", ["0"])
        JoinMessage (Just (chans, keys)) ->
            ( "JOIN"
            , T.intercalate "," (map unChannel chans) :
              if null keys
                then []
                else [T.intercalate "," $ map unChannelKey keys]
            )
        PartMessage chans reason ->
            ( "PART"
            , T.intercalate "," (map unChannel chans) ?: fmap unComment reason
            )
        ChannelModeMessage _remove _add ->
            ("????", error "Not implemented")
        TopicMessage chan topic ->
            ("TOPIC", unChannel chan ?: fmap unChannelTopic topic)
        NamesMessage chans serv ->
            ( "NAMES"
            , T.intercalate "," (map unChannel chans) ?: fmap unHostname serv
            )
        ListMessage _chans _serv ->
            ("????", error "Not implemented")
        InviteMessage _nn _chan ->
            ("????", error "Not implemented")
        KickMessage _chans _users _s ->
            ("????", error "Not implemented")
        PrivMsgMessage tgt (MsgContent mc) ->
            ("PRIVMSG", [showTarget tgt, mc])
        PrivActionMessage tgt (MsgContent mc) ->
            ("PRIVMSG", [showTarget tgt, "\1ACTION " <> mc <> "\1"])
        NoticeMessage tgt (MsgContent mc) ->
            ("NOTICE", [showTarget tgt, mc])
        MotdMessage _serv ->
            ("????", error "Not implemented")
        LusersMessage _serv ->
            ("????", error "Not implemented")
        VersionMessage _serv ->
            ("????", error "Not implemented")
        StatsMessage _x ->
            ("????", error "Not implemented")
        LinksMessage _x ->
            ("????", error "Not implemented")
        TimeMessage _serv ->
            ("????", error "Not implemented")
        ConnectMessage _serv _portn _sm ->
            ("????", error "Not implemented")
        TraceMessage _t ->
            ("????", error "Not implemented")
        AdminMessage _t ->
            ("????", error "Not implemented")
        InfoMessage _t ->
            ("????", error "Not implemented")
        ServlistMessage _ ->
            ("????", error "Not implemented")
        SQueryMessage _ _ ->
            ("????", error "Not implemented")
        WhoMessage _ ->
            ("????", error "Not implemented")
        WhoisMessage _ _ ->
            ("????", error "Not implemented")
        WhowasMessage _ _ ->
            ("????", error "Not implemented")
        KillMessage _ _ ->
            ("????", error "Not implemented")
        PingMessage s1 s2 ->
            ("PING", unHostname s1 ?: fmap unHostname s2)
        PongMessage s1 s2 ->
            ("PONG", unHostname s1 ?: fmap unHostname s2)
        ErrorMessage _ ->
            ("????", error "Not implemented")
        AwayMessage _ ->
            ("????", error "Not implemented")
        RehashMessage ->
            ("????", error "Not implemented")
        DieMessage ->
            ("????", error "Not implemented")
        RestartMessage ->
            ("????", error "Not implemented")
        SummonMessage _ _ ->
            ("????", error "Not implemented")
        UsersMessage _ ->
            ("????", error "Not implemented")
        WallopsMessage _ ->
            ("????", error "Not implemented")
        UserhostMessage _ ->
            ("????", error "Not implemented")
        IsonMessage _ ->
            ("????", error "Not implemented")
    where
    perhaps = maybeToList
    x ?: my = x : perhaps my

-- | Fill a generic message record using a specific message's details.
buildMessage :: SpecificMessage -> GenericMessage
buildMessage (SpecificMessage pref msg) =
    let (cmd, ps) = buildMessage' msg
    in  GenericMessage pref (NamedCmd $ CmdName cmd) ps

channelPrivacyChar :: ChannelPrivacy -> Char
channelPrivacyChar Secret  = '@'
channelPrivacyChar Private = '*'
channelPrivacyChar Public  = '='

privilegeChar :: Privilege -> Maybe Char
privilegeChar Regular  = Nothing
privilegeChar Voice    = Just '+'
privilegeChar Operator = Just '@'

-- Fill reply code, target and parameters from specific reply
buildReply' :: Reply -> (Int, [Parameter])
buildReply' reply =
    case reply of
        NamesReply priv chan pns ->
            ( 353
            , [ T.singleton $ channelPrivacyChar priv
              , unChannel chan
              , T.unwords $
                map
                    (\ (p, (Nickname n)) ->
                        maybe n (`T.cons` n) $ privilegeChar p
                    )
                    pns
              ]
            )
        _ -> error "Not implemented"

-- | Fill a generic reply record using a specific reply's details.
buildReply :: SpecificReply -> GenericReply
buildReply (SpecificReply sender tgt reply) =
    let (code, ps) = buildReply' reply
    in  GenericReply sender (CmdNumber code) tgt ps

-- | Convert a reply, which is a message with a numeric command name, into a
-- generic message value.
messageFromReply :: GenericReply -> GenericMessage
messageFromReply reply = GenericMessage
    { gmPrefix  = Just $ PrefixServer $ grSender reply
    , gmCommand = NumericCmd $ grCode reply
    , gmParams  = target' reply : grParams reply
    }
    where
    target' (GenericReply { grTarget = NickTarget n })   = unNickname n
    target' (GenericReply { grTarget = ServerTarget s }) = unHostname s

-------------------------------------------------------------------------------
-- Serializing
-------------------------------------------------------------------------------

serializePrefix :: Prefix -> Text
serializePrefix (PrefixServer sn)    = unHostname sn
serializePrefix (PrefixNick n mu mh) =
    unNickname n                                 <>
    maybe "" ('!' `T.cons`) (fmap unUsername mu) <>
    maybe "" (('@' `T.cons`) . showHost) mh

serializeCommand :: Command -> Text
serializeCommand (NamedCmd t)   = unCmdName t
serializeCommand (NumericCmd n) = showt $ unCmdNumber n

serializeParams :: [Parameter] -> Text
serializeParams = f . map (\ p -> if T.null p then "(?)" else p)
    where
    f [] = ""
    f l  =
        let (ps, p) = (init l, last l)
        in  T.concat (map (' ' `T.cons`) ps) <> " " <>
            if T.head p == ':' || T.any (== ' ') p
                then ':' `T.cons` p
                else p

-- | Write a message into an IRC protocol message formatted string.
serializeMessage :: GenericMessage -> Text
serializeMessage msg = T.concat
    [ maybe
        T.empty
        (\ p -> ':' `T.cons` serializePrefix p `T.snoc` ' ')
        (gmPrefix msg)
    , serializeCommand $ gmCommand msg
    , serializeParams $ gmParams msg
    , "\r\n"
    ]

-- | Write a reply into an IRC protocol message formatted string.
--
-- This is essentially a combination of 'messageFromReply' and
-- 'serializeMessage'.
serializeReply :: GenericReply -> Text
serializeReply = serializeMessage . messageFromReply