diff --git a/functorrent.cabal b/functorrent.cabal index 28f6c97..0e5e445 100644 --- a/functorrent.cabal +++ b/functorrent.cabal @@ -48,7 +48,6 @@ library QuickCheck, tasty, tasty-hunit, - lens, transformers, unix @@ -70,7 +69,6 @@ executable functorrent network, network-uri, parsec, - lens, transformers, unix @@ -118,5 +116,4 @@ test-suite control-thread-tests QuickCheck, tasty, tasty-hunit, - functorrent, - lens + functorrent diff --git a/src/FuncTorrent/Bencode.hs b/src/FuncTorrent/Bencode.hs index 2fb1228..ef6d12f 100644 --- a/src/FuncTorrent/Bencode.hs +++ b/src/FuncTorrent/Bencode.hs @@ -12,14 +12,15 @@ module FuncTorrent.Bencode import Prelude hiding (length, concat) -import Control.Applicative ((<*)) +import Control.Applicative ((<*)) -- This will cause a warning in 7.10. import Data.ByteString (ByteString, length, concat) import Data.ByteString.Char8 (unpack, pack) -import Data.Functor ((<$>)) +import Data.Functor ((<$>)) -- This will cause a warning in 7.10. import Data.Map.Strict (Map, fromList, toList) + +import Test.QuickCheck import Text.ParserCombinators.Parsec import qualified Text.Parsec.ByteString as ParsecBS -import Test.QuickCheck data BVal = Bint Integer | Bstr ByteString @@ -146,8 +147,8 @@ bencVal = Bstr <$> bencStr <|> Bdict <$> bencDict decode :: ByteString -> Either String BVal -decode bs = case (parse bencVal "BVal" bs) of - Left e -> Left "Unable to parse torrent file" +decode bs = case parse bencVal "BVal" bs of + Left _ -> Left "Unable to parse torrent file" Right torrent -> Right torrent -- Encode BVal into a bencoded ByteString. Inverse of decode diff --git a/src/FuncTorrent/ControlThread.hs b/src/FuncTorrent/ControlThread.hs index 3278c71..7dfda48 100644 --- a/src/FuncTorrent/ControlThread.hs +++ b/src/FuncTorrent/ControlThread.hs @@ -1,31 +1,27 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} module FuncTorrent.ControlThread where import Control.Concurrent -import GHC.Conc -import Control.Lens +import Control.Monad hiding (forM, forM_, mapM, mapM_, msum, sequence, sequence_) import Data.IORef -import Control.Monad hiding ( - forM , forM_ , mapM , mapM_ , msum , sequence , sequence_ ) +import GHC.Conc -import FuncTorrent.Tracker (TrackerResponse(..), tracker, mkTrackerResponse, peers) import FuncTorrent.Bencode (decode) import FuncTorrent.Metainfo (Metainfo(..)) +import FuncTorrent.Tracker (TrackerResponse(..), tracker, mkTrackerResponse, peers) -import FuncTorrent.Peer +import FuncTorrent.Peer (Peer(..)) import FuncTorrent.PeerThread import FuncTorrent.PeerThreadData -data ControlThread = ControlThread { - _metaInfo :: Metainfo - , _trackerResponses :: [TrackerResponse] - , _peerList :: [Peer] - , _peerThreads :: [(PeerThread, ThreadId)] --- , _diskIO_Handle :: Handle - , _controlTStatus :: IORef ControlThreadStatus - , _controlTAction :: IORef ControlThreadAction +data ControlThread = ControlThread + { metaInfo :: Metainfo + , trackerResponses :: [TrackerResponse] + , peerList :: [Peer] + , peerThreads :: [(PeerThread, ThreadId)] + , controlTStatus :: IORef ControlThreadStatus + , controlTAction :: IORef ControlThreadAction } data ControlThreadStatus = @@ -41,9 +37,6 @@ data ControlThreadAction = | Stop deriving (Eq, Show) -makeLenses ''ControlThread - - -- Description -- ControlThread handles all operations for a single torrent -- It is responsible for @@ -66,8 +59,8 @@ controlThreadMain ct = doInitialization :: ControlThread -> IO ControlThread doInitialization ct = getTrackerResponse ct >>= \x -> - let peerInit = take 4 $ x^.peerList - in foldM forkPeerThread x peerInit + let peerInit = take 4 (peerList x) + in foldM forkPeerThread x peerInit mainLoop :: ControlThread -> IO ControlThread mainLoop ct = @@ -82,10 +75,12 @@ mainLoop ct = checkAction where + checkAction :: ControlThread -> IO ControlThread checkAction ct1 = do - putStrLn "Check action" + putStrLn "Check control thread action" + -- TODO: This will cause a 4s delay b/w a ^C and the app going down threadDelay $ 4*1000*1000 - action <- readIORef $ view controlTAction ct1 + action <- readIORef $ controlTAction ct1 case action of FuncTorrent.ControlThread.Stop -> return ct1 _ -> mainLoop ct1 @@ -93,9 +88,9 @@ mainLoop ct = doExit :: ControlThread -> IO () doExit ct = do putStrLn "Doing control-thread exit" - let peerTs = ct ^. peerThreads + let peerTs = peerThreads ct -- let the peer threads stop themselves - mapM_ ((setPeerThreadAction FuncTorrent.PeerThreadData.Stop).fst) peerTs + mapM_ (setPeerThreadAction FuncTorrent.PeerThreadData.Stop . fst) peerTs -- Let the threads run for a while -- We may add delay also if required @@ -108,31 +103,32 @@ doExit ct = do -- if they are blocked due to disk write, then wait and retry -- if thread not responding then kill the thread - unless (null (ct1 ^. peerThreads)) $ doExit ct1 + unless (null (peerThreads ct1)) $ doExit ct1 where clearFinishedThreads :: ControlThread -> IO ControlThread clearFinishedThreads ct1 = do - remainingThreads <- filterM isRunning $ ct1 ^. peerThreads - return (ct1 & peerThreads .~ remainingThreads) + remainingThreads <- filterM isRunning (peerThreads ct1) + return (ct1 {peerThreads = remainingThreads}) where isRunning (_,tid) = threadStatus tid >>= (\x -> return $ ThreadFinished /= x) getTrackerResponse :: ControlThread -> IO ControlThread getTrackerResponse ct = do - response <- tracker (ct^.metaInfo) "-HS0001-*-*-20150215" - + response <- tracker (metaInfo ct) "-HS0001-*-*-20150215" + -- TODO: Write to ~/.functorrent/caches -- writeFile (name (info m) ++ ".cache") response - + case decode response of Right trackerInfo -> case mkTrackerResponse trackerInfo of Right trackerResp -> - let ct1 = trackerResponses %~ (trackerResp : ) $ ct - ct2 = peerList %~ ((peers trackerResp) ++) $ ct1 - in return ct2 + let newTrackerResponses = trackerResp : trackerResponses ct + newPeerList = peerList ct ++ peers trackerResp + in return ct {trackerResponses = newTrackerResponses, + peerList = newPeerList} Left _ -> putStrLn "mkTracker error" >> return ct Left _ -> putStrLn "tracker resp decode error" >> return ct @@ -140,65 +136,19 @@ getTrackerResponse ct = do forkPeerThread :: ControlThread -> Peer -> IO ControlThread forkPeerThread ct p = do pt <- initPeerThread p - return (peerThreads %~ (pt : ) $ ct) -- Append pt to peerThreads - --- First try to stop and let the thread exit gracefully. --- If it does not work, then give thread a kill signal -killPeerThread :: ControlThread -> (PeerThread, ThreadId) -> IO ControlThread -killPeerThread _ _ = undefined + let newPeerThreads = pt : peerThreads ct -- Append pt to peerThreads + return ct { peerThreads = newPeerThreads} -- Piece Management Stuff - pieceManagement :: ControlThread -> IO ControlThread pieceManagement ct = do - putStrLn "Doing Piece Management" + putStrLn "Manage pieces" return ct - --let peerTs = map fst $ ct^.peerThreads - --s <- getIncrementalPeerThreadStatus peerTs - --p <- samplePieceAvailability peerTs - --let u = incrementalJobAssign s p [] - --do updatePeerPieceQueue u - -- return ct - -updatePeerPieceQueue :: [(PeerThread, [Piece])] -> IO () -updatePeerPieceQueue = - mapM_ (\x -> do - ts <- takeMVar $ fst x ^. transferStats - let tsnew = queuePieces .~ snd x $ ts - putMVar (fst x ^.transferStats) tsnew) - - --- Get information about what pieces are currently downloading + downloaded after the previous status update -getIncrementalPeerThreadStatus :: [PeerThread] -> IO [(PeerThread, [Piece])] -getIncrementalPeerThreadStatus = - mapM (\x -> do - ts <- takeMVar $ x^.transferStats - let ps = ts^.activePieces ++ ts^.downloadedInc - tsnew = downloadedInc .~ [] $ ts - putMVar (x^.transferStats) tsnew - return (x,ps)) - - --- Sample current piece availability -samplePieceAvailability :: [PeerThread] -> IO [(PeerThread, [Piece])] -samplePieceAvailability = mapM (\x -> do - y <- takeMVar $ x^.peerPieces - return (x,y)) - --- Uses the piece availability to distribute the download jobs to peers --- This should be used to initialize the job distribution -initialJobAssign :: [(PeerThread, [Piece])] -> [(PeerThread, [Piece])] -initialJobAssign p = p - --- Take the initial job assignment, availability and the progress --- of each peer to decide incremental job distribution. --- This API also need to do load-balancing --- Additionaly this can also compute the peer ranking -incrementalJobAssign :: [(PeerThread, [Piece])] -> [(PeerThread, [Piece])] -> [(PeerThread, [Piece])] -> [(PeerThread, [Piece])] -incrementalJobAssign p _ _ = p filterBadPeers :: ControlThread -> IO ControlThread -filterBadPeers ct = putStrLn "FilterBadPeer" >> return ct +filterBadPeers ct = do + putStrLn "Filter bad peers" + return ct initControlThread :: Metainfo -> IO (ControlThread, ThreadId) initControlThread m = do diff --git a/src/FuncTorrent/Peer.hs b/src/FuncTorrent/Peer.hs index be2b567..acbad9b 100644 --- a/src/FuncTorrent/Peer.hs +++ b/src/FuncTorrent/Peer.hs @@ -8,43 +8,38 @@ module FuncTorrent.Peer import Prelude hiding (lookup, concat, replicate, splitAt) -import System.IO +import Control.Applicative (liftA3) +import Control.Monad (replicateM, liftM, forever) +import Data.Binary (Binary(..), decode) +import Data.Binary.Get (getWord32be, getWord16be, getWord8, runGet) +import Data.Binary.Put (putWord32be, putWord16be, putWord8) import Data.ByteString (ByteString, pack, unpack, concat, hGet, hPut, singleton) import Data.ByteString.Lazy (fromStrict, fromChunks) -import qualified Data.ByteString.Char8 as BC (replicate, pack) +import Data.Functor ((<$>)) -- This will cause a warning in 7.10. import Network (connectTo, PortID(..)) -import Data.Binary (Binary(..), decode) -import Data.Binary.Put (putWord32be, putWord16be, putWord8) -import Data.Binary.Get (getWord32be, getWord16be, getWord8, runGet) -import Control.Monad (replicateM, liftM, forever) -import Control.Applicative ((<$>), liftA3) +import System.IO +import qualified Data.ByteString.Char8 as BC (replicate, pack) type ID = String type IP = String type Port = Integer -data PeerState = PeerState { handle :: Handle - , am_choking :: Bool - , am_interested :: Bool - , peer_choking :: Bool - , peer_interested :: Bool} - --- Maintain info on every piece and the current state of it. --- should probably be a TVar. -type Pieces = [PieceData] +data PeerState = PeerState { + handle :: Handle + , amChoking :: Bool + , amInterested :: Bool + , peerChoking :: Bool + , peerInterested :: Bool + } data PieceState = Pending | InProgress | Have deriving (Show) -data PieceData = PieceData { index :: Int -- ^ Piece number - , peers :: [Peer] -- ^ list of peers who have this piece - , state :: PieceState } -- ^ state of the piece from download perspective. - -- | Peer is a PeerID, IP address, port tuple data Peer = Peer ID IP Port - deriving (Show, Eq) + deriving (Show, Eq) data PeerMsg = KeepAliveMsg | ChokeMsg diff --git a/src/FuncTorrent/PeerThread.hs b/src/FuncTorrent/PeerThread.hs index 12a0c30..1a8bcb1 100644 --- a/src/FuncTorrent/PeerThread.hs +++ b/src/FuncTorrent/PeerThread.hs @@ -8,7 +8,6 @@ module FuncTorrent.PeerThread where -- For each peer a separate instance of PeerThread is used import Control.Concurrent -import Control.Lens import Data.IORef import FuncTorrent.Peer @@ -21,19 +20,19 @@ import FuncTorrent.PeerThreadMain (peerThreadMain) #endif --- PeerThread is responsible for +-- PeerThread is responsible for -- 1. Hand-shake with peer -- 2. Keeping track of peer state and managing our state with peer. -- This includes the choke/interested status and have properties. --- +-- -- 3. Initiate request to get data. -- The main thread will allocate a bunch of blocks for fetching from the peer. --- +-- -- 4. Respond to data-request. -- Algo to manage data-request -- -- 5. Do data checking and disk IO. (Disk IO might be handled in a separate thread?) --- +-- -- 6. If needed, keep the connection alive. -- @@ -65,10 +64,10 @@ stopPeerThread _ = undefined -- Control thread will get status from this API -- It should not block due to Peer-Thread getPeerThreadStatus :: PeerThread -> IO (Maybe PeerThreadStatus) -getPeerThreadStatus pt = tryReadMVar $ pt^.peerTStatus +getPeerThreadStatus pt = tryReadMVar $ peerTStatus pt -- Peer Thread may block, if no action is recieved from Control-thread -- It may also kill itself if no communication from Control-thread for some time. setPeerThreadAction :: PeerThreadAction -> PeerThread -> IO Bool -setPeerThreadAction a pt = tryPutMVar (pt^.peerTAction) a +setPeerThreadAction a pt = tryPutMVar (peerTAction pt) a diff --git a/src/FuncTorrent/PeerThreadData.hs b/src/FuncTorrent/PeerThreadData.hs index 28e01c5..cdb8865 100644 --- a/src/FuncTorrent/PeerThreadData.hs +++ b/src/FuncTorrent/PeerThreadData.hs @@ -1,55 +1,54 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +module FuncTorrent.PeerThreadData + (PeerThread(..), + PeerThreadAction(..), + PeerThreadStatus(..), + Piece, + TransferStats(..) + ) where -module FuncTorrent.PeerThreadData where - -import Control.Concurrent -import Control.Lens -import Data.IORef +import Control.Concurrent (MVar, ThreadId) +import Data.IORef (IORef) import FuncTorrent.Peer -data PeerThread = PeerThread { - _peer :: Peer - , _peerTStatus :: MVar PeerThreadStatus - , _peerTAction :: MVar PeerThreadAction - , _transferStats :: MVar TransferStats - , _peerPieces :: MVar [Piece] - , _downloadThread :: IORef (Maybe ThreadId) - } - -data PeerThreadStatus = - PeerCommError - | InitDone - | PeerReady - | PeerBusy - | Downloading - | Seeding - deriving (Eq,Show) - -data PeerThreadAction = - InitPeerConnection - | GetPeerStatus - | GetPieces [Piece] - | Seed - | StayIdle - | Stop - deriving (Eq,Show) - type Piece = Int --- DownloadedInc has Pieces which were downloaded --- after the last status fetch from ControlThread -data TransferStats = TransferStats { - _activePieces :: [Piece] - , _downloadedInc :: [Piece] - , _downloaded :: [Piece] - , _queuePieces :: [Piece] - , _dataRecieved :: Int - , _dataSent :: Int - , _totalDataR :: Int - , _totalDataS :: Int +data PeerThreadStatus + = PeerCommError + | InitDone + | PeerReady + | PeerBusy + | Downloading + | Seeding + deriving (Eq,Show) + +data PeerThreadAction + = InitPeerConnection + | GetPeerStatus + | GetPieces [Piece] + | Seed + | StayIdle + | Stop + deriving (Eq,Show) + +data PeerThread = PeerThread + { peer :: Peer + , peerTStatus :: MVar PeerThreadStatus + , peerTAction :: MVar PeerThreadAction + , transferStats :: MVar TransferStats + , peerPieces :: MVar [Piece] + , downloadThread :: IORef (Maybe ThreadId) } -makeLenses ''PeerThread -makeLenses ''TransferStats +data TransferStats = TransferStats + { activePieces :: [Piece] + -- | Pieces which were downloaded after the last status fetch from + -- ControlThread + , downloadedInc :: [Piece] + , downloaded :: [Piece] + , queuePieces :: [Piece] + , dataRecieved :: Int + , dataSent :: Int + , totalDataR :: Int + , totalDataS :: Int + } diff --git a/src/FuncTorrent/PeerThreadMain.hs b/src/FuncTorrent/PeerThreadMain.hs index b502ba7..ef235dd 100644 --- a/src/FuncTorrent/PeerThreadMain.hs +++ b/src/FuncTorrent/PeerThreadMain.hs @@ -1,15 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} module FuncTorrent.PeerThreadMain - ( peerThreadMain + ( peerThreadMain ) where import Prelude hiding (readFile) import Control.Concurrent -import Control.Monad hiding ( - forM , forM_ , mapM , mapM_ , msum , sequence , sequence_ ) -import Control.Lens +import Control.Monad hiding (forM, forM_, mapM, mapM_, msum, sequence, sequence_) import Data.IORef import FuncTorrent.PeerThreadData @@ -18,7 +16,7 @@ import FuncTorrent.PeerThreadData -- 1. Initiate hand-shake and set bit field? -- 2. Send peer our status (choked/interested) -- 3. Wait for peer status. --- 4. If the peer is interested, then do further communication. +-- 4. If the peer is interested, then do further communication. -- Else show that we are interested and wait. -- 5. Send the 'have' message. -- 6. Recieve the 'have' message. @@ -31,9 +29,7 @@ peerThreadMain pt = do case toDoAction of InitPeerConnection -> do response <- doHandShake pt - if not response - then setStatus PeerCommError - else setStatus InitDone + setStatus (if not response then PeerCommError else InitDone) GetPeerStatus -> setStatus PeerReady @@ -52,8 +48,8 @@ peerThreadMain pt = do unless (toDoAction == Stop) $ peerThreadMain pt - where setStatus = putMVar (pt^.peerTStatus) - getAction = takeMVar (pt^.peerTAction) + where setStatus = putMVar (peerTStatus pt) + getAction = takeMVar (peerTAction pt) -- Fork a thread to get pieces from the peer. -- The incoming requests from this peer will be handled @@ -62,10 +58,10 @@ peerThreadMain pt = do startDownload :: PeerThread -> IO () startDownload pt = do tid <- forkIO $ downloadData pt - writeIORef (pt^.downloadThread) (Just tid) + writeIORef (downloadThread pt) (Just tid) stopDownload :: PeerThread -> IO () -stopDownload pt = putStrLn $ "Stopping peer-thread " ++ show (pt^.peer) +stopDownload pt = putStrLn $ "Stopping peer-thread " ++ show (peer pt) -- This will do the actual data communication with peer downloadData :: PeerThread -> IO () @@ -84,7 +80,6 @@ downloadData _ = undefined doHandShake :: PeerThread -> IO Bool doHandShake pt = do - putStrLn $ "HandShake with " ++ show (pt^.peer) + putStrLn $ "HandShake with " ++ show (peer pt) return True -- timeout (10*1000*1000) handShake - diff --git a/src/FuncTorrent/ServerThread.hs b/src/FuncTorrent/ServerThread.hs index 0b55206..024da3b 100644 --- a/src/FuncTorrent/ServerThread.hs +++ b/src/FuncTorrent/ServerThread.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE LambdaCase #-} module FuncTorrent.ServerThread where @@ -7,18 +6,15 @@ module FuncTorrent.ServerThread where import Control.Concurrent import Control.Monad.IO.Class import Control.Monad.Trans.Maybe -import Control.Lens import Data.ByteString (ByteString) import System.IO import Network - import FuncTorrent.Metainfo (Metainfo(..)) import FuncTorrent.Peer import FuncTorrent.PeerThreadData import FuncTorrent.ControlThread - -- Torrent Server thread -- This thread has reposibility to serve all incoming requests -- @@ -30,66 +26,63 @@ import FuncTorrent.ControlThread -- -- 3. Handle data request messages - For this create a PeerThread -- and let it upload. --- --- 4. --- -data ServerThread = ServerThread { - _activeTorrents :: MVar [(Metainfo, ControlThread)] - , _blockedPeers :: MVar [Peer] - , _activeTransfers :: MVar [(Peer, PeerThread)] - , _listenThread :: MVar ThreadId - , _listenPortNum :: PortNumber - , _serverTStatus :: Int - , _serverTAction :: MVar ServerThreadAction +data ServerThread = ServerThread + { activeTorrents :: MVar [(Metainfo, ControlThread)] + , blockedPeers :: MVar [Peer] + , activeTransfers :: MVar [(Peer, PeerThread)] + , listenThread :: MVar ThreadId + , listenPortNum :: PortNumber + , serverTStatus :: Int + , serverTAction :: MVar ServerThreadAction } -data ServerThreadAction = - Seed - | AddTorrent (Metainfo, ControlThread) - | RemoveTorrent Metainfo - | Stop - -makeLenses ''ServerThread +data ServerThreadAction + = Seed + | AddTorrent (Metainfo, ControlThread) + | RemoveTorrent Metainfo + | Stop serverThreadMain :: ServerThread -> IO () serverThreadMain st = serverInit st >>= serverMainLoop >>= serverExit where serverExit st1 = do - tid <- takeMVar (st1^.listenThread) + tid <- takeMVar (listenThread st1) killThread tid putStrLn "Exiting server-thread" serverInit :: ServerThread -> IO ServerThread serverInit st = do tid <- forkIO $ listenAndReply st - putMVar (st^.listenThread) tid + putMVar (listenThread st) tid return st serverMainLoop :: ServerThread -> IO ServerThread serverMainLoop = handleAction - where + where handleAction st1 = - takeMVar (st1 ^. serverTAction) >>= + takeMVar (serverTAction st1) >>= \case - FuncTorrent.ServerThread.Seed -> + FuncTorrent.ServerThread.Seed -> serverMainLoop st1 AddTorrent t -> do - a <- readMVar (st1^.activeTorrents) - putMVar (st1^.activeTorrents) (t:a) + a <- readMVar (activeTorrents st1) + putMVar (activeTorrents st1) (t : a) serverMainLoop st1 RemoveTorrent m -> do - a <- readMVar (st1^.activeTorrents) + a <- readMVar (activeTorrents st1) let a1 = filter ((/=m).fst) a - putMVar (st1^.activeTorrents) a1 + putMVar (activeTorrents st1) a1 serverMainLoop st1 FuncTorrent.ServerThread.Stop -> return st1 listenAndReply :: ServerThread -> IO () listenAndReply st = - listenOn (PortNumber (st ^. listenPortNum)) >>= accept >>= - checkHandShakeMsgAndForkNewThread st >>= listenAndReply + listenOn (PortNumber (listenPortNum st)) >>= + accept >>= + checkHandShakeMsgAndForkNewThread st >>= + listenAndReply checkHandShakeMsgAndForkNewThread :: ServerThread -> (Handle, HostName, PortNumber) -> IO ServerThread checkHandShakeMsgAndForkNewThread st (h, peerName, peerPort) = @@ -97,8 +90,8 @@ checkHandShakeMsgAndForkNewThread st (h, peerName, peerPort) = \case Nothing -> hClose h >> return st Just ct -> forkPeerThreadWrap st ct peerName peerPort - - where + + where sendResponse = do hash <- getHash h (m,ct) <- MaybeT . return $ findHash st hash @@ -106,7 +99,7 @@ checkHandShakeMsgAndForkNewThread st (h, peerName, peerPort) = return ct getHash :: Handle -> MaybeT IO ByteString -getHash h = MaybeT . return $ Nothing +getHash _ = MaybeT . return $ Nothing findHash :: ServerThread -> ByteString -> Maybe (Metainfo, ControlThread) findHash = undefined @@ -118,7 +111,7 @@ forkPeerThreadWrap :: ServerThread -> ControlThread -> HostName -> PortNumber -> forkPeerThreadWrap = undefined initServerThread :: [(Metainfo, ControlThread)] -> IO (ServerThread, ThreadId) -initServerThread cts = do +initServerThread _ = do mv1 <- newEmptyMVar mv2 <- newEmptyMVar mv3 <- newEmptyMVar @@ -126,5 +119,5 @@ initServerThread cts = do mv5 <- newEmptyMVar let pn = 14560 let st = ServerThread mv1 mv2 mv3 mv4 pn 0 mv5 - tid <- forkIO $ serverThreadMain st + tid <- forkIO $ serverThreadMain st return (st, tid) diff --git a/src/Main.hs b/src/Main.hs index 4731318..a39956e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -9,21 +9,17 @@ module Main where import Prelude hiding (log, length, readFile, writeFile) import Control.Concurrent -import Control.Concurrent.MVar -import Control.Lens +import Control.Monad (liftM) import Data.ByteString (ByteString) -import Data.ByteString.Char8 (readFile, writeFile, unpack) +import Data.ByteString.Char8 (readFile) import Data.IORef import System.Directory (doesFileExist) import System.Environment (getArgs) import System.Posix.Signals (installHandler, Handler(Catch), sigINT, sigTERM) -import Text.ParserCombinators.Parsec (ParseError) import FuncTorrent.Bencode (decode) -import FuncTorrent.Logger (Log, initLogger, logMessage, logError, logStop) -import FuncTorrent.Metainfo (Info(..), Metainfo(..), mkMetaInfo) -import FuncTorrent.Peer (handShake) -import FuncTorrent.Tracker (tracker, peers, mkTrackerResponse) +import FuncTorrent.Logger (Log, initLogger, logMessage, logStop) +import FuncTorrent.Metainfo (Metainfo(..), mkMetaInfo) import FuncTorrent.ControlThread import FuncTorrent.ServerThread @@ -44,7 +40,7 @@ main = do case minfo of Right m -> startTorrentConc log m Left err -> log err - [] -> usage + _ -> usage logStop logR @@ -53,47 +49,22 @@ usage = putStrLn "Usage: functorrent torrent-file" parseTorrentFile :: Log -> String -> IO (Either String Metainfo) -parseTorrentFile log file = do +parseTorrentFile _ file = do fileExist <- doesFileExist file if fileExist - then readFile file >>= return . getMetaInfo + then liftM getMetaInfo (readFile file) else return $ Left "File does not exist" where getMetaInfo :: ByteString -> Either String Metainfo getMetaInfo torrentStr = decode torrentStr >>= mkMetaInfo -startTorrent :: Log -> [Metainfo] -> IO () -startTorrent log (m:_) = do - log "Input File OK" - log $ "Downloading file : " ++ name (info m) - log "Trying to fetch peers" - - log $ "Trackers: " ++ head (announceList m) - response <- tracker m peerId - - -- TODO: Write to ~/.functorrent/caches - writeFile (name (info m) ++ ".cache") response - case decode response of - Left e -> logError log e - Right trackerInfo -> - case mkTrackerResponse trackerInfo of - Left e -> log $ "Error" ++ unpack e - Right peerResp -> do - log $ "Peers List : " ++ (show . peers $ peerResp) - let p1 = head (peers peerResp) - msg <- handShake p1 (infoHash m) peerId - log $ "handshake: " ++ show msg - return () - -startTorrent _ [] = return () - startTorrentConc :: Log -> Metainfo -> IO () -startTorrentConc log m = do +startTorrentConc _ m = do -- Handle user-interrupt interrupt <- newEmptyMVar - _ <- installHandler sigINT (Catch $ putMVar interrupt 1) Nothing - _ <- installHandler sigTERM (Catch $ putMVar interrupt 1) Nothing + _ <- installHandler sigINT (Catch $ putMVar interrupt sigINT) Nothing + _ <- installHandler sigTERM (Catch $ putMVar interrupt sigTERM) Nothing -- Fork Control-Thread(s) (ct,_) <- initControlThread m @@ -105,7 +76,7 @@ startTorrentConc log m = do _ <- takeMVar interrupt -- Exit gracefully - putMVar (st ^. serverTAction) FuncTorrent.ServerThread.Stop - writeIORef (ct ^. controlTAction) FuncTorrent.ControlThread.Stop + putMVar (serverTAction st) FuncTorrent.ServerThread.Stop + writeIORef (controlTAction ct) FuncTorrent.ControlThread.Stop yield threadDelay $ 4*1000*1000 diff --git a/test/ControlThreadTests.hs b/test/ControlThreadTests.hs index f9c25d2..45f1c74 100644 --- a/test/ControlThreadTests.hs +++ b/test/ControlThreadTests.hs @@ -2,27 +2,16 @@ module ControlThreadTests where -import Prelude hiding (readFile) -import Control.Lens -import System.IO -import Control.Concurrent - --- import Test.Tasty.HUnit (testCase, (@?=)) - import FuncTorrent.ControlThread hiding (controlThreadMain) -import FuncTorrent.Peer -import FuncTorrent.PeerThread -import FuncTorrent.PeerThreadData -import PeerThreadMock doTests :: IO () doTests = putStrLn "Not Implemented" controlThreadMain :: ControlThread -> IO () -controlThreadMain ct = undefined +controlThreadMain _ = undefined - -- controlThreadMain ct2 - -- If PeerThread is busy status will be Nothing +-- controlThreadMain ct2 +-- If PeerThread is busy status will be Nothing -- Control activity of Peer-Threads diff --git a/test/PeerThreadMock.hs b/test/PeerThreadMock.hs index 843bfe7..417ea3c 100644 --- a/test/PeerThreadMock.hs +++ b/test/PeerThreadMock.hs @@ -1,26 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} -module PeerThreadMock - ( peerThreadMain - ) where +module PeerThreadMock + ( + peerThreadMain + ) where import Prelude hiding (readFile) --- import Test.Tasty.HUnit (testCase, (@?=)) --- --- import FuncTorrent.ControlThread - import Control.Concurrent -import Control.Lens -import System.Timeout -import Data.IORef -import System.IO import FuncTorrent.PeerThreadData peerThreadMain :: PeerThread -> IO () peerThreadMain pt = do toDoAction <- getAction + -- TODO: Non exhaustive pattern match case toDoAction of InitPeerConnection -> do threadDelay $ 1000*1000 @@ -30,7 +24,7 @@ peerThreadMain pt = do threadDelay $ 1000*1000 setStatus PeerReady - GetPieces piece -> + GetPieces _ -> setStatus Downloading Seed -> @@ -41,5 +35,5 @@ peerThreadMain pt = do peerThreadMain pt - where setStatus = putMVar (pt^.peerTStatus) - getAction = takeMVar (pt^.peerTAction) + where setStatus = putMVar (peerTStatus pt) + getAction = takeMVar (peerTAction pt)