{- This file is part of irc-fun-messages. - - Written in 2015 by fr33domlover . - - ♡ 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 - . -} module Network.IRC.Fun.Messages.Internal.Serialize ( -- * Building buildMessage , buildReply , messageFromReply -- * Serializing , serializeMessage , serializeReply ) where import Data.Bits (bit, zeroBits, (.|.)) --import Data.Char (toUpper) import Data.List (intercalate) import Data.Maybe (maybeToList) import Network.IRC.Fun.Messages.Mask (serializeMask) --import Network.IRC.Fun.Messages.Modes (parseUserMode) --import Network.IRC.Fun.Messages.Reply (messageToReply, messageIsReply) import Network.IRC.Fun.Messages.Internal.Types ------------------------------------------------------------------------------- -- Building ------------------------------------------------------------------------------- showAddr :: Address -> String showAddr (IPv4 s) = s showAddr (IPv6 s) = s showHost :: Host -> String showHost (HostName hn) = hn showHost (HostAddr addr) = showAddr addr showHost (HostCloak s) = s showTargetMask :: TargetMask -> String showTargetMask (HostMask m) = '#' : serializeMask m showTargetMask (ServerMask m) = '$' : serializeMask m showTarget :: MessageTarget -> String showTarget (ChannelTarget chan) = chan showTarget (UserTarget Nothing (Just (UserAddr user mhost)) (Just server)) = maybe user ((user ++) . ('%' :) . showHost) mhost ++ '@' : server showTarget (UserTarget Nothing (Just (UserAddr user (Just host))) Nothing) = user ++ '%' : showHost host showTarget (UserTarget (Just nick) Nothing Nothing) = nick showTarget (UserTarget (Just nick) (Just (UserAddr 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 -> (CommandName, [Parameter]) buildMessage' msg = case msg of PassMessage pass -> ("PASS", [pass]) NickMessage nn -> ("NICK", [nn]) UserMessage un i w rn -> ("USER", [un, show $ modebit 3 i .|. modebit 2 w, "*", 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 reason) SQuitMessage s t -> ("????", error "Not implemented") JoinMessage Nothing -> ("JOIN", ["0"]) JoinMessage (Just (chans, keys)) -> ("JOIN", intercalate "," chans : if null keys then [] else [intercalate "," keys]) PartMessage chans reason -> ("PART", intercalate "," chans ?: reason) ChannelModeMessage remove add -> ("????", error "Not implemented") TopicMessage chan topic -> ("TOPIC", chan ?: topic) NamesMessage chans serv -> ("????", error "Not implemented") ListMessage chans serv -> ("????", error "Not implemented") InviteMessage nn chan -> ("????", error "Not implemented") KickMessage chans users s -> ("????", error "Not implemented") PrivMsgMessage tgt text -> ("PRIVMSG", [showTarget tgt, text]) NoticeMessage tgt text -> ("NOTICE", [showTarget tgt, text]) 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", s1 ?: s2) PongMessage s1 s2 -> ("PONG", s1 ?: 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 (StringCommand 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 , [ [channelPrivacyChar priv] , chan , unwords $ map (\ (p, n) -> maybe n (: 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 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 { prefix = Just $ Server $ sender reply , command = NumericCommand $ code reply , parameters = target' reply : params reply } where target' (GenericReply { target = NickTarget n }) = n target' (GenericReply { target = ServerTarget s }) = s ------------------------------------------------------------------------------- -- Serializing ------------------------------------------------------------------------------- serializePrefix :: Prefix -> String serializePrefix (Server sn) = sn serializePrefix (Nick n mu mh) = n ++ maybe "" ('!' :) mu ++ maybe "" (('@' :) . showHost) mh serializeCommand :: Command -> String serializeCommand (StringCommand s) = s serializeCommand (NumericCommand n) = show n serializeParams :: [Parameter] -> String serializeParams = f . map (\ p -> if null p then "(?)" else p) where f [] = "" f l = let (ps, p) = (init l, last l) in concatMap (' ' :) ps ++ ' ' : if head p == ':' || ' ' `elem` p then ':' : p else p -- | Write a message into an IRC protocol message formatted string. serializeMessage :: GenericMessage -> String serializeMessage msg = concat [ maybe "" (\ p -> ':' : serializePrefix p ++ " ") $ prefix msg , serializeCommand $ command msg , serializeParams $ parameters msg , "\r\n" ] -- | Write a reply into an IRC protocol message formatted string. -- -- This is essentially a combination of 'messageFromReply' and -- 'serializeMessage'. serializeReply :: GenericReply -> String serializeReply = serializeMessage . messageFromReply