1 files changed, 37 insertions, 11 deletions

diff --git a/xmppServer.hs b/xmppServer.hs
index a6cf2a2b..aa99c061 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -25,6 +25,8 @@ import qualified Text.XML.Stream.Parse as XML
 import Data.XML.Types as XML
 import Data.Maybe (catMaybes)
 import Data.Monoid ( (<>) )
+import Data.Text (Text)
+import qualified Data.Text as Text (pack)
 
 import qualified Control.Concurrent.STM.UpdateStream as Slotted
 import ControlMaybe
@@ -32,6 +34,13 @@ import NestingXML
 import EventUtil
 import Server
 
+addrToText :: SockAddr -> Text
+addrToText (addr@(SockAddrInet _ _)) = Text.pack $ stripColon (show addr)
+ where stripColon s = pre where (pre,port) = break (==':') s
+addrToText (addr@(SockAddrInet6 _ _ _ _)) = Text.pack $ stripColon (show addr)
+ where stripColon s = if null bracket then pre else pre ++ "]"
+          where
+            (pre,bracket) = break (==']') s
 
 wlog s = putStrLn s
  where _ = s :: String
@@ -39,14 +48,6 @@ wlogb s = Strict8.putStrLn s
 
 control sv = atomically . putTMVar (serverCommand sv)
 
-discardFlush :: Monad m => ConduitM (Flush a) a m ()
-discardFlush = awaitForever $ \x -> do
-    let unchunk (Chunk a) = a
-        ischunk (Chunk _) = True
-        ischunk _         = False
-    when (ischunk x) $ yield (unchunk x)
-
-
 xmlStream :: ReadCommand -> WriteCommand -> ( Source IO XML.Event
                                             , Sink (Flush XML.Event) IO () )
 xmlStream conread conwrite = (xsrc,xsnk)
@@ -57,6 +58,13 @@ xmlStream conread conwrite = (xsrc,xsnk)
         =$= builderToByteStringFlush 
         =$= discardFlush 
         =$ snk
+      where
+        discardFlush :: Monad m => ConduitM (Flush a) a m ()
+        discardFlush = awaitForever $ \x -> do
+            let unchunk (Chunk a) = a
+                ischunk (Chunk _) = True
+                ischunk _         = False
+            when (ischunk x) $ yield (unchunk x)
 
     src = do
         v <- lift conread
@@ -145,6 +153,21 @@ data XMPPState
  deriving (Eq,Ord)
 
 
+peerPing :: Maybe Text -> Text -> Text -> [XML.Event]
+peerPing mid to from = 
+       [ EventBeginElement "{jabber:server}iq"
+         $ (case mid of
+            Just c -> (("id",[ContentText c]):)
+            _      -> id               )
+            [ ("type",[ContentText "get"])
+            , attr "to"   to
+            , attr "from" from
+            ]
+       , EventBeginElement "{urn:xmpp:ping}ping" []
+       , EventEndElement "{urn:xmpp:ping}ping"
+       , EventEndElement "{jabber:server}iq" ]
+
+
 forkConnection :: ConnectionKey
                 -> FlagCommand
                 -> Source IO XML.Event
@@ -201,9 +224,12 @@ forkConnection k pingflag src snk stanzas = do
                         what
                 ,do pingflag >>= check
                     return $ do
-                    atomically $ Slotted.push slots (Just PingSlot) $ EventBeginElement "ping" []
-                    atomically $ Slotted.push slots (Just PingSlot) $ EventEndElement "ping"
-                    -- TODO: fix ping
+                    let to = addrToText (callBackAddress k)
+                        from = "todo" -- Look it up from Server object
+                                      -- or pass it with Connection event.
+                        mid = Just "ping"
+                    mapM_ (atomically . Slotted.push slots (Just $ PingSlot))
+                          (peerPing mid to from)
                     loop
                 ,readTMVar rdone >> return (return ())
                 ]