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
--- 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
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
+++ /dev/null
-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]
--- /dev/null
+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
--- /dev/null
+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]
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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]
--- /dev/null
+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)
--- /dev/null
+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)
+++ /dev/null
-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
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
+++ /dev/null
-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
+++ /dev/null
-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]
+++ /dev/null
-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)
+++ /dev/null
-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)
projects / functorrent.git / commitdiff