fix some discrepancies to RFC6120/6121/6122

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

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)
+        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"

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)
+        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"

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.