From be449c9e0cd90e4b76a7f02628951cd502fb3118 Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Sun, 17 Nov 2013 16:24:51 -0500
Subject: Added RestrictedSocket parameter to ActivityBump

---
 Presence/SocketLike.hs |  2 +-
 Presence/XMPP.hs       | 18 +++++++++---------
 Presence/XMPPTypes.hs  |  2 +-
 3 files changed, 11 insertions(+), 11 deletions(-)

diff --git a/Presence/SocketLike.hs b/Presence/SocketLike.hs
index cf52aca8..9cfb85dc 100644
--- a/Presence/SocketLike.hs
+++ b/Presence/SocketLike.hs
@@ -48,7 +48,7 @@ instance SocketLike NS.Socket where
     sIsReadable   = NS.sIsReadable
     sIsWritable   = NS.sIsWritable
 
-newtype RestrictedSocket = Restricted NS.Socket deriving SocketLike
+newtype RestrictedSocket = Restricted NS.Socket deriving (SocketLike,Show)
 
 restrictSocket :: NS.Socket -> RestrictedSocket
 restrictSocket socket = Restricted socket
diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 84035ea2..7a0bb1a2 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -636,9 +636,9 @@ listenForRemotePeers addrfamily session_factory port st = do
     doServer (addrfamily .*. port .*. session_factory .*. st) handlePeer
 
 handlePeer
-  :: (SocketLike sock, HHead l (XMPPPeerClass session),
+  :: (HHead l (XMPPPeerClass session),
       JabberPeerSession session) =>
-     HCons sock (HCons t1 l) -> Source IO ByteString -> t -> IO ()
+     HCons RestrictedSocket (HCons t1 l) -> Source IO ByteString -> t -> IO ()
 handlePeer st src snk = do
     let HCons sock (HCons _ st') = st
         session_factory = hHead st'
@@ -646,7 +646,7 @@ handlePeer st src snk = do
     debugL $ "(P) connected " <++> name
     session <- newPeerSession session_factory sock
 
-    finally ( src $= parseBytes def $$ fromPeer session )
+    finally ( src $= parseBytes def $$ fromPeer sock session )
         $ do 
             debugL $ "(P) disconnected " <++> name
             closePeerSession session
@@ -912,8 +912,8 @@ handlePeerIQGet session tag = do
         req -> unhandledGet req
 
 fromPeer :: (MonadThrow m,MonadIO m, JabberPeerSession session) => 
-    session -> Sink XML.Event m ()
-fromPeer session = doNestingXML $ do
+    RestrictedSocket -> session -> Sink XML.Event m ()
+fromPeer sock session = doNestingXML $ do
     let log  = liftIO . debugL . ("(P) " <++>)
     withXML $ \begindoc -> do
     when (begindoc==EventBeginDocument) $ do
@@ -927,7 +927,7 @@ fromPeer session = doNestingXML $ do
         whenJust nextElement $ \stanza -> do
             stanza_lvl <- nesting
 
-            liftIO $ sendPeerMessage session ActivityBump -- reset ping timer
+            liftIO $ sendPeerMessage session (ActivityBump sock) -- reset ping timer
 
             let unhandledStanza = do
                     xs <- gatherElement stanza Seq.empty
@@ -987,7 +987,7 @@ instance CommandCache CachedMessages where
     updateCache (OutBoundMessage msg) cache = cache -- TODO: cache chat?
     updateCache (Pong _ _ _) cache = cache          -- pings are not cached
     updateCache (Unsupported _ _ _ _) cache = cache -- error messages are not cached
-    updateCache ActivityBump cache = cache
+    updateCache (ActivityBump sock) cache = cache
 
 instance ThreadChannelCommand OutBoundMessage where
     isQuitCommand Disconnect = True
@@ -1143,7 +1143,7 @@ toPeer sock cache chan fail = do
     pingref <- liftIO $ do
                     ping_timer <- liftIO $ newDelay five_sec
                     newTVarIO (ping_timer,0::Int)
-    let bump = do
+    let bump fromsock = do
             timer <- atomically $ do
                         (timer,v) <-  readTVar pingref
                         writeTVar pingref (timer,0)
@@ -1206,7 +1206,7 @@ toPeer sock cache chan fail = do
                   Pong from to mid -> sendPong from to mid
                   Unsupported from to mid tag -> sendUnsupported from to mid tag
                   Disconnect -> return ()
-                  ActivityBump -> liftIO bump
+                  ActivityBump fromsock -> liftIO (bump fromsock)
              when (not . isQuitCommand $ event) loop
         either chanEvent sendPing event
     return ()
diff --git a/Presence/XMPPTypes.hs b/Presence/XMPPTypes.hs
index f1f511e7..f6ffe66e 100644
--- a/Presence/XMPPTypes.hs
+++ b/Presence/XMPPTypes.hs
@@ -284,7 +284,7 @@ data OutBoundMessage = OutBoundPresence Presence
                         | Pong JID JID (Maybe Content)
                         | Unsupported JID JID (Maybe Content) XML.Name
                         | Disconnect
-                        | ActivityBump
+                        | ActivityBump RestrictedSocket
  deriving Prelude.Show
 
 getNamesForPeer :: Peer -> IO [S.ByteString]
-- 
cgit v1.2.3