From: Jaseem Abid Date: Sat, 21 Mar 2015 14:02:57 +0000 (+0530) Subject: Make functorrent a library and an executable X-Git-Url: https://git.rkrishnan.org/vdrive/%22file:/frontends/simplejson/module-simplejson.scanner.html?a=commitdiff_plain;h=9e665dc72cd3230502340154173f22096895bd5f;p=functorrent.git Make functorrent a library and an executable This is a prerequisite for testing, as well as code organization. 1. `$ cabal repl` will build and import Functorrent library. 2. Making module exports explicit --- diff --git a/functorrent.cabal b/functorrent.cabal index 915fe71..e72f301 100644 --- a/functorrent.cabal +++ b/functorrent.cabal @@ -1,5 +1,5 @@ --- Initial functorrent.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ +-- Initial functorrent.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ name: functorrent version: 0.1.0.0 @@ -9,28 +9,49 @@ license: GPL-3 license-file: LICENSE author: Ramakrishnan Muthukrishnan maintainer: ram@rkrishnan.org --- copyright: +-- copyright: category: Network build-type: Simple --- extra-source-files: -cabal-version: >=1.10 +extra-source-files: README +cabal-version: >=1.18 -executable functorrent - main-is: Main.hs - -- other-modules: - -- other-extensions: +library + exposed-modules: FuncTorrent + FuncTorrent.Bencode, + FuncTorrent.Logger, + FuncTorrent.Metainfo, + FuncTorrent.Peer, + FuncTorrent.Tracker + other-extensions: OverloadedStrings + hs-source-dirs: src + ghc-options: -Wall -fwarn-incomplete-patterns + default-language: Haskell2010 build-depends: base, HTTP, base16-bytestring, binary, - bytestring, + bytestring, containers, cryptohash, doctest, - network-uri, + network-uri, parsec, time +executable functorrent + main-is: Main.hs + other-extensions: OverloadedStrings hs-source-dirs: src ghc-options: -Wall -fwarn-incomplete-patterns default-language: Haskell2010 + build-depends: base, + HTTP, + base16-bytestring, + binary, + bytestring, + containers, + cryptohash, + doctest, + network-uri, + parsec, + time diff --git a/src/Bencode.hs b/src/Bencode.hs deleted file mode 100644 index 246fffc..0000000 --- a/src/Bencode.hs +++ /dev/null @@ -1,131 +0,0 @@ -module Bencode where - -import Control.Applicative ((<*)) -import Data.ByteString.Char8 (ByteString, pack, unpack) -import Data.Functor ((<$>)) -import Data.Map.Strict (Map, fromList, keys, (!)) -import Text.ParserCombinators.Parsec -import qualified Text.Parsec.ByteString as ParsecBS - -data BVal = Bint Integer - | Bstr ByteString - | Blist [BVal] - | Bdict InfoDict - deriving (Ord, Eq, Show) - -type InfoDict = Map BVal BVal - --- $setup --- >>> import Data.Either - --- | parse strings --- --- >>> parse bencStr "Bstr" (pack "4:spam") --- Right "spam" --- >>> parse bencStr "Bstr" (pack "0:") --- Right "" --- >>> parse bencStr "Bstr" (pack "0:hello") --- Right "" --- -bencStr :: ParsecBS.Parser ByteString -bencStr = do _ <- spaces - ds <- many1 digit <* char ':' - s <- count (read ds) anyChar - return (pack s) - --- | parse integers --- --- >>> parse bencInt "Bint" (pack "i42e") --- Right 42 --- >>> parse bencInt "Bint" (pack "i123e") --- Right 123 --- >>> parse bencInt "Bint" (pack "i1e") --- Right 1 --- >>> parse bencInt "Bint" (pack "i0e") --- Right 0 --- >>> parse bencInt "Bint" (pack "i-1e") --- Right (-1) --- >>> isLeft $ parse bencInt "Bint" (pack "i01e") --- True --- >>> isLeft $ parse bencInt "Bint" (pack "i00e") --- True --- >>> isLeft $ parse bencInt "Bint" (pack "i002e") --- True -bencInt :: ParsecBS.Parser Integer -bencInt = do _ <- spaces - ds <- between (char 'i') (char 'e') numbers - return (read ds) - where numbers = do d' <- char '-' <|> digit - ds' <- many digit - parseNumber d' ds' - parseNumber '0' [] = return "0" - parseNumber '0' _ = unexpected "numbers cannot be left-padded with zeros" - parseNumber '-' [] = unexpected "sign without any digits" - parseNumber '-' (d'':_) | d'' == '0' = unexpected "numbers cannot be left-padded with zeros" - parseNumber d'' ds'' = return (d'':ds'') - --- | parse lists --- --- >>> parse bencList "Blist" (pack "le") --- Right [] --- >>> parse bencList "Blist" (pack "l4:spam4:eggse") --- Right ["spam","eggs"] --- >>> parse bencList "Blist" (pack "l4:spami42ee") --- Right ["spam",42] --- >>> parse bencList "Blist" (pack "l4:spam4:eggsli42eee") --- Right ["spam","eggs",[42]] -bencList :: ParsecBS.Parser [BVal] -bencList = do _ <- spaces - between (char 'l') (char 'e') (many bencVal) - --- | parse dict --- --- >>> parse bencDict "Bdict" (pack "de") --- Right (fromList []) --- >>> parse bencDict "Bdict" (pack "d3:cow3:moo4:spam4:eggse") --- Right (fromList [("cow","moo"),("spam","eggs")]) --- >>> parse bencDict "Bdict" (pack "d4:spaml1:a1:bee") --- Right (fromList [("spam",["a","b"])]) --- >>> parse bencDict "Bdict" (pack "d9:publisher3:bob17:publisher-webpage15:www.example.com18:publisher.location4:homee") --- Right (fromList [("publisher","bob"),("publisher-webpage","www.example.com"),("publisher.location","home")]) -bencDict :: ParsecBS.Parser (Map BVal BVal) -bencDict = between (char 'd') (char 'e') $ fromList <$> many kvpair - where kvpair = do k <- bencStr - v <- bencVal - return (Bstr k, v) - -bencVal :: ParsecBS.Parser BVal -bencVal = Bstr <$> bencStr <|> - Bint <$> bencInt <|> - Blist <$> bencList <|> - Bdict <$> bencDict - -decode :: ByteString -> Either ParseError BVal -decode = parse bencVal "BVal" - --- given an input dict or int or string, encode --- it into a bencoded bytestring. --- | encode bencoded-values --- --- >>> encode (Bstr (pack "")) --- "0:" --- >>> encode (Bstr (pack "spam")) --- "4:spam" --- >>> encode (Bint 0) --- "i0e" --- >>> encode (Bint 42) --- "i42e" --- >>> encode (Blist [(Bstr (pack "spam")), (Bstr (pack "eggs"))]) --- "l4:spam4:eggse" --- >>> encode (Blist []) --- "le" --- >>> encode (Bdict (fromList [(Bstr $ pack "spam", Bstr $ pack "eggs")])) --- "d4:spam4:eggse" -encode :: BVal -> String -encode (Bstr bs) = let s = unpack bs - in show (length s) ++ ":" ++ s -encode (Bint i) = "i" ++ show i ++ "e" -encode (Blist xs) = "l" ++ encodeList xs ++ "e" - where encodeList = foldr ((++) . encode) "" -encode (Bdict d) = "d" ++ encodeDict d ++ "e" - where encodeDict m = concat [encode k ++ encode (m ! k) | k <- keys m] diff --git a/src/FuncTorrent.hs b/src/FuncTorrent.hs new file mode 100644 index 0000000..acd679e --- /dev/null +++ b/src/FuncTorrent.hs @@ -0,0 +1,32 @@ +module FuncTorrent + (BVal(..), + Info, + InfoDict, + Metainfo, + Peer, + PeerResp(..), + announce, + connect, + decode, + encode, + getPeerResponse, + getPeers, + handShakeMsg, + info, + infoHash, + initLogger, + lengthInBytes, + logMessage, + logStop, + mkInfo, + mkMetaInfo, + name, + prepareRequest, + urlEncodeHash + ) where + +import FuncTorrent.Bencode +import FuncTorrent.Logger +import FuncTorrent.Metainfo +import FuncTorrent.Peer +import FuncTorrent.Tracker diff --git a/src/FuncTorrent/Bencode.hs b/src/FuncTorrent/Bencode.hs new file mode 100644 index 0000000..89446ea --- /dev/null +++ b/src/FuncTorrent/Bencode.hs @@ -0,0 +1,136 @@ +module FuncTorrent.Bencode + (BVal(..), + InfoDict, + encode, + decode + ) where + +import Control.Applicative ((<*)) +import Data.ByteString.Char8 (ByteString, pack, unpack) +import Data.Functor ((<$>)) +import Data.Map.Strict (Map, fromList, keys, (!)) +import Text.ParserCombinators.Parsec +import qualified Text.Parsec.ByteString as ParsecBS + +data BVal = Bint Integer + | Bstr ByteString + | Blist [BVal] + | Bdict InfoDict + deriving (Ord, Eq, Show) + +type InfoDict = Map BVal BVal + +-- $setup +-- >>> import Data.Either + +-- | parse strings +-- +-- >>> parse bencStr "Bstr" (pack "4:spam") +-- Right "spam" +-- >>> parse bencStr "Bstr" (pack "0:") +-- Right "" +-- >>> parse bencStr "Bstr" (pack "0:hello") +-- Right "" +-- +bencStr :: ParsecBS.Parser ByteString +bencStr = do _ <- spaces + ds <- many1 digit <* char ':' + s <- count (read ds) anyChar + return (pack s) + +-- | parse integers +-- +-- >>> parse bencInt "Bint" (pack "i42e") +-- Right 42 +-- >>> parse bencInt "Bint" (pack "i123e") +-- Right 123 +-- >>> parse bencInt "Bint" (pack "i1e") +-- Right 1 +-- >>> parse bencInt "Bint" (pack "i0e") +-- Right 0 +-- >>> parse bencInt "Bint" (pack "i-1e") +-- Right (-1) +-- >>> isLeft $ parse bencInt "Bint" (pack "i01e") +-- True +-- >>> isLeft $ parse bencInt "Bint" (pack "i00e") +-- True +-- >>> isLeft $ parse bencInt "Bint" (pack "i002e") +-- True +bencInt :: ParsecBS.Parser Integer +bencInt = do _ <- spaces + ds <- between (char 'i') (char 'e') numbers + return (read ds) + where numbers = do d' <- char '-' <|> digit + ds' <- many digit + parseNumber d' ds' + parseNumber '0' [] = return "0" + parseNumber '0' _ = unexpected "numbers cannot be left-padded with zeros" + parseNumber '-' [] = unexpected "sign without any digits" + parseNumber '-' (d'':_) | d'' == '0' = unexpected "numbers cannot be left-padded with zeros" + parseNumber d'' ds'' = return (d'':ds'') + +-- | parse lists +-- +-- >>> parse bencList "Blist" (pack "le") +-- Right [] +-- >>> parse bencList "Blist" (pack "l4:spam4:eggse") +-- Right ["spam","eggs"] +-- >>> parse bencList "Blist" (pack "l4:spami42ee") +-- Right ["spam",42] +-- >>> parse bencList "Blist" (pack "l4:spam4:eggsli42eee") +-- Right ["spam","eggs",[42]] +bencList :: ParsecBS.Parser [BVal] +bencList = do _ <- spaces + between (char 'l') (char 'e') (many bencVal) + +-- | parse dict +-- +-- >>> parse bencDict "Bdict" (pack "de") +-- Right (fromList []) +-- >>> parse bencDict "Bdict" (pack "d3:cow3:moo4:spam4:eggse") +-- Right (fromList [("cow","moo"),("spam","eggs")]) +-- >>> parse bencDict "Bdict" (pack "d4:spaml1:a1:bee") +-- Right (fromList [("spam",["a","b"])]) +-- >>> parse bencDict "Bdict" (pack "d9:publisher3:bob17:publisher-webpage15:www.example.com18:publisher.location4:homee") +-- Right (fromList [("publisher","bob"),("publisher-webpage","www.example.com"),("publisher.location","home")]) +bencDict :: ParsecBS.Parser (Map BVal BVal) +bencDict = between (char 'd') (char 'e') $ fromList <$> many kvpair + where kvpair = do k <- bencStr + v <- bencVal + return (Bstr k, v) + +bencVal :: ParsecBS.Parser BVal +bencVal = Bstr <$> bencStr <|> + Bint <$> bencInt <|> + Blist <$> bencList <|> + Bdict <$> bencDict + +decode :: ByteString -> Either ParseError BVal +decode = parse bencVal "BVal" + +-- given an input dict or int or string, encode +-- it into a bencoded bytestring. +-- | encode bencoded-values +-- +-- >>> encode (Bstr (pack "")) +-- "0:" +-- >>> encode (Bstr (pack "spam")) +-- "4:spam" +-- >>> encode (Bint 0) +-- "i0e" +-- >>> encode (Bint 42) +-- "i42e" +-- >>> encode (Blist [(Bstr (pack "spam")), (Bstr (pack "eggs"))]) +-- "l4:spam4:eggse" +-- >>> encode (Blist []) +-- "le" +-- >>> encode (Bdict (fromList [(Bstr $ pack "spam", Bstr $ pack "eggs")])) +-- "d4:spam4:eggse" +encode :: BVal -> String +encode (Bstr bs) = let s = unpack bs + in show (length s) ++ ":" ++ s +encode (Bint i) = "i" ++ show i ++ "e" +encode (Blist xs) = "l" ++ encodeList xs ++ "e" + where encodeList = foldr ((++) . encode) "" +encode (Bdict d) = "d" ++ encodeDict d ++ "e" + where encodeDict m = concat [encode k ++ encode (m ! k) | k <- keys m] diff --git a/src/FuncTorrent/Logger.hs b/src/FuncTorrent/Logger.hs new file mode 100644 index 0000000..255809b --- /dev/null +++ b/src/FuncTorrent/Logger.hs @@ -0,0 +1,54 @@ +module FuncTorrent.Logger ( + initLogger + , logMessage + , logStop + ) where + +import Control.Concurrent + +-- The below logger implementation has been taken from +-- Parallel and Concurrent Programming in Haskell, Chapter 7 +-- The logger is implemented in a concurrent thread. + +-- Here the (MVar LogCommand) is used for actual thread communication +-- So if multiple threads try to log, then the logger will be thread-safe +-- Also the 'loop' in logger will wait for the message to come. +-- +-- The MVar in stop is just to ensure the logger thread executes completely +-- Before exiting the main application. +-- +data Logger = Logger (MVar LogCommand) +data LogCommand = Message String | Stop (MVar ()) + +initLogger :: IO Logger +initLogger = do + m <- newEmptyMVar + let l = Logger m + _ <- forkIO (logger l) + return l + +logger :: Logger -> IO () +logger (Logger m) = loop + where + loop = do + cmd <- takeMVar m + case cmd of + Message msg -> do + -- We can alternatively put the message to a file + putStrLn msg + -- Recursive + loop + Stop s -> do + putStrLn "FuncTorrent: Exit succesfully" + putMVar s () + +-- Send log message to logger +logMessage :: Logger -> String -> IO () +logMessage (Logger m) s = putMVar m (Message s) + +logStop :: Logger -> IO () +logStop (Logger m) = do + s <- newEmptyMVar + putMVar m (Stop s) + -- Wait for logger to complete the logging + takeMVar s diff --git a/src/FuncTorrent/Metainfo.hs b/src/FuncTorrent/Metainfo.hs new file mode 100644 index 0000000..92b7b96 --- /dev/null +++ b/src/FuncTorrent/Metainfo.hs @@ -0,0 +1,74 @@ +module FuncTorrent.Metainfo + (Info, + Metainfo, + mkMetaInfo, + mkInfo, + announce, + lengthInBytes, + info, + name + ) where + +import Prelude hiding (lookup) +import Data.ByteString.Char8 (ByteString, pack, unpack) +import Data.Map as M ((!), lookup) + +import FuncTorrent.Bencode (BVal(..)) + +-- only single file mode supported for the time being. +data Info = Info { pieceLength :: !Integer + , pieces :: !ByteString + , private :: !(Maybe Integer) + , name :: !String + , lengthInBytes :: !Integer + , md5sum :: !(Maybe String) + } deriving (Eq, Show) + +data Metainfo = Metainfo { info :: !Info + , announce :: !String + , announceList :: !(Maybe [[String]]) + , creationDate :: !(Maybe String) + , comment :: !(Maybe String) + , createdBy :: !(Maybe String) + , encoding :: !(Maybe String) + } deriving (Eq, Show) + +mkInfo :: BVal -> Maybe Info +mkInfo (Bdict m) = let (Bint pieceLength') = m ! Bstr (pack "piece length") + (Bstr pieces') = m ! Bstr (pack "pieces") + private' = Nothing + (Bstr name') = m ! Bstr (pack "name") + (Bint length') = m ! Bstr (pack "length") + md5sum' = Nothing + in Just Info { pieceLength = pieceLength' + , pieces = pieces' + , private = private' + , name = unpack name' + , lengthInBytes = length' + , md5sum = md5sum'} +mkInfo _ = Nothing + +maybeBstrToString :: Maybe BVal -> Maybe String +maybeBstrToString Nothing = Nothing +maybeBstrToString (Just s) = let (Bstr bs) = s + in Just (unpack bs) + +mkMetaInfo :: BVal -> Maybe Metainfo +mkMetaInfo (Bdict m) = let (Just info') = mkInfo (m ! Bstr (pack "info")) + (Bstr announce') = m ! Bstr (pack "announce") + -- announceList = lookup (Bstr (pack "announce list")) + announceList' = Nothing + -- creationDate = lookup (Bstr (pack "creation date")) m + creationDate' = Nothing + comment' = lookup (Bstr (pack "comment")) m + createdBy' = lookup (Bstr (pack "created by")) m + encoding' = lookup (Bstr (pack "encoding")) m + in Just Metainfo { info = info' + , announce = unpack announce' + , announceList = announceList' + , creationDate = creationDate' + , comment = maybeBstrToString comment' + , createdBy = maybeBstrToString createdBy' + , encoding = maybeBstrToString encoding' + } +mkMetaInfo _ = Nothing diff --git a/src/FuncTorrent/Peer.hs b/src/FuncTorrent/Peer.hs new file mode 100644 index 0000000..b9334ba --- /dev/null +++ b/src/FuncTorrent/Peer.hs @@ -0,0 +1,72 @@ +module FuncTorrent.Peer + (Peer, + PeerResp(..), + getPeers, + getPeerResponse, + handShakeMsg + ) where + +import Prelude hiding (lookup, concat, replicate, splitAt) +import Data.ByteString.Char8 (ByteString, pack, unpack, concat, replicate, splitAt) +import Data.ByteString.Lazy (toChunks) +import Data.Int (Int8) +import Data.List (intercalate) +import Data.Map as M ((!), lookup) +import qualified Data.Binary as Bin (encode) +import qualified Data.ByteString.Base16 as B16 (encode) + +import FuncTorrent.Bencode (BVal(..), InfoDict, decode) +import FuncTorrent.Tracker (infoHash) +import FuncTorrent.Utils (splitN) + + +type Address = String +type Port = Integer + +data Peer = Peer Address Port + deriving (Show) + +data PeerResp = PeerResponse { interval :: Maybe Integer + , peers :: [Peer] + , complete :: Maybe Integer + , incomplete :: Maybe Integer + } deriving (Show) + +toInt :: String -> Integer +toInt = read + +getPeers :: PeerResp -> [Peer] +getPeers = peers + +getPeerResponse :: ByteString -> PeerResp +getPeerResponse body = case decode body of + Right (Bdict peerM) -> + let (Just (Bint i)) = lookup (Bstr (pack "lookup")) peerM + (Bstr peersBS) = peerM ! Bstr (pack "peers") + pl = map (\peer -> let (ip', port') = splitAt 4 peer + in Peer (toIPNum ip') (toPortNum port')) + (splitN 6 peersBS) + in PeerResponse { interval = Just i + , peers = pl + , complete = Nothing + , incomplete = Nothing + } + where toPortNum = read . ("0x" ++) . unpack . B16.encode + toIPNum = intercalate "." . + map (show . toInt . ("0x" ++) . unpack) . + splitN 2 . B16.encode + + _ -> PeerResponse { interval = Nothing + , peers = [] + , complete = Nothing + , incomplete = Nothing + } + + +handShakeMsg :: InfoDict -> String -> ByteString +handShakeMsg m peer_id = let pstrlen = concat $ toChunks $ Bin.encode (19 :: Int8) + pstr = pack "BitTorrent protocol" + reserved = replicate 8 '\0' + infoH = infoHash m + peerID = pack peer_id + in concat [pstrlen, pstr, reserved, infoH, peerID] diff --git a/src/FuncTorrent/Tracker.hs b/src/FuncTorrent/Tracker.hs new file mode 100644 index 0000000..178aa97 --- /dev/null +++ b/src/FuncTorrent/Tracker.hs @@ -0,0 +1,57 @@ +module FuncTorrent.Tracker + (connect, + infoHash, + prepareRequest, + urlEncodeHash + ) where + +import Prelude hiding (lookup) +import Crypto.Hash.SHA1 (hash) +import Data.ByteString.Char8 (ByteString, pack, unpack) +import Data.Char (chr) +import Data.List (intercalate) +import Data.Maybe (fromJust) +import Data.Map as M (Map, (!)) +import Network.HTTP (simpleHTTP, defaultGETRequest_, getResponseBody) +import Network.HTTP.Base (urlEncode) +import Network.URI (parseURI) +import qualified Data.ByteString.Base16 as B16 (encode) + +import FuncTorrent.Bencode (BVal(..), InfoDict, encode) +import FuncTorrent.Utils (splitN) + +type Url = String + +-- | urlEncodeHash +-- +-- >>> urlEncodeHash $ pack "123456789abcdef123456789abcdef123456789a" +-- "%124Vx%9a%bc%de%f1%23Eg%89%ab%cd%ef%124Vx%9a" +urlEncodeHash :: ByteString -> String +urlEncodeHash bs = concatMap (encode' . unpack) (splitN 2 bs) + where encode' b@[c1, c2] = let c = chr (read ("0x" ++ b)) + in escape c c1 c2 + encode' _ = "" + escape i c1 c2 | i `elem` nonSpecialChars = [i] + | otherwise = "%" ++ [c1] ++ [c2] + + nonSpecialChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_.~" + +infoHash :: Map BVal BVal -> ByteString +infoHash m = let info = m ! Bstr (pack "info") + in (hash . pack . encode) info + +prepareRequest :: InfoDict -> String -> Integer -> String +prepareRequest d peer_id len = + let p = [("info_hash", urlEncodeHash ((B16.encode . infoHash) d)), + ("peer_id", urlEncode peer_id), + ("port", "6881"), + ("uploaded", "0"), + ("downloaded", "0"), + ("left", show len), + ("compact", "1"), + ("event", "started")] + in intercalate "&" [f ++ "=" ++ s | (f,s) <- p] + +connect :: Url -> String -> IO ByteString +connect baseurl qstr = simpleHTTP (defaultGETRequest_ url) >>= getResponseBody + where url = fromJust . parseURI $ (baseurl ++ "?" ++ qstr) diff --git a/src/FuncTorrent/Utils.hs b/src/FuncTorrent/Utils.hs new file mode 100644 index 0000000..e5a4a55 --- /dev/null +++ b/src/FuncTorrent/Utils.hs @@ -0,0 +1,7 @@ +module FuncTorrent.Utils where + +import qualified Data.ByteString.Char8 as BC + +splitN :: Int -> BC.ByteString -> [BC.ByteString] +splitN n bs | BC.null bs = [] + | otherwise = BC.take n bs : splitN n (BC.drop n bs) diff --git a/src/Logger.hs b/src/Logger.hs deleted file mode 100644 index c1a5894..0000000 --- a/src/Logger.hs +++ /dev/null @@ -1,54 +0,0 @@ -module Logger ( - initLogger - , logMessage - , logStop - ) where - -import Control.Concurrent - --- The below logger implementation has been taken from --- Parallel and Concurrent Programming in Haskell, Chapter 7 --- The logger is implemented in a concurrent thread. - --- Here the (MVar LogCommand) is used for actual thread communication --- So if multiple threads try to log, then the logger will be thread-safe --- Also the 'loop' in logger will wait for the message to come. --- --- The MVar in stop is just to ensure the logger thread executes completely --- Before exiting the main application. --- -data Logger = Logger (MVar LogCommand) -data LogCommand = Message String | Stop (MVar ()) - -initLogger :: IO Logger -initLogger = do - m <- newEmptyMVar - let l = Logger m - _ <- forkIO (logger l) - return l - -logger :: Logger -> IO () -logger (Logger m) = loop - where - loop = do - cmd <- takeMVar m - case cmd of - Message msg -> do - -- We can alternatively put the message to a file - putStrLn msg - -- Recursive - loop - Stop s -> do - putStrLn "FuncTorrent: Exit succesfully" - putMVar s () - --- Send log message to logger -logMessage :: Logger -> String -> IO () -logMessage (Logger m) s = putMVar m (Message s) - -logStop :: Logger -> IO () -logStop (Logger m) = do - s <- newEmptyMVar - putMVar m (Stop s) - -- Wait for logger to complete the logging - takeMVar s diff --git a/src/Main.hs b/src/Main.hs index bc4b8d3..c23b97e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -7,11 +7,11 @@ import System.Environment (getArgs) import System.Exit (exitSuccess) import Text.ParserCombinators.Parsec (ParseError) -import Bencode (decode, BVal(..)) -import Logger (initLogger, logMessage, logStop) -import Metainfo (announce, lengthInBytes, mkMetaInfo, info, name) -import Peer (getPeers, getPeerResponse, handShakeMsg) -import Tracker (connect, prepareRequest) +import FuncTorrent.Bencode (decode, BVal(..)) +import FuncTorrent.Logger (initLogger, logMessage, logStop) +import FuncTorrent.Metainfo (announce, lengthInBytes, mkMetaInfo, info, name) +import FuncTorrent.Peer (getPeers, getPeerResponse, handShakeMsg) +import FuncTorrent.Tracker (connect, prepareRequest) logError :: ParseError -> (String -> IO ()) -> IO () logError e logMsg = logMsg $ "parse error: \n" ++ show e diff --git a/src/Metainfo.hs b/src/Metainfo.hs deleted file mode 100644 index c77b127..0000000 --- a/src/Metainfo.hs +++ /dev/null @@ -1,64 +0,0 @@ -module Metainfo where - -import Prelude hiding (lookup) -import Bencode (BVal(..)) -import Data.ByteString.Char8 (ByteString, pack, unpack) -import Data.Map as M ((!), lookup) - --- only single file mode supported for the time being. -data Info = Info { pieceLength :: !Integer - , pieces :: !ByteString - , private :: !(Maybe Integer) - , name :: !String - , lengthInBytes :: !Integer - , md5sum :: !(Maybe String) - } deriving (Eq, Show) - -data Metainfo = Metainfo { info :: !Info - , announce :: !String - , announceList :: !(Maybe [[String]]) - , creationDate :: !(Maybe String) - , comment :: !(Maybe String) - , createdBy :: !(Maybe String) - , encoding :: !(Maybe String) - } deriving (Eq, Show) - -mkInfo :: BVal -> Maybe Info -mkInfo (Bdict m) = let (Bint pieceLength') = m ! Bstr (pack "piece length") - (Bstr pieces') = m ! Bstr (pack "pieces") - private' = Nothing - (Bstr name') = m ! Bstr (pack "name") - (Bint length') = m ! Bstr (pack "length") - md5sum' = Nothing - in Just Info { pieceLength = pieceLength' - , pieces = pieces' - , private = private' - , name = unpack name' - , lengthInBytes = length' - , md5sum = md5sum'} -mkInfo _ = Nothing - -maybeBstrToString :: Maybe BVal -> Maybe String -maybeBstrToString Nothing = Nothing -maybeBstrToString (Just s) = let (Bstr bs) = s - in Just (unpack bs) - -mkMetaInfo :: BVal -> Maybe Metainfo -mkMetaInfo (Bdict m) = let (Just info') = mkInfo (m ! Bstr (pack "info")) - (Bstr announce') = m ! Bstr (pack "announce") - -- announceList = lookup (Bstr (pack "announce list")) - announceList' = Nothing - -- creationDate = lookup (Bstr (pack "creation date")) m - creationDate' = Nothing - comment' = lookup (Bstr (pack "comment")) m - createdBy' = lookup (Bstr (pack "created by")) m - encoding' = lookup (Bstr (pack "encoding")) m - in Just Metainfo { info = info' - , announce = unpack announce' - , announceList = announceList' - , creationDate = creationDate' - , comment = maybeBstrToString comment' - , createdBy = maybeBstrToString createdBy' - , encoding = maybeBstrToString encoding' - } -mkMetaInfo _ = Nothing diff --git a/src/Peer.hs b/src/Peer.hs deleted file mode 100644 index b07b79d..0000000 --- a/src/Peer.hs +++ /dev/null @@ -1,66 +0,0 @@ -module Peer where - -import Prelude hiding (lookup, concat, replicate, splitAt) - -import Bencode (BVal(..), InfoDict, decode) -import Data.ByteString.Char8 (ByteString, pack, unpack, concat, replicate, splitAt) -import Data.ByteString.Lazy (toChunks) -import Data.Int (Int8) -import Data.List (intercalate) -import Data.Map as M ((!), lookup) -import Tracker (infoHash) -import Utils (splitN) -import qualified Data.Binary as Bin (encode) -import qualified Data.ByteString.Base16 as B16 (encode) - - -type Address = String -type Port = Integer - -data Peer = Peer Address Port - deriving (Show) - -data PeerResp = PeerResponse { interval :: Maybe Integer - , peers :: [Peer] - , complete :: Maybe Integer - , incomplete :: Maybe Integer - } deriving (Show) - -toInt :: String -> Integer -toInt = read - -getPeers :: PeerResp -> [Peer] -getPeers = peers - -getPeerResponse :: ByteString -> PeerResp -getPeerResponse body = case decode body of - Right (Bdict peerM) -> - let (Just (Bint i)) = lookup (Bstr (pack "lookup")) peerM - (Bstr peersBS) = peerM ! Bstr (pack "peers") - pl = map (\peer -> let (ip', port') = splitAt 4 peer - in Peer (toIPNum ip') (toPortNum port')) - (splitN 6 peersBS) - in PeerResponse { interval = Just i - , peers = pl - , complete = Nothing - , incomplete = Nothing - } - where toPortNum = read . ("0x" ++) . unpack . B16.encode - toIPNum = intercalate "." . - map (show . toInt . ("0x" ++) . unpack) . - splitN 2 . B16.encode - - _ -> PeerResponse { interval = Nothing - , peers = [] - , complete = Nothing - , incomplete = Nothing - } - - -handShakeMsg :: InfoDict -> String -> ByteString -handShakeMsg m peer_id = let pstrlen = concat $ toChunks $ Bin.encode (19 :: Int8) - pstr = pack "BitTorrent protocol" - reserved = replicate 8 '\0' - infoH = infoHash m - peerID = pack peer_id - in concat [pstrlen, pstr, reserved, infoH, peerID] diff --git a/src/Tracker.hs b/src/Tracker.hs deleted file mode 100644 index 6c558e5..0000000 --- a/src/Tracker.hs +++ /dev/null @@ -1,52 +0,0 @@ -module Tracker where - -import Prelude hiding (lookup) - -import Bencode (BVal(..), InfoDict, encode) -import Crypto.Hash.SHA1 (hash) -import Data.ByteString.Char8 (ByteString, pack, unpack) -import Data.Char (chr) -import Data.List (intercalate) -import Data.Maybe (fromJust) -import Data.Map as M (Map, (!)) -import Network.HTTP (simpleHTTP, defaultGETRequest_, getResponseBody) -import Network.HTTP.Base (urlEncode) -import Network.URI (parseURI) -import Utils (splitN) -import qualified Data.ByteString.Base16 as B16 (encode) - -type Url = String - --- | urlEncodeHash --- --- >>> urlEncodeHash $ pack "123456789abcdef123456789abcdef123456789a" --- "%124Vx%9a%bc%de%f1%23Eg%89%ab%cd%ef%124Vx%9a" -urlEncodeHash :: ByteString -> String -urlEncodeHash bs = concatMap (encode' . unpack) (splitN 2 bs) - where encode' b@[c1, c2] = let c = chr (read ("0x" ++ b)) - in escape c c1 c2 - encode' _ = "" - escape i c1 c2 | i `elem` nonSpecialChars = [i] - | otherwise = "%" ++ [c1] ++ [c2] - - nonSpecialChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_.~" - -infoHash :: Map BVal BVal -> ByteString -infoHash m = let info = m ! Bstr (pack "info") - in (hash . pack . encode) info - -prepareRequest :: InfoDict -> String -> Integer -> String -prepareRequest d peer_id len = - let p = [("info_hash", urlEncodeHash ((B16.encode . infoHash) d)), - ("peer_id", urlEncode peer_id), - ("port", "6881"), - ("uploaded", "0"), - ("downloaded", "0"), - ("left", show len), - ("compact", "1"), - ("event", "started")] - in intercalate "&" [f ++ "=" ++ s | (f,s) <- p] - -connect :: Url -> String -> IO ByteString -connect baseurl qstr = simpleHTTP (defaultGETRequest_ url) >>= getResponseBody - where url = fromJust . parseURI $ (baseurl ++ "?" ++ qstr) diff --git a/src/Utils.hs b/src/Utils.hs deleted file mode 100644 index 019b06b..0000000 --- a/src/Utils.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Utils where - -import qualified Data.ByteString.Char8 as BC - -splitN :: Int -> BC.ByteString -> [BC.ByteString] -splitN n bs | BC.null bs = [] - | otherwise = BC.take n bs : splitN n (BC.drop n bs)