FileSystem: add read/write stats

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)
 

diff --git a/src/FuncTorrent/Peer.hs b/src/FuncTorrent/Peer.hs
index bd66f99a43ef5c0f0357a56fd32ec4cc00c3b781..05ecc3c961351ddff93b24de9e863f38cb25b749 100644 (file)
--- a/src/FuncTorrent/Peer.hs
+++ b/src/FuncTorrent/Peer.hs
@@ -19,7 +19,7 @@ import FuncTorrent.Metainfo (Metainfo(..))
 import FuncTorrent.PeerMsgs (Peer(..), PeerMsg(..), sendMsg, getMsg, genHandshakeMsg)
 import FuncTorrent.Utils (splitNum, verifyHash)
 import FuncTorrent.PieceManager (PieceDlState(..), PieceData(..), PieceMap, pickPiece, updatePieceAvailability)
-import qualified FuncTorrent.FileSystem as FS (MsgChannel, writePiece, Piece(..))
+import qualified FuncTorrent.FileSystem as FS (MsgChannel, writePieceToDisk, Piece(..))
 
 data PState = PState { handle :: Handle
                      , peer :: Peer
@@ -116,7 +116,7 @@ msgLoop pieceStatus msgchannel = do
             liftIO $ putStrLn "Hash mismatch"
             else do
             liftIO $ putStrLn $ "Write piece: " ++ show workPiece
-            liftIO $ FS.writePiece msgchannel workPiece pBS
+            liftIO $ FS.writePieceToDisk msgchannel workPiece pBS
             msgLoop (adjust (\pieceData -> pieceData { dlstate = Have }) workPiece pieceStatus) msgchannel
     _ -> do
       msg <- liftIO $ getMsg h

diff --git a/src/main/Main.hs b/src/main/Main.hs
index 4efd36f37fc2dbe500cb11ca5aa1aa61fd567f97..c641fa065aa81e084ba5201510a4924050a177ef 100644 (file)
--- a/src/main/Main.hs
+++ b/src/main/Main.hs
@@ -4,9 +4,10 @@ module Main where
 import           Prelude hiding (log, length, readFile, getContents)
 
 import           Control.Concurrent (forkIO, killThread)
+import           Control.Monad.State (liftIO)
 import           Control.Concurrent.MVar (readMVar)
 import           Data.ByteString.Char8 (ByteString, getContents, readFile)
-import qualified FuncTorrent.FileSystem as FS (createMsgChannel, pieceMapFromFile, startThread)
+import qualified FuncTorrent.FileSystem as FS (createMsgChannel, pieceMapFromFile, run)
 import           FuncTorrent.Logger (initLogger, logMessage, logStop)
 import           FuncTorrent.Metainfo (Info(..), Metainfo(..), torrentToMetainfo)
 import           FuncTorrent.Peer (handlePeerMsgs)
@@ -75,7 +76,7 @@ main = do
        log $ "Downloading file : " ++ filePath
        pieceMap <- FS.pieceMapFromFile filePath fileLen defaultPieceMap
        log $ "start filesystem manager thread"
-       fsTid <- withFile filePath ReadWriteMode (FS.startThread pieceMap fsMsgChannel)
+       fsTid <- forkIO $ withFile filePath ReadWriteMode (FS.run pieceMap fsMsgChannel)
        log $ "starting server"
        (serverSock, (PortNumber portnum)) <- Server.start
        log $ "server started on " ++ show portnum