1 files changed, 14 insertions, 18 deletions

diff --git a/Presence/Server.hs b/Presence/Server.hs
index f82a93c5..1e46c051 100644
--- a/Presence/Server.hs
+++ b/Presence/Server.hs
@@ -6,6 +6,7 @@
 {-# LANGUAGE RankNTypes         #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TupleSections      #-}
+{-# LANGUAGE LambdaCase         #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Server
@@ -313,15 +314,13 @@ server allocate = do
           (post <=< flip connWrite bs . cstate)
       $ Map.lookup con map
 
-  doit server (Connect addr params) = do
-    mb <- atomically $ do
-        rmap <- readTVar (retrymap server)
-        return $ Map.lookup addr rmap
-    maybe forkit
-          (\(v,d) -> do b <- atomically $ readTVar v
-                        interruptDelay d
-                        when (not b) forkit)
-          mb
+  doit server (Connect addr params) = join $ atomically $ do
+    Map.lookup addr <$> readTVar (retrymap server)
+      >>= return . \case
+        Nothing    -> forkit
+        Just (v,d) -> do b <- atomically $ readTVar v
+                         interruptDelay d
+                         when (not b) forkit
     where
     forkit = void . forkIO $ do
         proto <- getProtocolNumber "tcp"
@@ -347,17 +346,14 @@ server allocate = do
         resultVar <- atomically newEmptyTMVar
         timer <- interruptibleDelay
         (retryVar,action) <- atomically $ do
-            let noop = return ()
             map <- readTVar (retrymap server)
-            let mb = Map.lookup addr map
-            action <-
-                maybe (return noop)
-                      (\(v,d) -> do writeTVar v False
-                                    return $ interruptDelay d)
-                      mb
+            action <- case Map.lookup addr map of
+                Nothing    -> return $ return ()
+                Just (v,d) -> do writeTVar v False
+                                 return $ interruptDelay d
             v <- newTVar True
-            writeTVar (retrymap server) (Map.insert addr (v,timer) map)
-            return (v,action)
+            writeTVar (retrymap server) $! Map.insert addr (v,timer) map
+            return (v,action :: IO ())
         action
         fix $ \retryLoop -> do
         utc <- getCurrentTime