module Network.IRC.Fun.Messages.Internal.Serialize
(
buildMessage
, buildReply
, messageFromReply
, serializeMessage
, serializeReply
)
where
import Data.Bits (bit, zeroBits, (.|.))
import Data.List (intercalate)
import Data.Maybe (maybeToList)
import Network.IRC.Fun.Messages.Mask (serializeMask)
import Network.IRC.Fun.Messages.Internal.Types
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"
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 -> ("NAMES", intercalate "," chans ?: serv)
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])
PrivActionMessage tgt text ->
("PRIVMSG", [showTarget tgt, "\1ACTION " ++ text ++ "\1"])
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
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 '@'
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"
buildReply :: SpecificReply -> GenericReply
buildReply (SpecificReply sender tgt reply) =
let (code, ps) = buildReply' reply
in GenericReply sender code tgt ps
messageFromReply :: GenericReply -> GenericMessage
messageFromReply reply = GenericMessage
{ gmPrefix = Just $ Server $ grSender reply
, gmCommand = NumericCommand $ grCode reply
, gmParams = target' reply : grParams reply
}
where
target' (GenericReply { grTarget = NickTarget n }) = n
target' (GenericReply { grTarget = ServerTarget s }) = s
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
serializeMessage :: GenericMessage -> String
serializeMessage msg = concat
[ maybe "" (\ p -> ':' : serializePrefix p ++ " ") $ gmPrefix msg
, serializeCommand $ gmCommand msg
, serializeParams $ gmParams msg
, "\r\n"
]
serializeReply :: GenericReply -> String
serializeReply = serializeMessage . messageFromReply