More strictness.

3 files changed, 15 insertions, 13 deletions

diff --git a/src/Network/BitTorrent/DHT/ContactInfo.hs b/src/Network/BitTorrent/DHT/ContactInfo.hs
index 26bdeae9..f9dae567 100644
--- a/src/Network/BitTorrent/DHT/ContactInfo.hs
+++ b/src/Network/BitTorrent/DHT/ContactInfo.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 module Network.BitTorrent.DHT.ContactInfo
        ( PeerStore
        , Network.BitTorrent.DHT.ContactInfo.lookup
@@ -120,8 +121,8 @@ newtype PeerStore ip = PeerStore (HashMap InfoHash (SwarmData ip))
 type Timestamp = POSIXTime
 
 data SwarmData ip = SwarmData
-    { peers :: PSQ (PeerAddr ip) Timestamp
-    , name :: Maybe ByteString
+    { peers :: !(PSQ (PeerAddr ip) Timestamp)
+    , name :: !(Maybe ByteString)
     }
 
 
@@ -210,16 +211,16 @@ freshPeers ih tm (PeerStore m) = fromMaybe ([],PeerStore m) $ do
                     _         -> peers swarm
         ps = L.map (key . fst) ps0
         m' = HM.insert ih swarm { peers = L.foldl' (\q p -> PSQ.insert p tm q) peers' ps } m
-    return (ps,PeerStore m')
+    return $! (ps,PeerStore m')
 
 incomp :: (x -> Maybe (r,x)) -> x -> Maybe ((r,x),x)
-incomp f x = do
+incomp !f !x = do
    (result,x') <- f x
-   pure $ ( (result,x'), x' )
+   pure $! ( (result,x'), x' )
 
 -- | Used in 'announce_peer' DHT queries.
 insertPeer :: Ord a => InfoHash -> Maybe ByteString -> PeerAddr a -> PeerStore a -> PeerStore a
-insertPeer ih name a (PeerStore m) = PeerStore (HM.insertWith swarmInsert ih a' m)
+insertPeer !ih !name !a !(PeerStore m) = seq a' $ PeerStore (HM.insertWith swarmInsert ih a' m)
  where
     a' = SwarmData { peers = PSQ.singleton a 0
                    , name = name }
diff --git a/src/Network/BitTorrent/DHT/Routing.hs b/src/Network/BitTorrent/DHT/Routing.hs
index 3c2e30aa..5c9788dc 100644
--- a/src/Network/BitTorrent/DHT/Routing.hs
+++ b/src/Network/BitTorrent/DHT/Routing.hs
@@ -14,6 +14,7 @@
 --   <http://www.bittorrent.org/beps/bep_0005.html#routing-table>
 --
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE BangPatterns    #-}
 {-# LANGUAGE ViewPatterns    #-}
 {-# LANGUAGE TypeOperators   #-}
 {-# LANGUAGE DeriveGeneric   #-}
@@ -231,8 +232,8 @@ bucketQ = seqQ
 --   very unlikely that all nodes in bucket fail within an hour of
 --   each other.
 --
-data Bucket ip = Bucket { bktNodes :: PSQ (NodeInfo ip) Timestamp
-                        , bktQ     :: BucketQueue ip
+data Bucket ip = Bucket { bktNodes :: !(PSQ (NodeInfo ip) Timestamp)
+                        , bktQ     :: !(BucketQueue ip)
                         } deriving (Show,Generic)
 
 instance (Eq ip, Serialize ip) => Serialize (Bucket ip) where
@@ -531,13 +532,13 @@ modifyBucket
 modifyBucket nodeId f = go (0 :: BitIx)
   where
     go :: BitIx -> Table ip -> Maybe (xs, Table ip)
-    go i (Zero table  bucket)
+    go !i (Zero table  bucket)
       | testIdBit nodeId i  = second (Zero  table) <$> f bucket
       |     otherwise       = second (`Zero` bucket) <$> go (succ i) table
-    go i (One  bucket table )
+    go !i (One  bucket table )
       | testIdBit nodeId i  = second (One  bucket)   <$> go (succ i) table
       |     otherwise       = second (`One` table)   <$> f bucket
-    go i (Tip nid n bucket)
+    go !i (Tip nid n bucket)
       |        n == 0       = second (Tip nid n)    <$> f bucket
       |     otherwise       = second (Tip nid n)    <$> f bucket
                            <|>  go i (splitTip nid n i bucket)
diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs
index 22d111e2..66de6548 100644
--- a/src/Network/KRPC/Manager.hs
+++ b/src/Network/KRPC/Manager.hs
@@ -466,14 +466,14 @@ handleMessage raw (E e) = handleResponse raw (Left  e)
 listener :: MonadKRPC h m => m ()
 listener = do
   Manager {..} <- getManager
-  forever $ do
+  fix $ \again -> do
     (bs, addr) <- liftIO $ do
       handle exceptions $ BS.recvFrom sock (optMaxMsgSize options)
-
     case BE.parse bs >>= \r -> (,) r <$> BE.decode bs of
       -- TODO ignore unknown messages at all?
       Left  e       -> liftIO $ sendMessage sock addr $ unknownMessage e
       Right (raw,m) -> handleMessage raw m addr
+    again
   where
     exceptions :: IOError -> IO (BS.ByteString, SockAddr)
     exceptions e