5 files changed, 43 insertions, 35 deletions

diff --git a/src/Data/Bitfield.hs b/src/Data/Bitfield.hs
index 89461fd2..acfca0d0 100644
--- a/src/Data/Bitfield.hs
+++ b/src/Data/Bitfield.hs
@@ -236,28 +236,28 @@ rarest xs
 
 -- | Find indices at least one peer have.
 union :: Bitfield -> Bitfield -> Bitfield
-union a b = Bitfield {
+union a b = {-# SCC union #-} Bitfield {
     bfSize = bfSize a `max` bfSize b
   , bfSet  = bfSet a `S.union` bfSet b
   }
 
 -- | Find indices both peers have.
 intersection :: Bitfield -> Bitfield -> Bitfield
-intersection a b = Bitfield {
+intersection a b = {-# SCC intersection #-} Bitfield {
     bfSize = bfSize a `min` bfSize b
   , bfSet  = bfSet a `S.intersection` bfSet b
   }
 
 -- | Find indices which have first peer but do not have the second peer.
 difference :: Bitfield -> Bitfield -> Bitfield
-difference a b = Bitfield {
+difference a b = {-# SCC difference #-} Bitfield {
     bfSize = bfSize a -- FIXME is it reasonable?
   , bfSet  = bfSet a `S.difference` bfSet b
   }
 
 -- | Find indices the any of the peers have.
 unions :: [Bitfield] -> Bitfield
-unions = foldl' union (haveNone 0)
+unions = {-# SCC unions #-} foldl' union (haveNone 0)
 
 {-----------------------------------------------------------------------
     Serialization
@@ -270,7 +270,7 @@ toList Bitfield {..} = S.toList bfSet
 -- | Unpack 'Bitfield' from tightly packed bit array. Note resulting
 -- size might be more than real bitfield size, use 'adjustSize'.
 fromBitmap :: ByteString -> Bitfield
-fromBitmap bs = Bitfield {
+fromBitmap bs = {-# SCC fromBitmap #-} Bitfield {
     bfSize = B.length bs * 8
   , bfSet  = S.fromByteString bs
   }
@@ -278,7 +278,7 @@ fromBitmap bs = Bitfield {
 
 -- | Pack a 'Bitfield' to tightly packed bit array.
 toBitmap :: Bitfield -> Lazy.ByteString
-toBitmap Bitfield {..} = Lazy.fromChunks [intsetBM, alignment]
+toBitmap Bitfield {..} = {-# SCC toBitmap #-} Lazy.fromChunks [intsetBM, alignment]
   where
     byteSize  = bfSize `div` 8 + if bfSize `mod` 8 == 0 then 0 else 1
     alignment = B.replicate (byteSize - B.length intsetBM) 0
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
diff --git a/src/System/Torrent/Storage.hs b/src/System/Torrent/Storage.hs
index cb0494e8..8a884196 100644
--- a/src/System/Torrent/Storage.hs
+++ b/src/System/Torrent/Storage.hs
@@ -110,7 +110,8 @@ withStorage se path = bracket (se `bindTo` path) unbind
 -- TODO make block_payload :: Lazy.ByteString
 
 selBlk :: MonadIO m => PieceIx -> Storage -> m [BlockIx]
-selBlk pix st @ Storage {..} = liftIO $ atomically $ do
+selBlk pix st @ Storage {..}
+  = liftIO $ {-# SCC selBlk #-} atomically $ do
     mask <- pieceMask pix st
     select mask <$> readTVar blocks
   where
@@ -137,7 +138,8 @@ selBlk pix st @ Storage {..} = liftIO $ atomically $ do
 --
 --
 putBlk :: MonadIO m => Block -> Storage -> m Bool
-putBlk blk @ Block {..}  st @ Storage {..} = liftIO $ do
+putBlk blk @ Block {..}  st @ Storage {..}
+  = liftIO $ {-# SCC putBlk #-} do
 --  let blkIx = undefined
 --  bm <- readTVarIO blocks
 --  unless (member blkIx bm) $ do
@@ -149,7 +151,7 @@ putBlk blk @ Block {..}  st @ Storage {..} = liftIO $ do
     validatePiece blkPiece st
 
 markBlock :: Block -> Storage -> IO ()
-markBlock Block {..} Storage {..} = do
+markBlock Block {..} Storage {..} = {-# SCC markBlock #-} do
   let piLen = pieceLength session
   let glIx  = (piLen `div` blockSize) * blkPiece + (blkOffset `div` blockSize)
   atomically $ modifyTVar' blocks (have glIx)
@@ -160,25 +162,27 @@ markBlock Block {..} Storage {..} = do
 --  Do not block.
 --
 getBlk :: MonadIO m => BlockIx -> Storage -> m Block
-getBlk ix @ BlockIx {..}  st @ Storage {..} = liftIO $ do
+getBlk ix @ BlockIx {..}  st @ Storage {..}
+  = liftIO $ {-# SCC getBlk #-} do
   -- TODO check if __piece__ is available
   bs <- readBytes (ixInterval (pieceLength session) ix) payload
   return $ Block ixPiece ixOffset (Lazy.toStrict bs)
 
 getPiece :: PieceIx -> Storage -> IO ByteString
-getPiece pix st @ Storage {..} = do
+getPiece pix st @ Storage {..} = {-# SCC getPiece #-} do
   let pieceLen = pieceLength session
   let bix      = BlockIx pix 0 (pieceLength session)
   bs <- readBytes (ixInterval pieceLen bix) payload
   return (Lazy.toStrict bs)
 
 resetPiece :: PieceIx -> Storage -> IO ()
-resetPiece pix st @ Storage {..} = atomically $ do
+resetPiece pix st @ Storage {..}
+  = {-# SCC resetPiece #-} atomically $ do
   mask <- pieceMask pix st
   modifyTVar' blocks (`difference` mask)
 
 validatePiece :: PieceIx -> Storage -> IO Bool
-validatePiece pix st @ Storage {..} = do
+validatePiece pix st @ Storage {..} = {-# SCC validatePiece #-} do
   downloaded <- atomically $ isDownloaded pix st
   if not downloaded then return False
     else do