From 570cdafd43737275e8ac9e179edfe738cbf9551f Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 14 Apr 2013 18:00:23 +0200 Subject: [PATCH] Improve RFC 6121 (XMPP-IM) code. Move the functionality from Network.Xmpp.IM.Message and *.Presence to Network.Xmpp.Stanza since it is not specific to RFC 6121. Implement presence functionality of RFC 6121 Fix hslint errors and warning --- pontarius-xmpp.cabal | 12 +- source/Network/Xmpp.hs | 10 +- source/Network/Xmpp/IM.hs | 23 ++-- source/Network/Xmpp/IM/Message.hs | 183 +++++++++++++---------------- source/Network/Xmpp/IM/Presence.hs | 113 ++++++++---------- source/Network/Xmpp/IM/Roster.hs | 52 ++++---- source/Network/Xmpp/Stanza.hs | 76 ++++++++++++ source/Network/Xmpp/Utilities.hs | 39 +----- 8 files changed, 268 insertions(+), 240 deletions(-) create mode 100644 source/Network/Xmpp/Stanza.hs diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index c12c252..81680b1 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -61,15 +61,20 @@ Library , xml-conduit >=1.0 , xml-picklers >=0.3.2 Exposed-modules: Network.Xmpp + , Network.Xmpp.IM , Network.Xmpp.Internal Other-modules: Network.Xmpp.Concurrent - , Network.Xmpp.Concurrent.Types , Network.Xmpp.Concurrent.Basic , Network.Xmpp.Concurrent.IQ , Network.Xmpp.Concurrent.Message + , Network.Xmpp.Concurrent.Monad , Network.Xmpp.Concurrent.Presence , Network.Xmpp.Concurrent.Threads - , Network.Xmpp.Concurrent.Monad + , Network.Xmpp.Concurrent.Types + , Network.Xmpp.IM.Message + , Network.Xmpp.IM.Presence + , Network.Xmpp.IM.Roster + , Network.Xmpp.IM.Roster.Types , Network.Xmpp.Marshal , Network.Xmpp.Sasl , Network.Xmpp.Sasl.Common @@ -79,12 +84,11 @@ Library , Network.Xmpp.Sasl.Mechanisms.Scram , Network.Xmpp.Sasl.StringPrep , Network.Xmpp.Sasl.Types + , Network.Xmpp.Stanza , Network.Xmpp.Stream , Network.Xmpp.Tls , Network.Xmpp.Types , Network.Xmpp.Utilities - , Network.Xmpp.IM.Roster - , Network.Xmpp.IM.Roster.Types GHC-Options: -Wall Source-Repository head diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index 87d56f1..d864b26 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -82,6 +82,7 @@ module Network.Xmpp -- occur in a system such as email. It is not to be confused with -- /instant messaging/ which is handled in the 'Network.Xmpp.IM' module , Message(..) + , message , MessageError(..) , MessageType(..) -- *** Creating @@ -103,6 +104,12 @@ module Network.Xmpp , PresenceType(..) , PresenceError(..) -- *** Creating + , presence + , presenceOffline + , presenceOnline + , presenceSubscribe + , presenceSubscribed + , presenceUnsubscribe , presTo -- *** Sending -- | Sends a presence stanza. In general, the presence stanza should have no @@ -157,7 +164,8 @@ module Network.Xmpp ) where import Network.Xmpp.Concurrent -import Network.Xmpp.Utilities import Network.Xmpp.Sasl import Network.Xmpp.Sasl.Types +import Network.Xmpp.Stanza import Network.Xmpp.Types +import Network.Xmpp.Utilities diff --git a/source/Network/Xmpp/IM.hs b/source/Network/Xmpp/IM.hs index 70d1510..2f5bf08 100644 --- a/source/Network/Xmpp/IM.hs +++ b/source/Network/Xmpp/IM.hs @@ -1,14 +1,19 @@ +-- | RFC 6121: Instant Messaging and Presence +-- module Network.Xmpp.IM ( -- * Instant Messages - subject - , thread - , body - , bodies - , newIM - , simpleIM - , answerIM - -- * Presence - , module Network.Xmpp.IM.Presence + MessageBody(..) + , MessageThread(..) + , MessageSubject(..) + , instantMessage + , getIM + , withIM + -- * Presence + , ShowStatus(..) + , IMPresence(..) + , imPresence + , getIMPresence + , withIMPresence -- * Roster , Roster(..) , Item(..) diff --git a/source/Network/Xmpp/IM/Message.hs b/source/Network/Xmpp/IM/Message.hs index e5aa830..070a479 100644 --- a/source/Network/Xmpp/IM/Message.hs +++ b/source/Network/Xmpp/IM/Message.hs @@ -1,119 +1,64 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK hide #-} -module Network.Xmpp.IM.Message - where +module Network.Xmpp.IM.Message where -import Control.Applicative ((<$>)) - -import Data.Maybe (maybeToList, listToMaybe) import Data.Text (Text) import Data.XML.Pickle import Data.XML.Types - import Network.Xmpp.Marshal import Network.Xmpp.Types +import Network.Xmpp.Stanza +import Data.List +import Data.Function + -data MessageBody = MessageBody { bodyLang :: (Maybe LangTag) +data MessageBody = MessageBody { bodyLang :: Maybe LangTag , bodyContent :: Text } -data MessageThread = MessageThread { theadID :: Text - , threadParent :: (Maybe Text) +data MessageThread = MessageThread { theadID :: Text + , threadParent :: Maybe Text } -data MessageSubject = MessageSubject { subjectLang :: (Maybe LangTag) +data MessageSubject = MessageSubject { subjectLang :: Maybe LangTag , subjectContent :: Text } -xpMessageSubject :: PU [Element] MessageSubject -xpMessageSubject = xpUnliftElems . - xpWrap (\(l, s) -> MessageSubject l s) - (\(MessageSubject l s) -> (l,s)) - $ xpElem "{jabber:client}subject" xpLangTag $ xpContent xpId +-- | The instant message (IM) specific part of a message. +data InstantMessage = InstantMessage { imThread :: Maybe MessageThread + , imSubject :: [MessageSubject] + , imBody :: [MessageBody] + } -xpMessageBody :: PU [Element] MessageBody -xpMessageBody = xpUnliftElems . - xpWrap (\(l, s) -> MessageBody l s) - (\(MessageBody l s) -> (l,s)) - $ xpElem "{jabber:client}body" xpLangTag $ xpContent xpId +instantMessage :: InstantMessage +instantMessage = InstantMessage { imThread = Nothing + , imSubject = [] + , imBody = [] + } -xpMessageThread :: PU [Element] MessageThread -xpMessageThread = xpUnliftElems - . xpWrap (\(t, p) -> MessageThread p t) - (\(MessageThread p t) -> (t,p)) - $ xpElem "{jabber:client}thread" - (xpAttrImplied "parent" xpId) - (xpContent xpId) +-- | Get the IM specific parts of a message. Returns 'Nothing' when the received +-- payload is not valid IM data. +getIM :: Message -> Maybe InstantMessage +getIM im = either (const Nothing) Just . unpickle xpIM $ messagePayload im --- | Get the subject elements of a message (if any). Messages may --- contain multiple subjects if each of them has a distinct xml:lang --- attribute -subject :: Message -> [MessageSubject] -subject m = ms - where - -- xpFindMatches will _always_ return Right - Right ms = unpickle (xpFindMatches xpMessageSubject) $ messagePayload m - --- | Get the thread elements of a message (if any). The thread of a --- message is considered opaque, that is, no meaning, other than it's --- literal identity, may be derived from it and it is not human --- readable -thread :: Message -> Maybe MessageThread -thread m = ms - where - -- xpFindMatches will _always_ return Right - Right ms = unpickle (xpOption xpMessageThread) $ messagePayload m - --- | Get the body elements of a message (if any). Messages may contain --- multiple bodies if each of them has a distinct xml:lang attribute -bodies :: Message -> [MessageBody] -bodies m = ms - where - -- xpFindMatches will _always_ return Right - Right ms = unpickle (xpFindMatches xpMessageBody) $ messagePayload m - --- | Return the first body element, regardless of it's language. -body :: Message -> Maybe Text -body m = bodyContent <$> listToMaybe (bodies m) - --- | Generate a new instant message -newIM - :: Jid - -> Maybe StanzaID - -> Maybe LangTag - -> MessageType - -> Maybe MessageSubject - -> Maybe MessageThread - -> Maybe MessageBody - -> [Element] - -> Message -newIM t i lang tp sbj thrd bdy payload = Message - { messageID = i - , messageFrom = Nothing - , messageTo = Just t - , messageLangTag = lang - , messageType = tp - , messagePayload = concat $ - maybeToList (pickle xpMessageSubject <$> sbj) - ++ maybeToList (pickle xpMessageThread <$> thrd) - ++ maybeToList (pickle xpMessageBody <$> bdy) - ++ [payload] - } +sanitizeIM :: InstantMessage -> InstantMessage +sanitizeIM im = im{imBody = nubBy ((==) `on` bodyLang) $ imBody im} + +-- | Append IM data to a message +withIM :: Message -> InstantMessage -> Message +withIM m im = m{ messagePayload = messagePayload m + ++ pickleTree xpIM (sanitizeIM im) } + +imToElements :: InstantMessage -> [Element] +imToElements im = pickle xpIM (sanitizeIM im) -- | Generate a simple message simpleIM :: Jid -- ^ recipient -> Text -- ^ body -> Message -simpleIM t bd = newIM - t - Nothing - Nothing - Normal - Nothing - Nothing - (Just $ MessageBody Nothing bd) - [] +simpleIM to bd = withIM message{messageTo = Just to} + instantMessage{imBody = [MessageBody Nothing bd]} -- | Generate an answer from a received message. The recepient is -- taken from the original sender, the sender is set to Nothing, @@ -121,17 +66,47 @@ simpleIM t bd = newIM -- thread are inherited, the remaining payload is replaced by the -- given one. -- --- If multiple message bodies are given they must have different language tags -answerIM :: [MessageBody] -> [Element] -> Message -> Message -answerIM bd payload msg = Message - { messageID = messageID msg - , messageFrom = Nothing - , messageTo = messageFrom msg - , messageLangTag = messageLangTag msg - , messageType = messageType msg - , messagePayload = concat $ - (pickle xpMessageSubject <$> subject msg) - ++ maybeToList (pickle xpMessageThread <$> thread msg) - ++ (pickle xpMessageBody <$> bd) - ++ [payload] - } +-- If multiple message bodies are given they MUST have different language tags +answerIM :: [MessageBody] -> Message -> Maybe Message +answerIM bd msg = case getIM msg of + Nothing -> Nothing + Just im -> Just $ flip withIM (im{imBody = bd}) $ + message { messageID = messageID msg + , messageFrom = Nothing + , messageTo = messageFrom msg + , messageLangTag = messageLangTag msg + , messageType = messageType msg + } + +-------------------------- +-- Picklers -------------- +-------------------------- +xpIM :: PU [Element] InstantMessage +xpIM = xpWrap (\(t, s, b) -> InstantMessage t s b) + (\(InstantMessage t s b) -> (t, s, b)) $ + xp3Tuple + xpMessageThread + xpMessageSubject + xpMessageBody + + +xpMessageSubject :: PU [Element] [MessageSubject] +xpMessageSubject = xpUnliftElems . + xpWrap (map $ \(l, s) -> MessageSubject l s) + (map $ \(MessageSubject l s) -> (l,s)) + $ xpElems "{jabber:client}subject" xpLangTag $ xpContent xpId + +xpMessageBody :: PU [Element] [MessageBody] +xpMessageBody = xpUnliftElems . + xpWrap (map $ \(l, s) -> MessageBody l s) + (map $ \(MessageBody l s) -> (l,s)) + $ xpElems "{jabber:client}body" xpLangTag $ xpContent xpId + +xpMessageThread :: PU [Element] (Maybe MessageThread) +xpMessageThread = xpUnliftElems + . xpOption + . xpWrap (\(t, p) -> MessageThread p t) + (\(MessageThread p t) -> (t,p)) + $ xpElem "{jabber:client}thread" + (xpAttrImplied "parent" xpId) + (xpContent xpId) diff --git a/source/Network/Xmpp/IM/Presence.hs b/source/Network/Xmpp/IM/Presence.hs index 773c04d..c8fdb9d 100644 --- a/source/Network/Xmpp/IM/Presence.hs +++ b/source/Network/Xmpp/IM/Presence.hs @@ -1,75 +1,66 @@ {-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} module Network.Xmpp.IM.Presence where -import Network.Xmpp.Types +import Data.Text (Text) +import Data.XML.Pickle +import Data.XML.Types +import Network.Xmpp.Types --- | An empty presence. -presence :: Presence -presence = Presence { presenceID = Nothing - , presenceFrom = Nothing - , presenceTo = Nothing - , presenceLangTag = Nothing - , presenceType = Nothing - , presencePayload = [] - } +data ShowStatus = StatusAway + | StatusChat + | StatusDnd + | StatusXa --- | Request subscription with an entity. -presenceSubscribe :: Jid -> Presence -presenceSubscribe to = presence { presenceTo = Just to - , presenceType = Just Subscribe - } +instance Show ShowStatus where + show StatusAway = "away" + show StatusChat = "chat" + show StatusDnd = "dnd" + show StatusXa = "xa" --- | Is presence a subscription request? -isPresenceSubscribe :: Presence -> Bool -isPresenceSubscribe pres = presenceType pres == (Just Subscribe) +instance Read ShowStatus where + readsPrec _ "away" = [(StatusAway, "")] + readsPrec _ "chat" = [(StatusChat, "")] + readsPrec _ "dnd" = [(StatusDnd , "")] + readsPrec _ "xa" = [(StatusXa , "")] + readsPrec _ _ = [] --- | Approve a subscripton of an entity. -presenceSubscribed :: Jid -> Presence -presenceSubscribed to = presence { presenceTo = Just to - , presenceType = Just Subscribed - } +data IMPresence = IMP { showStatus :: Maybe ShowStatus + , status :: Maybe Text + , priority :: Maybe Int + } --- | Is presence a subscription approval? -isPresenceSubscribed :: Presence -> Bool -isPresenceSubscribed pres = presenceType pres == (Just Subscribed) +imPresence :: IMPresence +imPresence = IMP { showStatus = Nothing + , status = Nothing + , priority = Nothing + } --- | End a subscription with an entity. -presenceUnsubscribe :: Jid -> Presence -presenceUnsubscribe to = presence { presenceTo = Just to - , presenceType = Just Unsubscribed - } --- | Is presence an unsubscription request? -isPresenceUnsubscribe :: Presence -> Bool -isPresenceUnsubscribe pres = presenceType pres == (Just Unsubscribe) +getIMPresence :: Presence -> Maybe IMPresence +getIMPresence pres = case unpickle xpIMPresence (presencePayload pres) of + Left _ -> Nothing + Right r -> Just r --- | Signal to the server that the client is available for communication. -presenceOnline :: Presence -presenceOnline = presence +withIMPresence :: IMPresence -> Presence -> Presence +withIMPresence imPres pres = pres{presencePayload = presencePayload pres + ++ pickleTree xpIMPresence + imPres} --- | Signal to the server that the client is no longer available for --- communication. -presenceOffline :: Presence -presenceOffline = presence {presenceType = Just Unavailable} +-- +-- Picklers +-- ----- Change your status ---status --- :: Maybe Text -- ^ Status message --- -> Maybe ShowType -- ^ Status Type --- -> Maybe Int -- ^ Priority --- -> Presence ---status txt showType prio = presence { presenceShowType = showType --- , presencePriority = prio --- , presenceStatus = txt --- } - --- | Set the current availability status. This implicitly sets the client's --- status online. ---presenceAvail :: ShowType -> Presence ---presenceAvail showType = status Nothing (Just showType) Nothing - --- | Set the current status message. This implicitly sets the client's status --- online. ---presenceMessage :: Text -> Presence ---presenceMessage txt = status (Just txt) Nothing Nothing +xpIMPresence :: PU [Element] IMPresence +xpIMPresence = xpUnliftElems $ + xpWrap (\(s, st, p) -> IMP s st p) + (\(IMP s st p) -> (s, st, p)) $ + xp3Tuple + (xpOption $ xpElemNodes "{jabber:client}show" + (xpContent xpPrim)) + (xpOption $ xpElemNodes "{jabber:client}status" + (xpContent xpText)) + (xpOption $ xpElemNodes "{jabber:client}priority" + (xpContent xpPrim)) diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs index 6d20f2c..7658bc3 100644 --- a/source/Network/Xmpp/IM/Roster.hs +++ b/source/Network/Xmpp/IM/Roster.hs @@ -1,5 +1,4 @@ {-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} @@ -9,7 +8,7 @@ import Control.Concurrent.STM import Control.Monad import Data.List (nub) import qualified Data.Map.Strict as Map -import Data.Maybe (isJust) +import Data.Maybe (isJust, fromMaybe) import Data.Text (Text) import Data.XML.Pickle import Data.XML.Types @@ -60,9 +59,11 @@ rosterRemove j sess = do IQResponseResult IQResult{} -> return True _ -> return False +-- | Retrieve the current Roster state getRoster :: Session -> IO Roster getRoster session = atomically $ readTVar (rosterRef session) +-- | Get the initial roster / refresh the roster. You don't need to call this on your own initRoster :: Session -> IO () initRoster session = do oldRoster <- getRoster session @@ -74,26 +75,25 @@ initRoster session = do Just roster -> atomically $ writeTVar (rosterRef session) roster handleRoster :: TVar Roster -> TChan Stanza -> Stanza -> IO Bool -handleRoster ref outC sta = do - case sta of - IQRequestS (iqr@IQRequest{iqRequestPayload = - iqb@Element{elementName = en}}) - | nameNamespace en == Just "jabber:iq:roster" -> do - case iqRequestFrom iqr of - Just _from -> return True -- Don't handle roster pushes from - -- unauthorized sources - Nothing -> case unpickleElem xpQuery iqb of - Right Query{ queryVer = v - , queryItems = [update] - } -> do - handleUpdate v update - atomically . writeTChan outC $ result iqr - return False - _ -> do - errorM "Pontarius.Xmpp" "Invalid roster query" - atomically . writeTChan outC $ badRequest iqr - return False - _ -> return True +handleRoster ref outC sta = case sta of + IQRequestS (iqr@IQRequest{iqRequestPayload = + iqb@Element{elementName = en}}) + | nameNamespace en == Just "jabber:iq:roster" -> do + case iqRequestFrom iqr of + Just _from -> return True -- Don't handle roster pushes from + -- unauthorized sources + Nothing -> case unpickleElem xpQuery iqb of + Right Query{ queryVer = v + , queryItems = [update] + } -> do + handleUpdate v update + atomically . writeTChan outC $ result iqr + return False + _ -> do + errorM "Pontarius.Xmpp" "Invalid roster query" + atomically . writeTChan outC $ badRequest iqr + return False + _ -> return True where handleUpdate v' update = atomically $ modifyTVar ref $ \(Roster v is) -> Roster (v' `mplus` v) $ case qiSubscription update of @@ -119,7 +119,7 @@ retrieveRoster oldRoster sess = do return Nothing Right ros' -> return . Just $ toRoster ros' IQResponseResult (IQResult{iqResultPayload = Nothing}) -> do - return $ oldRoster + return oldRoster -- sever indicated that no roster updates are necessary IQResponseTimeout -> do errorM "Pontarius.Xmpp.Roster" "getRoster: request timed out" @@ -134,11 +134,11 @@ retrieveRoster oldRoster sess = do is) toItem :: QueryItem -> Item -toItem qi = Item { approved = maybe False id (qiApproved qi) +toItem qi = Item { approved = fromMaybe False (qiApproved qi) , ask = qiAsk qi , jid = qiJid qi , name = qiName qi - , subscription = maybe None id (qiSubscription qi) + , subscription = fromMaybe None (qiSubscription qi) , groups = nub $ qiGroups qi } @@ -161,7 +161,7 @@ xpItems = xpWrap (map (\((app_, ask_, jid_, name_, sub_), groups_) -> xpElems "{jabber:iq:roster}item" (xp5Tuple (xpAttribute' "approved" xpBool) - (xpWrap (maybe False (const True)) + (xpWrap isJust (\p -> if p then Just () else Nothing) $ xpOption $ xpAttribute_ "ask" "subscribe") (xpAttribute "jid" xpPrim) diff --git a/source/Network/Xmpp/Stanza.hs b/source/Network/Xmpp/Stanza.hs new file mode 100644 index 0000000..ab3c68f --- /dev/null +++ b/source/Network/Xmpp/Stanza.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE RecordWildCards #-} + +{-# OPTIONS_HADDOCK hide #-} + +-- | Stanza related functions and constants +-- + +module Network.Xmpp.Stanza where + +import Data.XML.Types +import Network.Xmpp.Types + + +-- | An empty message +message :: Message +message = Message { messageID = Nothing + , messageFrom = Nothing + , messageTo = Nothing + , messageLangTag = Nothing + , messageType = Normal + , messagePayload = [] + } + +-- | An empty presence. +presence :: Presence +presence = Presence { presenceID = Nothing + , presenceFrom = Nothing + , presenceTo = Nothing + , presenceLangTag = Nothing + , presenceType = Nothing + , presencePayload = [] + } + +-- | Request subscription with an entity. +presenceSubscribe :: Jid -> Presence +presenceSubscribe to = presence { presenceTo = Just to + , presenceType = Just Subscribe + } + +-- | Approve a subscripton of an entity. +presenceSubscribed :: Jid -> Presence +presenceSubscribed to = presence { presenceTo = Just to + , presenceType = Just Subscribed + } + +-- | End a subscription with an entity. +presenceUnsubscribe :: Jid -> Presence +presenceUnsubscribe to = presence { presenceTo = Just to + , presenceType = Just Unsubscribed + } + +-- | Signal to the server that the client is available for communication. +presenceOnline :: Presence +presenceOnline = presence + +-- | Signal to the server that the client is no longer available for +-- communication. +presenceOffline :: Presence +presenceOffline = presence {presenceType = Just Unavailable} + +-- | Produce an answer message with the given payload, switching the "from" and +-- "to" attributes in the original message. Produces a 'Nothing' value of the +-- provided message message has no from attribute. +answerMessage :: Message -> [Element] -> Maybe Message +answerMessage Message{messageFrom = Just frm, ..} payload = + Just Message{ messageFrom = messageTo + , messageID = Nothing + , messageTo = Just frm + , messagePayload = payload + , .. + } +answerMessage _ _ = Nothing + +-- | Add a recipient to a presence notification. +presTo :: Presence -> Jid -> Presence +presTo pres to = pres{presenceTo = Just to} diff --git a/source/Network/Xmpp/Utilities.hs b/source/Network/Xmpp/Utilities.hs index eef3c98..6d4cee3 100644 --- a/source/Network/Xmpp/Utilities.hs +++ b/source/Network/Xmpp/Utilities.hs @@ -1,13 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_HADDOCK hide #-} + module Network.Xmpp.Utilities - ( presTo - , message - , answerMessage - , openElementToEvents + ( openElementToEvents , renderOpenElement , renderElement , checkHostName @@ -23,39 +20,11 @@ import qualified Data.Text as Text import Data.Text(Text) import qualified Data.Text.Encoding as Text import Data.XML.Types -import Network.Xmpp.Types import Prelude import System.IO.Unsafe(unsafePerformIO) import qualified Text.XML.Stream.Render as TXSR import Text.XML.Unresolved as TXU --- | Add a recipient to a presence notification. -presTo :: Presence -> Jid -> Presence -presTo pres to = pres{presenceTo = Just to} - --- | An empty message. -message :: Message -message = Message { messageID = Nothing - , messageFrom = Nothing - , messageTo = Nothing - , messageLangTag = Nothing - , messageType = Normal - , messagePayload = [] - } - --- | Produce an answer message with the given payload, switching the "from" and --- "to" attributes in the original message. Produces a 'Nothing' value of the --- provided message message has no from attribute. -answerMessage :: Message -> [Element] -> Maybe Message -answerMessage Message{messageFrom = Just frm, ..} payload = - Just Message{ messageFrom = messageTo - , messageID = Nothing - , messageTo = Just frm - , messagePayload = payload - , .. - } -answerMessage _ _ = Nothing - openElementToEvents :: Element -> [Event] openElementToEvents (Element name as ns) = EventBeginElement name as : goN ns [] where @@ -85,7 +54,7 @@ renderElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO -- | Validates the hostname string in accordance with RFC 1123. checkHostName :: Text -> Maybe Text -checkHostName t = do +checkHostName t = eitherToMaybeHostName $ AP.parseOnly hostnameP t where eitherToMaybeHostName = either (const Nothing) Just @@ -105,6 +74,6 @@ hostnameP = do <|> do _ <- AP.satisfy (== '.') r <- hostnameP - if (Text.length label) + 1 + (Text.length r) > 255 + if Text.length label + 1 + Text.length r > 255 then fail "Hostname too long." else return $ Text.concat [label, Text.pack ".", r]