FileSystem: add read/write stats

[functorrent.git] / src / FuncTorrent / FileSystem.hs

diff --git a/src/FuncTorrent/FileSystem.hs b/src/FuncTorrent/FileSystem.hs
index df203b09b752c0f8cf17bd5c398e72b5ea136df1..bfaf674af4705dde49054c3e89e92d349601bbfb 100644 (file)
--- a/src/FuncTorrent/FileSystem.hs
+++ b/src/FuncTorrent/FileSystem.hs
@@ -1,20 +1,21 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
 module FuncTorrent.FileSystem
-       (startThread,
+       (run,
         MsgChannel,
         createMsgChannel,
-        writePiece,
+        writePieceToDisk,
         Piece(..),
         pieceMapFromFile
        )
        where
 
-import           Control.Concurrent (ThreadId, forkIO)
 import           Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
 import           Control.Concurrent.MVar (MVar, putMVar)
 import           Control.Monad (forever)
-import           Data.Map (traverseWithKey)
+import           Control.Monad.State (StateT, liftIO, runStateT, modify)
 import qualified Data.ByteString as BS
-import           Data.Map ((!))
+import           Data.Map (traverseWithKey, (!))
 import           System.IO (Handle, IOMode (ReadWriteMode), withFile)
 import           System.Directory (doesFileExist)
 
@@ -30,24 +31,37 @@ data Msg = ReadPiece PieceNum Integer (MVar Piece)
 
 type MsgChannel = Chan Msg
 
+data Stats = Stats { bytesRead :: Integer
+                   , bytesWritten :: Integer
+                   }
+
 createMsgChannel :: IO (Chan Msg)
 createMsgChannel = newChan
 
-startThread :: PieceMap -> MsgChannel -> Handle -> IO ThreadId
-startThread pieceMap c handle = do
-  forkIO $ forever $ recvMsg >>= sendResponse
+run :: PieceMap -> MsgChannel -> Handle -> IO ()
+run pieceMap c handle = do
+  _ <- runStateT (run' pieceMap c handle) initialStats
+  return ()
+    where initialStats = Stats { bytesRead = 0
+                               , bytesWritten = 0 }
+
+run' :: PieceMap -> MsgChannel -> Handle -> StateT Stats IO ()
+run' pieceMap c handle = do
+  msg <- liftIO recvMsg
+  liftIO $ sendResponse msg
+  updateState msg 
   where
     recvMsg = readChan c
     sendResponse msg =
       case msg of
-        ReadPiece n len' var -> do
-          bs <- readPiece n len'
-          putMVar var (Piece n bs)
-        WritePiece (Piece n bs) -> do
-          writePiece n bs
-        VerifyPiece n var -> do
-          isHashValid <- verifyPiece n
-          putMVar var isHashValid
+      ReadPiece n len' var -> do
+        bs <- readPiece n len'
+        putMVar var (Piece n bs)
+      WritePiece (Piece n bs) ->
+        writePiece n bs
+      VerifyPiece n var -> do
+        isHashValid <- verifyPiece n
+        putMVar var isHashValid
     readPiece n len' = do
       let offset = pieceNumToOffset pieceMap n
       readFileAtOffset handle offset len'
@@ -60,6 +74,11 @@ startThread pieceMap c handle = do
           len'   = len (pieceMap ! n)
       bs' <- readFileAtOffset handle offset len'
       return $ verifyHash bs' hash'
+    updateState (ReadPiece _ l _) =
+      modify (\st -> st {bytesRead = bytesRead st + l})
+    updateState (WritePiece (Piece _ bs)) =
+      modify (\st -> st {bytesWritten = bytesWritten st + fromIntegral (BS.length bs)})
+    updateState _ = modify id
 
 pieceMapFromFile :: FilePath -> Integer -> PieceMap -> IO PieceMap
 pieceMapFromFile filePath fileLen pieceMap = do
@@ -75,7 +94,7 @@ pieceMapFromFile filePath fileLen pieceMap = do
         then return $ v { dlstate = Have }
         else return v
 
-writePiece :: MsgChannel -> PieceNum -> BS.ByteString -> IO ()
-writePiece c pieceNum bs = do
+writePieceToDisk :: MsgChannel -> PieceNum -> BS.ByteString -> IO ()
+writePieceToDisk c pieceNum bs =
   writeChan c $ WritePiece (Piece pieceNum bs)