Merge branch 'optional-whitespace-keepalive' of https://github.com/singpolyma/pontarius-xmpp into singpolyma-optional-whitespace-keepalive

source/Network/Xmpp/Concurrent.hs

@@ -187,6 +187,7 @@ newSession stream config realm mbSasl = runErrorT $ do
                         ]
     (kill, sState, reader) <- ErrorT $ startThreadsWith writeSem stanzaHandler
                                                         eh stream
+                                                        (keepAlive config)
     idGen <- liftIO $ sessionStanzaIDs config
     let sess = Session { stanzaCh = stanzaChan
                        , iqHandlers = iqHands

source/Network/Xmpp/Concurrent/Threads.hs

@@ -86,14 +86,15 @@ startThreadsWith :: TMVar (BS.ByteString -> IO (Either XmppFailure ()))
                  -> (Stanza -> IO ())
                  -> TMVar EventHandlers
                  -> Stream
+                 -> Maybe Int
                  -> IO (Either XmppFailure (IO (),
                                             TMVar Stream,
                                             ThreadId))
-startThreadsWith writeSem stanzaHandler eh con = do
+startThreadsWith writeSem stanzaHandler eh con keepAlive = do
     -- read' <- withStream' (gets $ streamSend . streamHandle) con
     -- writeSem <- newTMVarIO read'
     conS <- newTMVarIO con
-    cp <- forkIO $ connPersist writeSem
+    cp <- forkIO $ connPersist keepAlive writeSem
     rdw <- forkIO $ readWorker stanzaHandler (noCon eh) conS
     return $ Right ( killConnection [rdw, cp]
                    , conS
@@ -115,9 +116,10 @@ startThreadsWith writeSem stanzaHandler eh con = do
 
 -- Acquires the write lock, pushes a space, and releases the lock.
 -- | Sends a blank space every 30 seconds to keep the connection alive.
-connPersist :: TMVar (BS.ByteString -> IO a) -> IO ()
-connPersist sem = forever $ do
+connPersist :: Maybe Int -> TMVar (BS.ByteString -> IO a) -> IO ()
+connPersist (Just delay) sem = forever $ do
     pushBS <- atomically $ takeTMVar sem
     _ <- pushBS " "
     atomically $ putTMVar sem pushBS
-    threadDelay 30000000 -- 30s
+    threadDelay (delay*1000000)
+connPersist Nothing _ = return ()

source/Network/Xmpp/Concurrent/Types.hs

@@ -96,6 +96,9 @@ data SessionConfiguration = SessionConfiguration
                                           -> PeerStatus
                                           -> PeerStatus
                                           -> IO ())
+      -- | How often to send keep-alives
+      --   'Nothing' disables keep-alive
+    , keepAlive                  :: Maybe Int
     }
 
 instance Default SessionConfiguration where
@@ -111,6 +114,7 @@ instance Default SessionConfiguration where
                                , enableRoster = True
                                , enablePresenceTracking = True
                                , onPresenceChange = Nothing
+                               , keepAlive = Just 30
                                }
 
 -- | Handlers to be run when the Xmpp session ends and when the Xmpp connection is