module Bencode where
--- import qualified Data.ByteString.Lazy as BL
-import qualified Data.ByteString.Char8 as BC
-import qualified Data.Map.Strict as M
-import qualified Text.Parsec.ByteString as ParsecBS
-import Text.ParserCombinators.Parsec
import Control.Applicative ((<*))
-import Data.Functor
+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 BC.ByteString
+ | Bstr ByteString
| Blist [BVal]
| Bdict InfoDict
deriving (Ord, Eq, Show)
-type InfoDict = M.Map BVal BVal
+type InfoDict = Map BVal BVal
-- $setup
-- >>> import Data.Either
-- | parse strings
--
--- >>> parse bencStr "Bstr" (BC.pack "4:spam")
+-- >>> parse bencStr "Bstr" (pack "4:spam")
-- Right "spam"
--- >>> parse bencStr "Bstr" (BC.pack "0:")
+-- >>> parse bencStr "Bstr" (pack "0:")
-- Right ""
--- >>> parse bencStr "Bstr" (BC.pack "0:hello")
+-- >>> parse bencStr "Bstr" (pack "0:hello")
-- Right ""
--
-bencStr :: ParsecBS.Parser BC.ByteString
+bencStr :: ParsecBS.Parser ByteString
bencStr = do _ <- spaces
ds <- many1 digit <* char ':'
s <- count (read ds) anyChar
- return (BC.pack s)
+ return (pack s)
-- | parse integers
--
--- >>> parse bencInt "Bint" (BC.pack "i42e")
+-- >>> parse bencInt "Bint" (pack "i42e")
-- Right 42
--- >>> parse bencInt "Bint" (BC.pack "i123e")
+-- >>> parse bencInt "Bint" (pack "i123e")
-- Right 123
--- >>> parse bencInt "Bint" (BC.pack "i1e")
+-- >>> parse bencInt "Bint" (pack "i1e")
-- Right 1
--- >>> parse bencInt "Bint" (BC.pack "i0e")
+-- >>> parse bencInt "Bint" (pack "i0e")
-- Right 0
--- >>> parse bencInt "Bint" (BC.pack "i-1e")
+-- >>> parse bencInt "Bint" (pack "i-1e")
-- Right (-1)
--- >>> isLeft $ parse bencInt "Bint" (BC.pack "i01e")
+-- >>> isLeft $ parse bencInt "Bint" (pack "i01e")
-- True
--- >>> isLeft $ parse bencInt "Bint" (BC.pack "i00e")
+-- >>> isLeft $ parse bencInt "Bint" (pack "i00e")
-- True
--- >>> isLeft $ parse bencInt "Bint" (BC.pack "i002e")
+-- >>> isLeft $ parse bencInt "Bint" (pack "i002e")
-- True
bencInt :: ParsecBS.Parser Integer
bencInt = do _ <- spaces
-- | parse lists
--
--- >>> parse bencList "Blist" (BC.pack "le")
+-- >>> parse bencList "Blist" (pack "le")
-- Right []
--- >>> parse bencList "Blist" (BC.pack "l4:spam4:eggse")
+-- >>> parse bencList "Blist" (pack "l4:spam4:eggse")
-- Right ["spam","eggs"]
--- >>> parse bencList "Blist" (BC.pack "l4:spami42ee")
+-- >>> parse bencList "Blist" (pack "l4:spami42ee")
-- Right ["spam",42]
--- >>> parse bencList "Blist" (BC.pack "l4:spam4:eggsli42eee")
+-- >>> parse bencList "Blist" (pack "l4:spam4:eggsli42eee")
-- Right ["spam","eggs",[42]]
bencList :: ParsecBS.Parser [BVal]
bencList = do _ <- spaces
-- | parse dict
--
--- >>> parse bencDict "Bdict" (BC.pack "de")
+-- >>> parse bencDict "Bdict" (pack "de")
-- Right (fromList [])
--- >>> parse bencDict "Bdict" (BC.pack "d3:cow3:moo4:spam4:eggse")
+-- >>> parse bencDict "Bdict" (pack "d3:cow3:moo4:spam4:eggse")
-- Right (fromList [("cow","moo"),("spam","eggs")])
--- >>> parse bencDict "Bdict" (BC.pack "d4:spaml1:a1:bee")
+-- >>> parse bencDict "Bdict" (pack "d4:spaml1:a1:bee")
-- Right (fromList [("spam",["a","b"])])
--- >>> parse bencDict "Bdict" (BC.pack "d9:publisher3:bob17:publisher-webpage15:www.example.com18:publisher.location4:homee")
+-- >>> 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 (M.Map BVal BVal)
-bencDict = between (char 'd') (char 'e') $ M.fromList <$> many kvpair
+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)
Blist <$> bencList <|>
Bdict <$> bencDict
-decode :: BC.ByteString -> Either ParseError BVal
+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 (BC.pack ""))
+-- >>> encode (Bstr (pack ""))
-- "0:"
--- >>> encode (Bstr (BC.pack "spam"))
+-- >>> encode (Bstr (pack "spam"))
-- "4:spam"
-- >>> encode (Bint 0)
-- "i0e"
-- >>> encode (Bint 42)
-- "i42e"
--- >>> encode (Blist [(Bstr (BC.pack "spam")), (Bstr (BC.pack "eggs"))])
+-- >>> encode (Blist [(Bstr (pack "spam")), (Bstr (pack "eggs"))])
-- "l4:spam4:eggse"
-- >>> encode (Blist [])
-- "le"
--- >>> encode (Bdict (M.fromList [(Bstr $ BC.pack "spam", Bstr $ BC.pack "eggs")]))
+-- >>> encode (Bdict (fromList [(Bstr $ pack "spam", Bstr $ pack "eggs")]))
-- "d4:spam4:eggse"
encode :: BVal -> String
-encode (Bstr bs) = let s = BC.unpack bs
+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 M.! k) | k <- M.keys m]
+ where encodeDict m = concat [encode k ++ encode ((!) m k) | k <- keys m]
module Main where
+import Prelude hiding (length, readFile)
+
+import Bencode (decode, BVal(..))
+import Data.ByteString.Char8 as BC (ByteString, pack, length, readFile, length)
+import Data.Functor ((<$>))
+import Metainfo (announce, lengthInBytes, mkMetaInfo, info)
+import Peer (getPeers, getPeerResponse, handShakeMsg)
import System.Environment (getArgs)
-import System.Exit
-import qualified Data.ByteString.Char8 as BC
-import qualified Bencode as Benc
-import qualified Metainfo as MInfo
-import qualified Tracker as T
-import qualified Text.ParserCombinators.Parsec as Parsec
-import qualified Peer as P
-import Data.Functor
-
-printError :: Parsec.ParseError -> IO ()
+import System.Exit (exitSuccess)
+import Tracker (connect, prepareRequest)
+import Text.ParserCombinators.Parsec (ParseError)
+
+printError :: ParseError -> IO ()
printError e = putStrLn $ "parse error: " ++ show e
peerId :: String
peerId = "-HS0001-*-*-20150215"
-exit :: IO BC.ByteString
+exit :: IO ByteString
exit = exitSuccess
usage :: IO ()
usage = putStrLn "usage: functorrent torrent-file"
-parse :: [String] -> IO BC.ByteString
+parse :: [String] -> IO ByteString
parse [] = usage >> exit
-parse [a] = BC.readFile a
+parse [a] = readFile a
parse _ = exit
main :: IO ()
main = do
args <- getArgs
torrentStr <- parse args
- case Benc.decode torrentStr of
+ case decode torrentStr of
Right d ->
- case MInfo.mkMetaInfo d of
+ case mkMetaInfo d of
Nothing -> putStrLn "parse error"
Just m -> do
- let len = MInfo.lengthInBytes (MInfo.info m)
- (Benc.Bdict d') = d
- body <- BC.pack <$> T.connect (MInfo.announce m) (T.prepareRequest d' peerId len)
- print (P.getPeers (P.getPeerResponse body))
- print (BC.length (P.handShakeMsg d' peerId))
+ let len = lengthInBytes $ info m
+ (Bdict d') = d
+ body <- pack <$> connect (announce m) (prepareRequest d' peerId len)
+ print $ getPeers $ getPeerResponse body
+ print $ length $ handShakeMsg d' peerId
Left e -> printError e
putStrLn "done"
module Metainfo where
-import qualified Bencode as Benc
-import qualified Data.ByteString.Char8 as BC
-import qualified Data.Map as M
+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 :: !BC.ByteString
+ , pieces :: !ByteString
, private :: !(Maybe Integer)
, name :: !String
, lengthInBytes :: !Integer
, encoding :: !(Maybe String)
} deriving (Eq, Show)
-mkInfo :: Benc.BVal -> Maybe Info
-mkInfo (Benc.Bdict m) = let (Benc.Bint pieceLength') = m M.! Benc.Bstr (BC.pack "piece length")
- (Benc.Bstr pieces') = m M.! Benc.Bstr (BC.pack "pieces")
- private' = Nothing
- (Benc.Bstr name') = m M.! Benc.Bstr (BC.pack "name")
- (Benc.Bint length') = m M.! Benc.Bstr (BC.pack "length")
- md5sum' = Nothing
- in Just Info { pieceLength = pieceLength'
- , pieces = pieces'
- , private = private'
- , name = BC.unpack name'
- , lengthInBytes = length'
- , md5sum = md5sum'
- }
+mkInfo :: BVal -> Maybe Info
+mkInfo (Bdict m) = let (Bint pieceLength') = m M.! Bstr (pack "piece length")
+ (Bstr pieces') = m M.! Bstr (pack "pieces")
+ private' = Nothing
+ (Bstr name') = m M.! Bstr (pack "name")
+ (Bint length') = m 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 Benc.BVal -> Maybe String
+maybeBstrToString :: Maybe BVal -> Maybe String
maybeBstrToString Nothing = Nothing
-maybeBstrToString (Just s) = let (Benc.Bstr bs) = s
- in Just (BC.unpack bs)
+maybeBstrToString (Just s) = let (Bstr bs) = s
+ in Just (unpack bs)
-mkMetaInfo :: Benc.BVal -> Maybe Metainfo
-mkMetaInfo (Benc.Bdict m) = let (Just info') = mkInfo (m M.! Benc.Bstr (BC.pack "info"))
- (Benc.Bstr announce') = m M.! Benc.Bstr (BC.pack "announce")
--- announceList = M.lookup (Benc.Bstr (BC.pack "announce list"))
- announceList' = Nothing
- -- creationDate = M.lookup (Benc.Bstr (BC.pack "creation date")) m
- creationDate' = Nothing
- comment' = M.lookup (Benc.Bstr (BC.pack "comment")) m
- createdBy' = M.lookup (Benc.Bstr (BC.pack "created by")) m
- encoding' = M.lookup (Benc.Bstr (BC.pack "encoding")) m
- in Just Metainfo { info = info'
- , announce = BC.unpack announce'
- , announceList = announceList'
- , creationDate = creationDate'
- , comment = maybeBstrToString comment'
- , createdBy = maybeBstrToString createdBy'
- , encoding = maybeBstrToString encoding'
- }
+mkMetaInfo :: BVal -> Maybe Metainfo
+mkMetaInfo (Bdict m) = let (Just info') = mkInfo (m M.! Bstr (pack "info"))
+ (Bstr announce') = m 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
module Peer where
-import qualified Utils as U
-import qualified Bencode as Benc
-import qualified Tracker as T
-import qualified Data.Map as M
-import qualified Data.ByteString.Char8 as BC
-import qualified Data.ByteString.Base16 as B16
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.List as L
-import qualified Data.Binary as Bin
-import qualified Data.Int as DI
-
-data Peer = Peer { ip :: String
- , port :: Integer
- } deriving (Show)
-
+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
getPeers :: PeerResp -> [Peer]
getPeers = peers
-getPeerResponse :: BC.ByteString -> PeerResp
-getPeerResponse body = case Benc.decode body of
- Right (Benc.Bdict peerM) ->
- let (Just (Benc.Bint i)) = M.lookup (Benc.Bstr (BC.pack "lookup")) peerM
- (Benc.Bstr peersBS) = peerM M.! Benc.Bstr (BC.pack "peers")
- pl = map (\peer -> let (ip', port') = BC.splitAt 4 peer
- in Peer { ip = toIPNum ip'
- , port = toPortNum port'
- })
- (U.splitN 6 peersBS)
+getPeerResponse :: ByteString -> PeerResp
+getPeerResponse body = case decode body of
+ Right (Bdict peerM) ->
+ let (Just (Bint i)) = lookup (Bstr (pack "lookup")) peerM
+ (Bstr peersBS) = peerM M.! 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" ++) . BC.unpack . B16.encode
- toIPNum = L.intercalate "." .
- map (show . toInt . ("0x" ++) . BC.unpack) .
- U.splitN 2 . B16.encode
+ where toPortNum = read . ("0x" ++) . unpack . B16.encode
+ toIPNum = intercalate "." .
+ map (show . toInt . ("0x" ++) . unpack) .
+ splitN 2 . B16.encode
+
_ -> PeerResponse { interval = Nothing
, peers = []
, complete = Nothing
}
-handShakeMsg :: Benc.InfoDict -> String -> BC.ByteString
-handShakeMsg m peer_id = let pstrlen = BC.concat $ BL.toChunks $ Bin.encode (19 :: DI.Int8)
- pstr = BC.pack "BitTorrent protocol"
- reserved = BC.replicate 8 '\0'
- infoH = T.infoHash m
- peerID = BC.pack peer_id
- in BC.concat [pstrlen, pstr, reserved, infoH, peerID]
+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]
module Tracker where
-import qualified Data.ByteString.Char8 as BC
-import qualified Data.Map as M
-import qualified Data.List as List
-import qualified Network.HTTP as HTTP
-import qualified Network.HTTP.Base as HB
-import qualified Bencode as Benc
-import qualified Crypto.Hash.SHA1 as SHA1
-import qualified Data.ByteString.Base16 as B16
-import qualified Utils as U
-import Data.Char
+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.Map as M (Map, (!))
+import Network.HTTP (simpleHTTP, getRequest, getResponseBody)
+import Network.HTTP.Base (urlEncode)
+import Utils (splitN)
+import qualified Data.ByteString.Base16 as B16 (encode)
type Url = String
--
-- >>> urlEncodeHash $ BC.pack "123456789abcdef123456789abcdef123456789a"
-- "%124vx%9a%bc%de%f1%23Eg%89%ab%cd%ef%124Vx%9a"
-urlEncodeHash :: BC.ByteString -> String
-urlEncodeHash bs = concatMap (encode . BC.unpack) (U.splitN 2 bs)
- where encode b@[c1, c2] = let c = chr (read ("0x" ++ b))
- in
- escape c c1 c2
- encode _ = ""
+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]
- where nonSpecialChars = ['A'..'Z'] ++
- ['a'..'z'] ++
- ['0'..'9'] ++
- "-_.~"
-infoHash :: M.Map Benc.BVal Benc.BVal -> BC.ByteString
-infoHash m = let info = m M.! Benc.Bstr (BC.pack "info")
- in (SHA1.hash . BC.pack . Benc.encode) info
+ nonSpecialChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_.~"
+
+infoHash :: Map BVal BVal -> ByteString
+infoHash m = let info = m M.! Bstr (pack "info")
+ in (hash . pack . encode) info
-prepareRequest :: Benc.InfoDict -> String -> Integer -> String
+prepareRequest :: InfoDict -> String -> Integer -> String
prepareRequest d peer_id len =
let p = [("info_hash", urlEncodeHash ((B16.encode . infoHash) d)),
- ("peer_id", HB.urlEncode peer_id),
+ ("peer_id", urlEncode peer_id),
("port", "6881"),
("uploaded", "0"),
("downloaded", "0"),
("left", show len),
("compact", "1"),
("event", "started")]
- in
- List.intercalate "&" [f ++ "=" ++ s | (f,s) <- p]
+ in intercalate "&" [f ++ "=" ++ s | (f,s) <- p]
connect :: Url -> String -> IO String
connect baseurl qstr = let url = baseurl ++ "?" ++ qstr
- in HTTP.simpleHTTP (HTTP.getRequest url) >>=
- HTTP.getResponseBody
+ in simpleHTTP (getRequest url) >>=
+ getResponseBody
projects / functorrent.git / commitdiff