From a5e25a5657d4a4bafc72413d6eda1f174cb54c1f Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 17 Mar 2014 12:45:48 +0100 Subject: [PATCH] fix some discrepancies to RFC6120/6121/6122 --- source/Network/Xmpp/Concurrent/Presence.hs | 10 ++++- source/Network/Xmpp/IM/Roster.hs | 50 +++++++++++++--------- source/Network/Xmpp/Marshal.hs | 16 +++---- source/Network/Xmpp/Types.hs | 9 +++- 4 files changed, 53 insertions(+), 32 deletions(-) diff --git a/source/Network/Xmpp/Concurrent/Presence.hs b/source/Network/Xmpp/Concurrent/Presence.hs index f261668..054d728 100644 --- a/source/Network/Xmpp/Concurrent/Presence.hs +++ b/source/Network/Xmpp/Concurrent/Presence.hs @@ -6,6 +6,7 @@ import Control.Concurrent.STM import Network.Xmpp.Types import Network.Xmpp.Concurrent.Types import Network.Xmpp.Concurrent.Basic +import Network.Xmpp.Lens -- | Read a presence stanza from the inbound stanza channel, discards any other -- stanzas. Returns the presence stanza with annotations. @@ -40,4 +41,11 @@ waitForPresence f s = fst <$> waitForPresenceA (f . fst) s -- | Send a presence stanza. sendPresence :: Presence -> Session -> IO (Either XmppFailure ()) -sendPresence p session = sendStanza (PresenceS p) session +sendPresence p session = sendStanza (PresenceS checkedP) session + where + -- | RFC 6121 §3.1.1: When a user sends a presence subscription request to a + -- potential instant messaging and presence contact, the value of the 'to' + -- attribute MUST be a bare JID rather than a full JID + checkedP = case presenceType p of + Subscribe -> modify to (fmap toBare) p + _ -> p diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs index 4abdeaa..62f70a9 100644 --- a/source/Network/Xmpp/IM/Roster.hs +++ b/source/Network/Xmpp/IM/Roster.hs @@ -31,22 +31,15 @@ import Network.Xmpp.Types timeout :: Maybe Integer timeout = Just 3000000 -- 3 seconds --- | Push a roster item to the server. The values for approved and ask are --- ignored and all values for subsciption except "remove" are ignored. -rosterPush :: Item -> Session -> IO (Either IQSendError (Annotated IQResponse)) -rosterPush item session = do - let el = pickleElem xpQuery (Query Nothing [fromItem item]) - sendIQA' timeout Nothing Set Nothing el [] session - -- | Add or update an item to the roster. -- -- To update the item just send the complete set of new data. -rosterAdd :: Jid -- ^ JID of the item +rosterSet :: Jid -- ^ JID of the item -> Maybe Text -- ^ Name alias -> [Text] -- ^ Groups (duplicates will be removed) -> Session -> IO (Either IQSendError (Annotated IQResponse)) -rosterAdd j n gs session = do +rosterSet j n gs session = do let el = pickleElem xpQuery (Query Nothing [QueryItem { qiApproved = Nothing , qiAsk = False @@ -57,6 +50,14 @@ rosterAdd j n gs session = do }]) sendIQA' timeout Nothing Set Nothing el [] session +-- | Synonym to rosterSet +rosterAdd :: Jid + -> Maybe Text + -> [Text] + -> Session + -> IO (Either IQSendError (Annotated IQResponse)) +rosterAdd = rosterSet + -- | Remove an item from the roster. Return 'True' when the item is sucessfully -- removed or if it wasn't in the roster to begin with. rosterRemove :: Jid -> Session -> IO Bool @@ -69,6 +70,13 @@ rosterRemove j sess = do case res of Right (IQResponseResult IQResult{}, _) -> return True _ -> return False + where + rosterPush :: Item + -> Session + -> IO (Either IQSendError (Annotated IQResponse)) + rosterPush item session = do + let el = pickleElem xpQuery (Query Nothing [fromItem item]) + sendIQA' timeout Nothing Set Nothing el [] session -- | Retrieve the current Roster state getRoster :: Session -> IO Roster @@ -157,9 +165,13 @@ toItem qi = Item { riApproved = fromMaybe False (qiApproved qi) , riAsk = qiAsk qi , riJid = qiJid qi , riName = qiName qi - , riSubscription = fromMaybe None (qiSubscription qi) + , riSubscription = fromSubscription (qiSubscription qi) , riGroups = nub $ qiGroups qi } + where + fromSubscription Nothing = None + fromSubscription (Just s) | s `elem` [None, To, From, Both] = s + | otherwise = None fromItem :: Item -> QueryItem fromItem i = QueryItem { qiApproved = Nothing @@ -198,17 +210,15 @@ xpQuery = xpWrap (\(ver_, items_) -> Query ver_ items_ ) xpSubscription :: PU Text Subscription xpSubscription = ("xpSubscription", "") - xpPartial ( \input -> case subscriptionFromText input of - Nothing -> Left "Could not parse subscription." - Just j -> Right j) - subscriptionToText + xpIso subscriptionFromText + subscriptionToText where - subscriptionFromText "none" = Just None - subscriptionFromText "to" = Just To - subscriptionFromText "from" = Just From - subscriptionFromText "both" = Just Both - subscriptionFromText "remove" = Just Remove - subscriptionFromText _ = Nothing + subscriptionFromText "none" = None + subscriptionFromText "to" = To + subscriptionFromText "from" = From + subscriptionFromText "both" = Both + subscriptionFromText "remove" = Remove + subscriptionFromText _ = None subscriptionToText None = "none" subscriptionToText To = "to" subscriptionToText From = "from" diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs index daee98d..69d778d 100644 --- a/source/Network/Xmpp/Marshal.hs +++ b/source/Network/Xmpp/Marshal.hs @@ -400,16 +400,14 @@ xpIQRequestType = ("xpIQRequestType", "") xpMessageType :: PU Text MessageType xpMessageType = ("xpMessageType", "") - xpPartial ( \input -> case messageTypeFromText input of - Nothing -> Left "Could not parse message type." - Just j -> Right j) - messageTypeToText + xpIso messageTypeFromText + messageTypeToText where - messageTypeFromText "chat" = Just Chat - messageTypeFromText "groupchat" = Just GroupChat - messageTypeFromText "headline" = Just Headline - messageTypeFromText "normal" = Just Normal - messageTypeFromText _ = Just Normal + messageTypeFromText "chat" = Chat + messageTypeFromText "groupchat" = GroupChat + messageTypeFromText "headline" = Headline + messageTypeFromText "normal" = Normal + messageTypeFromText _ = Normal messageTypeToText Chat = "chat" messageTypeToText GroupChat = "groupchat" messageTypeToText Headline = "headline" diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 15cda29..2714b18 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -91,6 +91,7 @@ import Data.Text (Text) import qualified Data.Text as Text import Data.Typeable(Typeable) import Data.XML.Types as XML +import qualified Data.Text.Encoding as Text #if WITH_TEMPLATE_HASKELL import Language.Haskell.TH import Language.Haskell.TH.Quote @@ -1019,8 +1020,9 @@ jidFromTexts l d r = do guard $ Text.all (`Set.notMember` prohibMap) l'' l''' <- nonEmpty l'' return $ Just l''' - domainPart' <- SP.runStringPrep (SP.namePrepProfile False) d + domainPart' <- SP.runStringPrep (SP.namePrepProfile False) (stripSuffix d) guard $ validDomainPart domainPart' + guard $ validPartLength domainPart' domainPart <- nonEmpty domainPart' resourcePart <- case r of Nothing -> return Nothing @@ -1036,7 +1038,10 @@ jidFromTexts l d r = do -- checks validPartLength :: Text -> Bool - validPartLength p = Text.length p > 0 && Text.length p < 1024 + validPartLength p = Text.length p > 0 + && BS.length (Text.encodeUtf8 p) < 1024 + -- RFC6122 §2.2 + stripSuffix t = if Text.last t == '.' then Text.init t else t -- | Returns 'True' if the JID is /bare/, that is, it doesn't have a resource -- part, and 'False' otherwise.