Factored Stanza.Build out of XMPPServer.

3 files changed, 144 insertions, 2 deletions

diff --git a/Presence/Stanza/Build.hs b/Presence/Stanza/Build.hs
new file mode 100644
index 00000000..5c4d371a
--- /dev/null
+++ b/Presence/Stanza/Build.hs
@@ -0,0 +1,142 @@
+{-# LANGUAGE CPP #-}
+module Stanza.Build where
+
+import Control.Monad
+import Control.Concurrent.STM
+import Data.Maybe
+import Data.Text (Text)
+import Data.XML.Types as XML
+
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent
+import GHC.Conc (labelThread)
+#endif
+
+import EventUtil
+import LockedChan
+import Stanza.Types
+
+makeMessage :: Text -> Text -> Text -> Text -> IO Stanza
+makeMessage namespace from to bod =
+    stanzaFromList typ
+     $ [ EventBeginElement (mkname namespace "message")
+            [ attr "from" from
+            , attr "to" to
+            ]
+       , EventBeginElement (mkname namespace "body") []
+       , EventContent (ContentText bod)
+       , EventEndElement (mkname namespace "body")
+       , EventEndElement (mkname namespace "message") ]
+ where
+    typ = Message { msgThread = Nothing
+                  , msgLangMap = [("", lsm)]
+                  }
+    lsm = LangSpecificMessage
+            { msgBody = Just bod
+            , msgSubject = Nothing }
+
+makeInformSubscription :: Text -> Text -> Text -> Bool -> IO Stanza
+makeInformSubscription namespace from to approved =
+    stanzaFromList (PresenceInformSubscription approved)
+      $ [ EventBeginElement (mkname namespace "presence")
+            [ attr "from" from
+            , attr "to" to
+            , attr "type" $ if approved then "subscribed"
+                                        else "unsubscribed" ]
+        , EventEndElement (mkname namespace "presence")]
+
+makePresenceStanza :: Text -> Maybe Text -> JabberShow -> IO Stanza
+makePresenceStanza namespace mjid pstat = do
+    stanzaFromList PresenceStatus { presenceShow = pstat
+                                  , presencePriority = Nothing
+                                  , presenceStatus = []
+                                  , presenceWhiteList = []
+                                  }
+      $ [ EventBeginElement (mkname namespace "presence")
+            (setFrom $ typ pstat) ]
+        ++ (shw pstat >>= jabberShow) ++
+        [ EventEndElement (mkname namespace "presence")]
+ where
+    setFrom = maybe id
+                    (\jid -> (attr "from" jid :) )
+                    mjid
+    typ Offline = [attr "type" "unavailable"]
+    typ _       = []
+    shw ExtendedAway = ["xa"]
+    shw Chatty       = ["chat"]
+    shw Away         = ["away"]
+    shw DoNotDisturb = ["dnd"]
+    shw _            = []
+    jabberShow stat =
+      [ EventBeginElement "{jabber:client}show" []
+      , EventContent (ContentText stat)
+      , EventEndElement "{jabber:client}show" ]
+
+makeRosterUpdate :: Text -> Text -> [(Name, Text)] -> IO Stanza
+makeRosterUpdate tojid contact as = do
+    let attrs = map (uncurry attr) as
+    stanzaFromList Unrecognized
+      [ EventBeginElement "{jabber:client}iq"
+            [ attr "to"   tojid
+            , attr "id"   "someid"
+            , attr "type" "set"
+            ]
+      , EventBeginElement "{jabber:iq:roster}query" []
+      , EventBeginElement "{jabber:iq:roster}item" (attr "jid" contact : attrs)
+      , EventEndElement   "{jabber:iq:roster}item"
+      , EventEndElement   "{jabber:iq:roster}query"
+      , EventEndElement "{jabber:client}iq"
+      ]
+
+makePong :: Text -> Maybe Text -> Text -> Text -> [XML.Event]
+makePong namespace mid to from =
+       -- Note: similar to session reply
+       [ EventBeginElement (mkname namespace "iq")
+         $(case mid of
+               Just c -> (("id",[ContentText c]):)
+               _      -> id)
+               [ attr "type" "result"
+               , attr "to"   to
+               , attr "from" from
+               ]
+       , EventEndElement (mkname namespace "iq")
+       ]
+
+
+mkname :: Text -> Text -> XML.Name
+mkname namespace name = (Name name (Just namespace) Nothing)
+
+
+stanzaFromList :: StanzaType -> [Event] -> IO Stanza
+stanzaFromList stype reply = do
+    let stanzaTag = listToMaybe reply
+        mid   = stanzaTag >>= lookupAttrib "id" . tagAttrs
+        mfrom = stanzaTag >>= lookupAttrib "from" . tagAttrs
+        mto = stanzaTag >>= lookupAttrib "to" . tagAttrs
+        {-
+        isInternal (InternalEnableHack {}) = True
+        isInternal (InternalCacheId {})    = True
+        isInternal _                       = False
+        -}
+    (donevar,replyChan,replyClsrs) <- atomically $ do
+        donevar <- newEmptyTMVar -- TMVar ()
+        replyChan <- newLockedChan
+        replyClsrs <- newTVar (Just [])
+        return (donevar,replyChan, replyClsrs)
+    t <- forkIO $ do
+        forM_ reply $ atomically . writeLChan replyChan
+        atomically $ do putTMVar donevar ()
+                        writeTVar replyClsrs Nothing
+    labelThread t $ concat $ "stanza." : take 1 (words $ show stype)
+    return Stanza { stanzaType      = stype
+                  , stanzaId        = mid
+                  , stanzaTo        = mto   -- as-is from reply list
+                  , stanzaFrom      = mfrom -- as-is from reply list
+                  , stanzaChan      = replyChan
+                  , stanzaClosers   = replyClsrs
+                  , stanzaInterrupt = donevar
+                  , stanzaOrigin    = LocalPeer
+                  }
+
diff --git a/Presence/Stanza/Parse.hs b/Presence/Stanza/Parse.hs
index 50e1e25b..e2a9efdd 100644
--- a/Presence/Stanza/Parse.hs
+++ b/Presence/Stanza/Parse.hs
@@ -18,7 +18,7 @@ import Control.Concurrent.STM.Util
 import ControlMaybe                (handleIO_, (<&>))
 import EventUtil
 import Nesting
-import Stanza.Type
+import Stanza.Types
 
 -- | Identify an XMPP stanza based on the open-tag.
 grokStanza ::  Text -> XML.Event -> NestingXML o IO (Maybe StanzaType)
diff --git a/Presence/Stanza/Type.hs b/Presence/Stanza/Types.hs
index 1d8041a9..6b402f4d 100644
--- a/Presence/Stanza/Type.hs
+++ b/Presence/Stanza/Types.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE FlexibleInstances #-}
-module Stanza.Type where
+module Stanza.Types where
 
 import Control.Concurrent.STM
 import Data.Int