library
exposed-modules: FuncTorrent.Bencode,
+ FuncTorrent.FileSystem,
FuncTorrent.Logger,
FuncTorrent.Metainfo,
FuncTorrent.Network
FuncTorrent.Peer,
FuncTorrent.PeerMsgs,
+ FuncTorrent.PieceManager,
FuncTorrent.Server,
FuncTorrent.Tracker,
FuncTorrent.Utils
--- /dev/null
+module FuncTorrent.FileSystem
+ (startThread,
+ MsgChannel,
+ initFS,
+ Msg(..),
+ Piece(..),
+ pieceMapFromFile
+ )
+ where
+
+import Control.Concurrent (ThreadId, forkIO)
+import Control.Concurrent.Chan (Chan, newChan, readChan)
+import Control.Concurrent.MVar (MVar, putMVar)
+import Control.Monad (forever)
+import Data.Map (traverseWithKey)
+
+import qualified Data.ByteString as BS
+import Data.Map ((!))
+import System.IO (Handle, openFile, IOMode (ReadWriteMode))
+
+import FuncTorrent.PieceManager (PieceDlState(..), PieceData(..), PieceMap, pieceNumToOffset)
+import FuncTorrent.Utils (readFileAtOffset, writeFileAtOffset, verifyHash)
+
+type PieceNum = Integer
+data Piece = Piece PieceNum BS.ByteString
+
+data Msg = ReadPiece PieceNum Integer (MVar Piece)
+ | WritePiece Piece
+ | VerifyPiece PieceNum (MVar Bool)
+
+type MsgChannel = Chan Msg
+
+-- init :: FileName -> IO (Handle, MsgChannel)
+initFS :: FilePath -> IO (Handle, MsgChannel)
+initFS filepath = do
+ c <- newChan
+ h <- openFile filepath ReadWriteMode
+ return (h, c)
+
+startThread :: Handle -> MsgChannel -> PieceMap -> IO ThreadId
+startThread handle c pieceMap = do
+ forkIO $ forever $ recvMsg >>= sendResponse
+ 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' = do
+ let offset = pieceNumToOffset pieceMap n
+ readFileAtOffset handle offset len'
+ writePiece n piece = do
+ let offset = pieceNumToOffset pieceMap n
+ writeFileAtOffset handle offset piece
+ verifyPiece n = do
+ let offset = pieceNumToOffset pieceMap n
+ hash' = hash (pieceMap ! n)
+ len' = len (pieceMap ! n)
+ bs' <- readFileAtOffset handle offset len'
+ return $ verifyHash bs' hash'
+
+pieceMapFromFile :: Handle -> PieceMap -> IO PieceMap
+pieceMapFromFile handle pieceMap = do
+ traverseWithKey f pieceMap
+ where
+ f k v = do
+ let offset = pieceNumToOffset pieceMap k
+ isHashValid <- flip verifyHash (hash v) <$> readFileAtOffset handle offset (len v)
+ if isHashValid
+ then return $ v { dlstate = Have }
+ else return v
module FuncTorrent.Peer
(Peer(..),
PieceMap,
- handlePeerMsgs,
- bytesDownloaded,
- initPieceMap,
- pieceMapFromFile
+ handlePeerMsgs
) where
-import Prelude hiding (lookup, concat, replicate, splitAt, take, drop, filter)
+import Prelude hiding (lookup, concat, replicate, splitAt, take, drop)
-import System.IO (Handle, BufferMode(..), hSetBuffering, hClose)
-import Data.ByteString (ByteString, unpack, concat, hGet, hPut, take, drop, empty)
-import qualified Data.ByteString.Char8 as BC (length)
-import Network (connectTo, PortID(..))
+import Control.Concurrent.Chan (writeChan)
import Control.Monad.State
+import Data.ByteString (ByteString, unpack, concat, hGet, hPut, take, drop, empty)
import Data.Bits
import Data.Word (Word8)
-import Data.Map (Map, fromList, toList, (!), mapWithKey, traverseWithKey, adjust, filter)
-import Safe (headMay)
+import Data.Map ((!), adjust)
+import Network (connectTo, PortID(..))
+import System.IO (Handle, BufferMode(..), hSetBuffering, hClose)
-import FuncTorrent.Metainfo (Info(..), Metainfo(..))
-import FuncTorrent.Utils (splitN, splitNum, writeFileAtOffset, readFileAtOffset, verifyHash)
+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, Msg(..), Piece(..))
data PState = PState { handle :: Handle
, peer :: Peer
, heChoking :: Bool
, heInterested :: Bool}
-data PieceDlState = Pending
- | Downloading
- | Have
- deriving (Show, Eq)
-
--- todo - map with index to a new data structure (peers who have that piece and state)
-data PieceData = PieceData { peers :: [Peer] -- ^ list of peers who have this piece
- , dlstate :: PieceDlState -- ^ state of the piece from download perspective.
- , hash :: ByteString -- ^ piece hash
- , len :: Integer } -- ^ piece length
-
--- which piece is with which peers
-type PieceMap = Map Integer PieceData
-
-
--- Make the initial Piece map, with the assumption that no peer has the
--- piece and that every piece is pending download.
-initPieceMap :: ByteString -> Integer -> Integer -> PieceMap
-initPieceMap pieceHash fileLen pieceLen = fromList kvs
- where
- numPieces = (toInteger . (`quot` 20) . BC.length) pieceHash
- kvs = [(i, PieceData { peers = []
- , dlstate = Pending
- , hash = h
- , len = pLen })
- | (i, h, pLen) <- zip3 [0..numPieces] hashes pLengths]
- hashes = splitN 20 pieceHash
- pLengths = splitNum fileLen pieceLen
-
-pieceMapFromFile :: FilePath -> PieceMap -> IO PieceMap
-pieceMapFromFile filePath pieceMap =
- traverseWithKey f pieceMap
- where
- f k v = do
- let offset = if k == 0 then 0 else k * len (pieceMap ! (k - 1))
- isHashValid <- flip verifyHash (hash v) <$> readFileAtOffset filePath offset (len v)
- if isHashValid
- then return $ v { dlstate = Have }
- else return v
-
havePiece :: PieceMap -> Integer -> Bool
havePiece pm index =
dlstate (pm ! index) == Have
, meChoking = meCh
, meInterested = meIn }
--- simple algorithm to pick piece.
--- pick the first piece from 0 that is not downloaded yet.
-pickPiece :: PieceMap -> Maybe Integer
-pickPiece =
- (fst `liftM`) . headMay . toList . filter (\v -> dlstate v == Pending)
-
-bytesDownloaded :: PieceMap -> Integer
-bytesDownloaded =
- sum . map (len . snd) . toList . filter (\v -> dlstate v == Have)
-
-updatePieceAvailability :: PieceMap -> Peer -> [Integer] -> PieceMap
-updatePieceAvailability pieceStatus p pieceList =
- mapWithKey (\k pd -> if k `elem` pieceList
- then (pd { peers = p : peers pd })
- else pd) pieceStatus
-
-handlePeerMsgs :: Peer -> String -> Metainfo -> PieceMap -> Bool -> IO ()
-handlePeerMsgs p peerId m pieceMap isClient = do
+handlePeerMsgs :: Peer -> String -> Metainfo -> PieceMap -> Bool -> FS.MsgChannel -> IO ()
+handlePeerMsgs p peerId m pieceMap isClient c = do
h <- connectToPeer p
doHandshake isClient h p (infoHash m) peerId
let pstate = toPeerState h p False False True True
- filePath = name (info m)
- _ <- runStateT (msgLoop pieceMap filePath) pstate
+ _ <- runStateT (msgLoop pieceMap c) pstate
return ()
-msgLoop :: PieceMap -> FilePath -> StateT PState IO ()
-msgLoop pieceStatus file = do
+msgLoop :: PieceMap -> FS.MsgChannel -> StateT PState IO ()
+msgLoop pieceStatus msgchannel = do
h <- gets handle
st <- get
case st of
liftIO $ sendMsg h InterestedMsg
gets peer >>= (\p -> liftIO $ putStrLn $ "--> InterestedMsg to peer: " ++ show p)
modify (\st' -> st' { meInterested = True })
- msgLoop pieceStatus file
+ msgLoop pieceStatus msgchannel
PState { meInterested = True, heChoking = False } ->
case pickPiece pieceStatus of
Nothing -> liftIO $ putStrLn "Nothing to download"
then
liftIO $ putStrLn "Hash mismatch"
else do
- let fileOffset = if workPiece == 0 then 0 else workPiece * len (pieceStatus ! (workPiece - 1))
- liftIO $ putStrLn $ "Write into file at offset: " ++ show fileOffset
- liftIO $ writeFileAtOffset file fileOffset pBS
- msgLoop (adjust (\pieceData -> pieceData { dlstate = Have }) workPiece pieceStatus) file
+ liftIO $ putStrLn $ "Write piece: " ++ show workPiece
+ liftIO $ writeChan msgchannel $ FS.WritePiece (FS.Piece workPiece pBS)
+ msgLoop (adjust (\pieceData -> pieceData { dlstate = Have }) workPiece pieceStatus) msgchannel
_ -> do
msg <- liftIO $ getMsg h
gets peer >>= (\p -> liftIO $ putStrLn $ "<-- " ++ show msg ++ "from peer: " ++ show p)
KeepAliveMsg -> do
liftIO $ sendMsg h KeepAliveMsg
gets peer >>= (\p -> liftIO $ putStrLn $ "--> " ++ "KeepAliveMsg to peer: " ++ show p)
- msgLoop pieceStatus file
+ msgLoop pieceStatus msgchannel
BitFieldMsg bss -> do
p <- gets peer
let pieceList = bitfieldToList (unpack bss)
-- for each pieceIndex in pieceList, make an entry in the pieceStatus
-- map with pieceIndex as the key and modify the value to add the peer.
-- download each of the piece in order
- msgLoop pieceStatus' file
+ msgLoop pieceStatus' msgchannel
UnChokeMsg -> do
modify (\st' -> st' {heChoking = False })
- msgLoop pieceStatus file
+ msgLoop pieceStatus msgchannel
ChokeMsg -> do
modify (\st' -> st' {heChoking = True })
- msgLoop pieceStatus file
+ msgLoop pieceStatus msgchannel
InterestedMsg -> do
modify (\st' -> st' {heInterested = True})
- msgLoop pieceStatus file
+ msgLoop pieceStatus msgchannel
NotInterestedMsg -> do
modify (\st' -> st' {heInterested = False})
- msgLoop pieceStatus file
+ msgLoop pieceStatus msgchannel
CancelMsg _ _ _ -> -- check if valid index, begin, length
- msgLoop pieceStatus file
+ msgLoop pieceStatus msgchannel
PortMsg _ ->
- msgLoop pieceStatus file
+ msgLoop pieceStatus msgchannel
-- handle RequestMsg, HaveMsg. No need to handle PieceMsg here.
-- also BitFieldMsg
++ show begin
return block
_ -> do
- putStrLn "ignoring irrelevant msg"
+ putStrLn $ "ignoring irrelevant msg: " ++ show msg
return empty)
--- /dev/null
+module FuncTorrent.PieceManager
+ (PieceDlState(..),
+ PieceData(..),
+ PieceMap,
+ pieceNumToOffset,
+ updatePieceAvailability,
+ pickPiece,
+ bytesDownloaded,
+ initPieceMap,
+ ) where
+
+import Prelude hiding (filter)
+
+import qualified Data.ByteString.Char8 as BC (length)
+import Control.Monad (liftM)
+import Data.ByteString (ByteString)
+import Data.Map (Map, (!), fromList, toList, mapWithKey, filter)
+import Safe (headMay)
+
+import FuncTorrent.PeerMsgs (Peer)
+import FuncTorrent.Utils (splitN, splitNum)
+
+data PieceDlState = Pending
+ | Downloading
+ | Have
+ deriving (Show, Eq)
+
+-- todo - map with index to a new data structure (peers who have that piece and state)
+data PieceData = PieceData { peers :: [Peer] -- ^ list of peers who have this piece
+ , dlstate :: PieceDlState -- ^ state of the piece from download perspective.
+ , hash :: ByteString -- ^ piece hash
+ , len :: Integer } -- ^ piece length
+
+-- which piece is with which peers
+type PieceMap = Map Integer PieceData
+
+pieceNumToOffset :: PieceMap -> Integer -> Integer
+pieceNumToOffset _ 0 = 0
+pieceNumToOffset pieceMap k = k * len (pieceMap ! (k - 1))
+
+-- simple algorithm to pick piece.
+-- pick the first piece from 0 that is not downloaded yet.
+pickPiece :: PieceMap -> Maybe Integer
+pickPiece =
+ (fst `liftM`) . headMay . toList . filter (\v -> dlstate v == Pending)
+
+bytesDownloaded :: PieceMap -> Integer
+bytesDownloaded =
+ sum . map (len . snd) . toList . filter (\v -> dlstate v == Have)
+
+updatePieceAvailability :: PieceMap -> Peer -> [Integer] -> PieceMap
+updatePieceAvailability pieceStatus p pieceList =
+ mapWithKey (\k pd -> if k `elem` pieceList
+ then (pd { peers = p : peers pd })
+ else pd) pieceStatus
+
+-- Make the initial Piece map, with the assumption that no peer has the
+-- piece and that every piece is pending download.
+initPieceMap :: ByteString -> Integer -> Integer -> PieceMap
+initPieceMap pieceHash fileLen pieceLen = fromList kvs
+ where
+ numPieces = (toInteger . (`quot` 20) . BC.length) pieceHash
+ kvs = [(i, PieceData { peers = []
+ , dlstate = Pending
+ , hash = h
+ , len = pLen })
+ | (i, h, pLen) <- zip3 [0..numPieces] hashes pLengths]
+ hashes = splitN 20 pieceHash
+ pLengths = splitNum fileLen pieceLen
import FuncTorrent.Metainfo (Metainfo)
import FuncTorrent.Peer (handlePeerMsgs, Peer(..), PieceMap)
+import qualified FuncTorrent.FileSystem as FS (MsgChannel)
-- server is listening on any port from 6881 - 6889
-- return the port number used
sock <- listenOn $ PortNumber $ fromIntegral (head portnums)
return (sock, PortNumber $ head portnums)
-run :: Socket -> String -> Metainfo -> PieceMap -> IO ()
-run listenSock peerid m pieceMap = forever $ do
+run :: Socket -> String -> Metainfo -> PieceMap -> FS.MsgChannel -> IO ()
+run listenSock peerid m pieceMap c = forever $ do
(handle, ip, port) <- accept listenSock
let peer = Peer "" ip (fromIntegral port)
hSetBuffering handle NoBuffering
- forkIO $ handlePeerMsgs peer peerid m pieceMap False
+ forkIO $ handlePeerMsgs peer peerid m pieceMap False c
(TState(..),
initialTrackerState,
trackerLoop,
+ udpTrackerLoop
) where
import Prelude hiding (lookup, splitAt)
-import System.IO (Handle)
+
import Control.Applicative (liftA2)
import Control.Concurrent (threadDelay)
import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, readMVar, putMVar)
+import Control.Exception (try)
import Data.Binary (Binary(..), encode, decode)
import Data.Binary.Put (putWord16be, putWord32be, putWord64be, putByteString)
import Data.Binary.Get (Get, isEmpty, getByteString, getWord16be, getWord32be)
import Data.Char (chr)
import Data.List (intercalate, isPrefixOf)
import Data.Map as M (lookup)
-import Network (PortNumber)
+import Network (connectTo, PortID(..), PortNumber, Socket)
+import Network.Socket (defaultProtocol, SocketType( Datagram ), Family( AF_INET ), SockAddr( SockAddrInet ), inet_addr, socket)
+import Network.Socket.ByteString (sendTo, recv)
import Network.HTTP.Base (urlEncode)
import qualified Data.ByteString.Base16 as B16 (encode)
import FuncTorrent.Peer (Peer(..))
import FuncTorrent.Utils (splitN)
-
data TrackerProtocol = Http
| Udp
| UnknownProtocol
trackerLoop port peerId m st
-- udp tracker
-getResponse :: Handle -> IO UDPResponse
-getResponse h = do
+getResponse :: Socket -> IO UDPResponse
+getResponse s = do
-- connect packet is 16 bytes long
-- announce packet is atleast 20 bytes long
- bs <- hGet h (16*1024)
+ bs <- recv s (16*1024)
return $ decode $ fromStrict bs
-sendRequest :: Handle -> UDPRequest -> IO ()
-sendRequest h req = hPut h bsReq
- where bsReq = toStrict $ encode req
+sendRequest :: Socket -> String -> PortNumber -> UDPRequest -> IO ()
+sendRequest s ip port req = do
+ hostaddr <- inet_addr ip
+ _ <- sendTo s bsReq $ SockAddrInet (fromIntegral port) hostaddr
+ return ()
+ where bsReq = toStrict $ encode req
getTrackerType :: String -> TrackerProtocol
getTrackerType url | isPrefixOf "http://" url = Http
| isPrefixOf "udp://" url = Udp
| otherwise = UnknownProtocol
+
+udpTrackerLoop :: PortNumber -> String -> Metainfo -> TState -> IO String
+udpTrackerLoop port peerId m st = do
+ -- h <- connectTo "exodus.desync.com" (PortNumber 6969)
+ s <- socket AF_INET Datagram defaultProtocol
+ hostAddr <- inet_addr "185.37.101.229"
+ putStrLn "connected to tracker"
+ _ <- sendTo s (toStrict $ encode (ConnectReq 42)) (SockAddrInet 2710 hostAddr)
+ putStrLn "--> sent ConnectReq to tracker"
+ resp <- recv s 16
+ putStrLn "<-- recv ConnectResp from tracker"
+ return $ show resp
import Control.Exception.Base (IOException, try)
import Data.ByteString (ByteString, writeFile, hPut, hGet, take)
import qualified Data.ByteString.Char8 as BC
-import System.IO (withFile, hSeek, IOMode(..), SeekMode(..))
+import System.IO (Handle, hSeek, SeekMode(..))
import System.Directory (doesFileExist)
splitN :: Int -> BC.ByteString -> [BC.ByteString]
return $ Right ()
-- write into a file at a specific offet
-writeFileAtOffset :: FilePath -> Integer -> ByteString -> IO ()
-writeFileAtOffset path offset block =
- withFile path ReadWriteMode (\h -> do
- hSeek h AbsoluteSeek offset
- hPut h block)
-readFileAtOffset :: FilePath -> Integer -> Integer -> IO ByteString
-readFileAtOffset path offset len =
- withFile path ReadWriteMode (\h -> do
- hSeek h AbsoluteSeek offset
- hGet h (fromInteger len))
+writeFileAtOffset :: Handle -> Integer -> ByteString -> IO ()
+writeFileAtOffset h offset block = do
+ hSeek h AbsoluteSeek offset
+ hPut h block
+
+readFileAtOffset :: Handle -> Integer -> Integer -> IO ByteString
+readFileAtOffset h offset len = do
+ hSeek h AbsoluteSeek offset
+ hGet h (fromInteger len)
verifyHash :: ByteString -> ByteString -> Bool
verifyHash bs pieceHash =
{-# LANGUAGE OverloadedStrings #-}
module Main where
-import Prelude hiding (log, length, readFile, getContents, replicate, writeFile)
+import Prelude hiding (log, length, readFile, getContents)
-import Control.Concurrent (forkIO)
-import Control.Concurrent.MVar (readMVar)
-import Data.ByteString.Char8 (ByteString, getContents, readFile, writeFile, replicate)
-import Network (PortID (PortNumber))
-import System.Environment (getArgs)
-import System.Exit (exitSuccess)
-import System.Directory (doesFileExist)
-import System.Random (getStdGen, randomRs)
-
-import FuncTorrent.Logger (initLogger, logMessage, logStop)
-import FuncTorrent.Metainfo (Info(..), Metainfo(..), torrentToMetainfo)
-import FuncTorrent.Peer (initPieceMap, handlePeerMsgs, pieceMapFromFile)
+import Control.Concurrent (forkIO)
+import Control.Concurrent.MVar (readMVar)
+import Data.ByteString.Char8 (ByteString, getContents, readFile)
+import qualified FuncTorrent.FileSystem as FS (initFS, pieceMapFromFile, startThread)
+import FuncTorrent.Logger (initLogger, logMessage, logStop)
+import FuncTorrent.Metainfo (Info(..), Metainfo(..), torrentToMetainfo)
+import FuncTorrent.Peer (handlePeerMsgs)
+import FuncTorrent.PieceManager (initPieceMap)
import qualified FuncTorrent.Server as Server
-import FuncTorrent.Tracker (connectedPeers, initialTrackerState, trackerLoop)
+import FuncTorrent.Tracker (connectedPeers, initialTrackerState, trackerLoop, udpTrackerLoop)
+import FuncTorrent.Utils (createDummyFile)
+import Network (PortID (PortNumber))
+import System.Directory (doesFileExist)
+import System.Environment (getArgs)
+import System.Exit (exitSuccess)
+import System.Random (getStdGen, randomRs)
logError :: String -> (String -> IO ()) -> IO ()
logError e logMsg = logMsg $ "parse error: \n" ++ e
pieceHash = pieces (info m)
pLen = pieceLength (info m)
defaultPieceMap = initPieceMap pieceHash fileLen pLen
+ log $ "create FS msg channel"
+ (handle, fsMsgChannel) <- FS.initFS filePath
log $ "Downloading file : " ++ filePath
dfe <- doesFileExist filePath
pieceMap <- if dfe
then
- pieceMapFromFile filePath defaultPieceMap
+ FS.pieceMapFromFile handle defaultPieceMap
else do
-- create a dummy file
- _ <- writeFile filePath (replicate (fromIntegral fileLen) '\0')
- return defaultPieceMap
+ createDummyFile filePath (fromIntegral fileLen) >>
+ return defaultPieceMap
+ log $ "start filesystem manager thread"
+ FS.startThread handle fsMsgChannel pieceMap
log $ "starting server"
(serverSock, (PortNumber portnum)) <- Server.start
log $ "server started on " ++ show portnum
log "Trying to fetch peers"
- _ <- forkIO $ Server.run serverSock peerId m pieceMap
+ _ <- forkIO $ Server.run serverSock peerId m pieceMap fsMsgChannel
log $ "Trackers: " ++ head (announceList m)
-- (tstate, errstr) <- runTracker portnum peerId m
tstate <- initialTrackerState $ lengthInBytes $ info m
ps <- readMVar (connectedPeers tstate)
log $ "Peers List : " ++ (show ps)
let p1 = head ps
- handlePeerMsgs p1 peerId m pieceMap True
+ handlePeerMsgs p1 peerId m pieceMap True fsMsgChannel
logStop logR
projects / functorrent.git / commitdiff