1 files changed, 50 insertions, 11 deletions

diff --git a/Presence/Server.hs b/Presence/Server.hs
index 4cbaaa7d..5e54ff27 100644
--- a/Presence/Server.hs
+++ b/Presence/Server.hs
@@ -3,6 +3,9 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE OverloadedStrings  #-}
 {-# LANGUAGE TupleSections      #-}
+#ifdef TEST
+{-# LANGUAGE FlexibleInstances #-}
+#endif
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Server
@@ -57,6 +60,9 @@ import Network.BSD
     ( getProtocolNumber
     )   
 import Debug.Trace
+import Data.Time.Clock (UTCTime,getCurrentTime)
+import Data.Time.Format (formatTime)
+import System.Locale (defaultTimeLocale)
 
 todo = error "unimplemented"
 
@@ -154,10 +160,15 @@ data ConnectionEvent b
     | RequiresPing 
     -- ^ 'pingInterval' miliseconds of idle was experienced
 
-{-
+#ifdef TEST
+instance Show (IO a) where show _ = "<IO action>"
+instance Show (STM a) where show _ = "<STM action>"
+instance Eq (ByteString -> IO Bool) where (==) _ _ = True
+instance Eq (IO (Maybe ByteString)) where (==) _ _ = True
+instance Eq (STM Bool) where (==) _ _ = True
 deriving instance Show b => Show (ConnectionEvent b)
 deriving instance Eq   b => Eq   (ConnectionEvent b)
--}
+#endif
 
 -- | This object accepts commands and signals events and maintains
 -- the list of currently listening ports and established connections.
@@ -267,7 +278,7 @@ server = do
   doit server (Connect addr params) = liftIO $ do
     void . forkIO $ do
         proto <- getProtocolNumber "tcp"
-        sock <- bracketOnError
+        bracketOnError
             (socket (socketFamily addr) Stream proto)
             (\sock -> do -- only done if there's an error
                          -- Weird hack: puting the would-be peer address
@@ -277,8 +288,8 @@ server = do
                          atomically 
                             $ writeTChan (serverEvent server) 
                                 $ (conkey,ConnectFailure addr))
-            $ \sock -> do connect sock addr
-                          return sock
+            $ \sock -> do
+        connect sock addr
         me <- getSocketName sock
         conkey <- makeConnKey params (sock,me)
         h <- socketToHandle sock ReadWriteMode
@@ -370,21 +381,22 @@ newConnection server params conkey h inout = do
                 kont <- updateConMap conkey new what
                 putTMVar started ()
                 return kont
-    {-
+#ifdef TEST
     -- enable this for 'Got' events
     forkIO $ do -- inout==In || duplex params then forkIO $ do
-        -- warn $ "waiting read thread: " <> bshow (conkey,inout)
+        warn $ "waiting gots thread: " <> bshow (conkey,inout)
         atomically $ takeTMVar started
         -- pingBump pinglogic -- start the ping timer
         fix $ \loop -> do
         -- warn $ "read thread: " <> bshow (conkey,inout)
         mb <- threadsRead new
         -- pingBump pinglogic
-        -- warn $ "got: " <> bshow (mb,(conkey,inout))
+        warn $ "got: " <> bshow (mb,(conkey,inout))
         maybe (return ())
               (atomically . forward >=> const loop)
               mb
-    -}
+        warn $ "quit-gots: " <> bshow (conkey,inout)
+#endif
     return ()
  where
 
@@ -408,9 +420,23 @@ newConnection server params conkey h inout = do
                                         $ Map.delete conkey
             -- warn $ "fin-EOF "<>bshow conkey
 
-    sendPing PingTimeOut = do atomically (connClose newCon)
-                              eof
+    sendPing PingTimeOut = do
+        {-
+        let me = connPingTimer newCon
+        utc <- getCurrentTime
+        let utc' = formatTime defaultTimeLocale "%s" utc
+        warn $ "TIMEOUT " <> bshow utc' <> " " <> bshow (pingIdle me, pingTimeOut me)
+        -}
+        atomically (connClose newCon)
+        eof
+
     sendPing PingIdle = do
+        {-
+        let me = connPingTimer newCon
+        utc <- getCurrentTime
+        let utc' = formatTime defaultTimeLocale "%s" utc
+        warn $ "IDLE" <> bshow utc' <> " " <> bshow (pingIdle me, pingTimeOut me)
+        -}
         atomically $ announce (conkey,RequiresPing)
         handleEOF conkey mvar newCon
 
@@ -701,7 +727,20 @@ pingBump me = do
                                       (1000*pingIdle me,PingIdle)
             takeTMVar (pingStarted me)
     when b $ throwTo (pingThread me) $ ErrorCall ""
+    {-
+    utc <- getCurrentTime
+    let utc' = formatTime defaultTimeLocale "%s" utc
+    warn $ "BUMP " <> bshow utc' <> " " <> bshow (pingIdle me, pingTimeOut me)
+    -}
     atomically $ putTMVar (pingStarted me) b
+{-
+pingBump me = do
+    b <- atomically $ do
+             when (pingIdle me /= 0) $ 
+                putTMVar (pingDelay me) (1000*pingIdle me,PingIdle)
+             readTMVar (pingStarted me)
+    when b $ throwTo (pingThread me) $ ErrorCall ""
+-}
 
 pingWait :: PingMachine -> STM PingEvent
 pingWait me = do