5 files changed, 148 insertions, 144 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
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 11a27660..a102ed5a 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -102,8 +102,9 @@ import qualified System.Random
 import Data.Void (Void)
 import DPut
 import DebugTag
-import Stanza.Type
+import Stanza.Build
 import Stanza.Parse
+import Stanza.Types
 
 -- peerport :: PortNumber
 -- peerport = 5269
@@ -450,36 +451,6 @@ sendReply donevar stype reply replychan = do
         liftIO . atomically $ writeTVar (stanzaClosers replyStanza) Nothing
         -- liftIO $ wlog "finished reply stanza"
 
-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)
-    forkIO $ do
-        forM_ reply $ atomically . writeLChan replyChan
-        atomically $ do putTMVar donevar ()
-                        writeTVar replyClsrs Nothing
-    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
-                  }
-
 
 
 {-
@@ -492,95 +463,6 @@ C->Unrecognized </iq>
 -}
 
 
-mkname :: Text -> Text -> XML.Name
-mkname namespace name = (Name name (Just namespace) Nothing)
-
-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")
-       ]
-
 xmppInbound :: ConnectionData
                 -> XMPPServerParameters -- ^ XXX: unused
                 -> (Text, IO Text, IO Text, TChan Stanza -> StanzaOrigin)
@@ -1549,24 +1431,3 @@ forkXmpp XMPPServer { _xmpp_sv          = sv
     return mt
 
 
-#if MIN_VERSION_stm(2,4,0)
-#else
--- |Clone a 'TChan': similar to dupTChan, but the cloned channel starts with the
--- same content available as the original channel.
---
--- Terrible inefficient implementation provided to build against older libraries.
-cloneTChan :: TChan a -> STM (TChan a)
-cloneTChan chan = do
-    contents <- chanContents' chan
-    chan2 <- dupTChan chan
-    mapM_ (writeTChan chan) contents
-    return chan2
- where
-    chanContents' chan = do
-        b <- isEmptyTChan chan
-        if b then return [] else do
-        x <- readTChan chan
-        xs <- chanContents' chan
-        return (x:xs)
-#endif
-
diff --git a/dht-client.cabal b/dht-client.cabal
index b8882b8f..074604bf 100644
--- a/dht-client.cabal
+++ b/dht-client.cabal
@@ -137,7 +137,8 @@ library
                     Connection.Tcp
                     SockAddr
                     UTmp
-                    Stanza.Type
+                    Stanza.Build
+                    Stanza.Types
                     Stanza.Parse
                     XMPPServer
                     Util