3 files changed, 26 insertions, 22 deletions

diff --git a/src/Network/BitTorrent.hs b/src/Network/BitTorrent.hs
index b6e2eadf..95a4c4e3 100644
--- a/src/Network/BitTorrent.hs
+++ b/src/Network/BitTorrent.hs
@@ -102,7 +102,7 @@ defaultClient = newClient defaultThreadCount defaultExtensions
 -- thus we can obtain an unified interface
 
 discover :: SwarmSession -> P2P () -> IO ()
-discover swarm action = do
+discover swarm action = {-# SCC discover #-} do
   port <- forkListener (error "discover")
 
   let conn = TConnection (tAnnounce (torrentMeta swarm))
@@ -134,7 +134,7 @@ discover swarm action = do
 
 -- | Default P2P action.
 exchange :: Storage -> P2P ()
-exchange storage = awaitEvent >>= handler
+exchange storage = {-# SCC exchange #-} (awaitEvent >>= handler)
   where
     handler (Available bf) = do
       liftIO (print (completeness bf))
diff --git a/src/Network/BitTorrent/Exchange.hs b/src/Network/BitTorrent/Exchange.hs
index 66112f14..9f119d13 100644
--- a/src/Network/BitTorrent/Exchange.hs
+++ b/src/Network/BitTorrent/Exchange.hs
@@ -110,17 +110,21 @@ runPeerWire sock p2p =
   sinkSocket sock
 
 awaitMessage :: P2P Message
-awaitMessage = P2P $ ReaderT $ const go
+awaitMessage = P2P $ ReaderT $ const $ {-# SCC awaitMessage #-} go
   where
     go = await >>= maybe (monadThrow PeerDisconnected) return
 {-# INLINE awaitMessage #-}
 
 yieldMessage :: Message -> P2P ()
-yieldMessage msg = P2P $ ReaderT $ const (C.yield msg)
+yieldMessage msg =  P2P $ ReaderT $ const $ {-# SCC yieldMessage #-} C.yield msg
 {-# INLINE yieldMessage #-}
 
 flushPending :: P2P ()
-flushPending = ask >>= liftIO . getPending >>= mapM_ yieldMessage
+flushPending = {-# SCC flushPending #-} do
+  se <- ask
+  q  <- liftIO (getPending se)
+  -- TODO send vectored
+  mapM_ yieldMessage q
 
 {-----------------------------------------------------------------------
     P2P monad
@@ -321,7 +325,7 @@ data Event
 --     forall (Fragment block). isPiece block == True
 --
 awaitEvent :: P2P Event
-awaitEvent = awaitMessage >>= go
+awaitEvent = {-# SCC awaitEvent #-} awaitMessage >>= go
   where
     go KeepAlive = awaitEvent
     go Choke     = do
@@ -439,22 +443,21 @@ awaitEvent = awaitMessage >>= go
 --   most likely will be ignored without any network IO.
 --
 yieldEvent  :: Event -> P2P ()
-yieldEvent (Available ixs) = asks swarmSession >>= liftIO . available ixs
-yieldEvent (Want      bix) = do
-  offer <- peerOffer
-  if ixPiece bix `BF.member` offer
-     then yieldMessage (Request bix)
-     else return ()
+yieldEvent e = {-# SCC yieldEvent #-} go e
+  where
+    go (Available ixs) = asks swarmSession >>= liftIO . available ixs
+    go (Want      bix) = do
+      offer <- peerOffer
+      if ixPiece bix `BF.member` offer
+        then yieldMessage (Request bix)
+        else return ()
 
-yieldEvent (Fragment  blk) = do
-  offer <- clientOffer
-  if blkPiece blk `BF.member` offer
-    then yieldMessage (Piece blk)
-    else return ()
+    go (Fragment  blk) = do
+      offer <- clientOffer
+      if blkPiece blk `BF.member` offer
+        then yieldMessage (Piece blk)
+        else return ()
 
 
 handleEvent :: (Event -> P2P Event) -> P2P ()
 handleEvent action = awaitEvent >>= action >>= yieldEvent
-
-checkPiece :: PieceLIx -> {-ByteString -> -} P2P Bool
-checkPiece = undefined
diff --git a/src/Network/BitTorrent/Internal.hs b/src/Network/BitTorrent/Internal.hs
index eaeb04e8..5a7e493f 100644
--- a/src/Network/BitTorrent/Internal.hs
+++ b/src/Network/BitTorrent/Internal.hs
@@ -538,7 +538,7 @@ findPieceCount = pieceCount . tInfo . torrentMeta . swarmSession
 -- 3. Signal to the all other peer about this.
 
 available :: Bitfield -> SwarmSession -> IO ()
-available bf se @ SwarmSession {..} = do
+available bf se @ SwarmSession {..} = {-# SCC available #-} do
     mark >> atomically broadcast
   where
     mark = do
@@ -561,7 +561,8 @@ available bf se @ SwarmSession {..} = do
 -- changed client state. Resulting queue should be sent to a peer
 -- immediately.
 getPending :: PeerSession -> IO [Message]
-getPending PeerSession {..} = atomically (readAvail pendingMessages)
+getPending PeerSession {..} = {-# SCC getPending #-} do
+  atomically (readAvail pendingMessages)
 
 readAvail :: TChan a -> STM [a]
 readAvail chan = do