From 23a5d2cfd9b293d6c86827c282e8571ace20de09 Mon Sep 17 00:00:00 2001 From: joe Date: Sat, 29 Jun 2013 02:44:02 -0400 Subject: bind-resource protocol implemented --- Presence/XMPP.hs | 142 ++++++++++++++++++++++++++++++++++++++++++++++++------- b | 2 +- 2 files changed, 126 insertions(+), 18 deletions(-) diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs index bfa5827e..656ed170 100644 --- a/Presence/XMPP.hs +++ b/Presence/XMPP.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} module XMPP ( module XMPPTypes , listenForXmppClients @@ -38,8 +39,8 @@ import Text.XML.Stream.Parse import Text.XML.Stream.Render import Data.XML.Types as XML import Network.BSD (getHostName,hostName,hostAliases) -import Data.Text.Encoding as S (decodeUtf8) -import Data.Text.Lazy.Encoding as L (decodeUtf8) +import Data.Text.Encoding as S (decodeUtf8,encodeUtf8) +import Data.Text.Lazy.Encoding as L (decodeUtf8,encodeUtf8) import Data.Text.Lazy (toStrict) import GetHostByAddr import Data.Monoid @@ -48,6 +49,8 @@ import Data.Foldable (toList) #ifdef RENDERFLUSH import Data.Conduit.Blaze #endif +import Data.List (find) +import qualified Text.Show.ByteString as L data Commands = Send [XML.Event] | QuitThread deriving Prelude.Show @@ -126,24 +129,131 @@ eventIsBeginElement _ = False eventIsEndElement (EventEndElement _) = True eventIsEndElement _ = False +filterMapElement:: + (Monad m, MonadPlus mp) => + (Event -> mp a) -> Event -> mp a -> MaybeT (ConduitM Event o m) (mp a) +filterMapElement ret opentag empty = loop (empty `mplus` ret opentag) 1 + where + loop ts 0 = return ts + loop ts cnt = do + tag <- mawait + let ts' = mplus ts (ret tag) + case () of + _ | eventIsEndElement tag -> loop ts' (cnt-1) + _ | eventIsBeginElement tag -> loop ts' (cnt+1) + _ -> loop ts' cnt + gatherElement :: (Monad m, MonadPlus mp) => Event -> mp Event -> MaybeT (ConduitM Event o m) (mp Event) -gatherElement opentag empty = gatherElement' (empty `mplus` return opentag) 1 +gatherElement opentag empty = loop (empty `mplus` return opentag) 1 where - gatherElement' ts cnt = do + loop ts 0 = return ts + loop ts cnt = do tag <- mawait - let ts' = ts `mplus` return tag - cnt' = case () of - _ | eventIsEndElement tag -> cnt-1 - _ | eventIsBeginElement tag -> cnt+1 - _ -> cnt - if (cnt'>0) then gatherElement' ts' cnt' - else return ts' + let ts' = mplus ts (return tag) + case () of + _ | eventIsEndElement tag -> loop ts' (cnt-1) + _ | eventIsBeginElement tag -> loop ts' (cnt+1) + _ -> loop ts' cnt + +{- +sourceStanza :: Monad m => Event -> ConduitM Event Event m () +sourceStanza opentag = yield opentag >> loop 1 + where + loop 0 = return () + loop cnt = do + e <- await + let go tag cnt = yield tag >> loop cnt + case e of + Just tag | eventIsEndElement tag -> go tag (cnt-1) + Just tag | eventIsBeginElement tag -> go tag (cnt+1) + Just tag -> go tag cnt + Nothing -> return () +-} voidMaybeT body = (>> return ()) . runMaybeT $ body fixMaybeT f = (>> return ()) . runMaybeT . fix $ f +iq_bind_reply id jid = + [ EventBeginElement "{jabber:client}iq" [("type",[ContentText "result"]),("id",[ContentText id])] + + , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind" + [("xmlns",[ContentText "urn:ietf:params:xml:ns:xmpp-bind"])] + , EventBeginElement "jid" [] + , EventContent (ContentText jid) + , EventEndElement "jid" + , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}bind" + , EventEndElement "{jabber:client}iq" + ] + +uncontent cs = head $ map getText cs + where + getText (ContentText x) = x + getText (ContentEntity x ) = x + +-- doIQ :: MonadIO m => Event -> MaybeT (ConduitM Event o m) () +doIQ session cmdChan tag@(EventBeginElement name attrs) = do + (_,uncontent->iq_id) <- MaybeT . return $ find (\(n,v)->isId n) attrs + -- The 'id' attribute is REQUIRED for IQ stanzas. + -- todo: handle it's absence more gracefully + case (find (\(n,v)->isType n) attrs) of + Just (_,[ContentText "get"]) -> discard + Just (_,[ContentText "set"]) -> do + fix $ \iqsetloop -> do + setwhat <- mawait + liftIO (putStrLn $ "IQ-set " ++ show setwhat) + case setwhat of + bind@(EventBeginElement name attrs) | isBind name -> do + fix $ \again -> do + rscElem <- mawait + liftIO (putStrLn $ "IQ-set-bind " ++ show rscElem) + case rscElem of + bindchild@(EventBeginElement name _) | isResource name -> do + let isContent (EventContent (ContentText v)) = return v + isContent _ = mzero + xs <- filterMapElement isContent bindchild Nothing + case xs of + Just rsrc -> + liftIO $ do + setResource session (L.fromChunks [S.encodeUtf8 rsrc]) + jid <- getJID session + atomically $ writeTChan cmdChan (Send $ iq_bind_reply iq_id (toStrict $ L.decodeUtf8 $ L.show jid) ) + Nothing -> return () -- TODO: empty resource tag? + void $ gatherElement bind Nothing + bindchild@(EventBeginElement _ _) -> do + liftIO (putStrLn "unknown bind child") + gatherElement bindchild Nothing + void $ gatherElement bind Nothing + EventEndElement _ -> do + liftIO (putStrLn "empty bind") + -- TODO + -- A server that supports resource binding MUST be able to + -- generate a resource identifier on behalf of a client. A + -- resource identifier generated by the server MUST be unique + -- for that . + _ -> again + discard + req@(EventBeginElement name attrs) -> do + liftIO (putStrLn $ "IQ-set-unknown " ++ show req) + gatherElement req Nothing + discard + endtag@(EventEndElement _) -> do + liftIO (putStrLn $ "IQ-set-empty" ++ show endtag) + _ -> iqsetloop + Just (_,[ContentText "result"]) -> discard + Just (_,[ContentText "error"]) -> discard + Just _ -> discard -- error: type must be one of {get,set,result,error} + Nothing -> discard -- error: The 'type' attribute is REQUIRED for IQ stanzas. + where + isId n = n=="id" + isType n = n=="type" + isResource n = n=="{urn:ietf:params:xml:ns:xmpp-bind}resource" + isBind n = n=="{urn:ietf:params:xml:ns:xmpp-bind}bind" + discard = do + xs <- gatherElement tag Seq.empty + prettyPrint "client-in: ignoring iq:" (toList xs) + fromClient :: (MonadIO m, XMPPSession session) => session -> TChan Commands -> Sink XML.Event m () fromClient session cmdChan = voidMaybeT $ do @@ -163,16 +273,14 @@ fromClient session cmdChan = voidMaybeT $ do fix $ \loop -> do xml <- mawait log $ bshow xml + let isIQ n = n=="{jabber:client}iq" case xml of _ | eventIsEndElement xml -> return () + tag@(EventBeginElement name attrs) | isIQ name -> doIQ session cmdChan tag >> loop + tag@(EventBeginElement _ _) -> do xs <- gatherElement tag Seq.empty prettyPrint "client-in: ignoring..." (toList xs) - {- - liftIO (putStrLn "client-in: ignoring\n{") - liftIO (mapM_ print xs) - liftIO (putStrLn "}") - -} loop _ -> loop @@ -192,7 +300,7 @@ toClient pchan cmdChan = fix $ \loop -> do (fmap Right $ readTChan cmdChan) case event of Right QuitThread -> return () - Right (Send xs) -> yield xs >> loop -- prettyPrint "client-out: " xs >> loop + Right (Send xs) -> yield xs >> prettyPrint "client-out: " xs >> loop Left presence -> do xs <- liftIO $ xmlifyPresenceForClient presence yield xs diff --git a/b b/b index e505cdf5..88474475 100755 --- a/b +++ b/b @@ -1,5 +1,5 @@ #!/bin/bash -args="-O2 -fwarn-unused-imports -rtsopts" +args="-O2 -fwarn-unused-imports -rtsopts -DRENDERFLUSH" root=${0%/*} cd "$root" -- cgit v1.2.3