FileSystem: bug fix, run should run for ever

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

diff --git a/src/FuncTorrent/FileSystem.hs b/src/FuncTorrent/FileSystem.hs
index e064b713c68607bd05941e22e5bce8ae64d86ddb..fdf89fa94bae2415d9fa12d572cade889823eebf 100644 (file)
--- a/src/FuncTorrent/FileSystem.hs
+++ b/src/FuncTorrent/FileSystem.hs
@@ -1,21 +1,21 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
 module FuncTorrent.FileSystem
-       (startThread,
+       (run,
         MsgChannel,
         createMsgChannel,
-        Msg(..),
+        writePieceToDisk,
         Piece(..),
         pieceMapFromFile
        )
        where
 
-import           Control.Concurrent (ThreadId, forkIO)
-import           Control.Concurrent.Chan (Chan, newChan, readChan)
+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)
 
@@ -31,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 = forever $ 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
+  updateStats 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'
@@ -61,6 +74,11 @@ startThread pieceMap c handle = do
           len'   = len (pieceMap ! n)
       bs' <- readFileAtOffset handle offset len'
       return $ verifyHash bs' hash'
+    updateStats (ReadPiece _ l _) =
+      modify (\st -> st {bytesRead = bytesRead st + l})
+    updateStats (WritePiece (Piece _ bs)) =
+      modify (\st -> st {bytesWritten = bytesWritten st + fromIntegral (BS.length bs)})
+    updateStats _ = modify id
 
 pieceMapFromFile :: FilePath -> Integer -> PieceMap -> IO PieceMap
 pieceMapFromFile filePath fileLen pieceMap = do
@@ -75,3 +93,8 @@ pieceMapFromFile filePath fileLen pieceMap = do
       if isHashValid
         then return $ v { dlstate = Have }
         else return v
+
+writePieceToDisk :: MsgChannel -> PieceNum -> BS.ByteString -> IO ()
+writePieceToDisk c pieceNum bs =
+  writeChan c $ WritePiece (Piece pieceNum bs)
+