From 11987749fc6e6d3e53ea737d46d5ab13a16faeb8 Mon Sep 17 00:00:00 2001 From: James Crayne Date: Sat, 28 Sep 2019 13:43:29 -0400 Subject: Factor out some new libraries word64-map: Data.Word64Map network-addr: Network.Address tox-crypto: Crypto.Tox lifted-concurrent: Control.Concurrent.Lifted.Instrument Control.Concurrent.Async.Lifted.Instrument psq-wrap: Data.Wrapper.PSQInt Data.Wrapper.PSQ minmax-psq: Data.MinMaxPSQ tasks: Control.Concurrent.Tasks kad: Network.Kademlia Network.Kademlia.Bootstrap Network.Kademlia.Routing Network.Kademlia.CommonAPI Network.Kademlia.Persistence Network.Kademlia.Search --- bittorrent/README.md | 78 -- bittorrent/Readme.md | 8 - bittorrent/bench/Main.hs | 75 -- bittorrent/bench/Throughtput.hs | 46 - bittorrent/bench/TorrentFile.hs | 27 - bittorrent/bittorrent.cabal | 412 ------- bittorrent/dev/README.md | 4 - bittorrent/dev/add-sources.sh | 5 - bittorrent/dev/bench | 4 - bittorrent/dev/test | 2 - bittorrent/dev/update-dependencies.sh | 11 - bittorrent/examples/Client.hs | 74 -- bittorrent/examples/FS.hs | 74 -- bittorrent/examples/MkTorrent.hs | 500 -------- bittorrent/res/dapper-dvd-amd64.iso.torrent | Bin 64198 -> 0 bytes bittorrent/res/pkg.torrent | Bin 32113 -> 0 bytes bittorrent/res/testfile | Bin 8192 -> 0 bytes bittorrent/res/testfile.torrent | 1 - bittorrent/src/Network/BitTorrent.hs | 61 - bittorrent/src/Network/BitTorrent/Client.hs | 195 --- bittorrent/src/Network/BitTorrent/Client/Handle.hs | 188 --- bittorrent/src/Network/BitTorrent/Client/Types.hs | 163 --- bittorrent/src/Network/BitTorrent/Exchange.hs | 35 - .../src/Network/BitTorrent/Exchange/Bitfield.hs | 405 ------- .../src/Network/BitTorrent/Exchange/Block.hs | 369 ------ .../src/Network/BitTorrent/Exchange/Connection.hs | 1012 ---------------- .../src/Network/BitTorrent/Exchange/Download.hs | 296 ----- .../src/Network/BitTorrent/Exchange/Manager.hs | 62 - .../src/Network/BitTorrent/Exchange/Message.hs | 1237 -------------------- .../src/Network/BitTorrent/Exchange/Session.hs | 586 ---------- .../src/Network/BitTorrent/Internal/Cache.hs | 169 --- .../src/Network/BitTorrent/Internal/Progress.hs | 154 --- .../src/Network/BitTorrent/Internal/Types.hs | 10 - bittorrent/src/Network/BitTorrent/Readme.md | 10 - bittorrent/src/Network/BitTorrent/Tracker.hs | 51 - bittorrent/src/Network/BitTorrent/Tracker/List.hs | 197 ---- .../src/Network/BitTorrent/Tracker/Message.hs | 925 --------------- bittorrent/src/Network/BitTorrent/Tracker/RPC.hs | 175 --- .../src/Network/BitTorrent/Tracker/RPC/HTTP.hs | 191 --- .../src/Network/BitTorrent/Tracker/RPC/UDP.hs | 454 ------- .../src/Network/BitTorrent/Tracker/Session.hs | 306 ----- bittorrent/src/System/Torrent/FileMap.hs | 163 --- bittorrent/src/System/Torrent/Storage.hs | 221 ---- bittorrent/src/System/Torrent/Tree.hs | 83 -- bittorrent/tests/Config.hs | 183 --- bittorrent/tests/Data/TorrentSpec.hs | 139 --- bittorrent/tests/Main.hs | 97 -- .../tests/Network/BitTorrent/Client/HandleSpec.hs | 19 - bittorrent/tests/Network/BitTorrent/CoreSpec.hs | 309 ----- .../tests/Network/BitTorrent/DHT/MessageSpec.hs | 221 ---- .../tests/Network/BitTorrent/DHT/QuerySpec.hs | 105 -- .../tests/Network/BitTorrent/DHT/RoutingSpec.hs | 77 -- .../tests/Network/BitTorrent/DHT/SessionSpec.hs | 110 -- .../tests/Network/BitTorrent/DHT/TestData.hs | 45 - .../tests/Network/BitTorrent/DHT/TokenSpec.hs | 42 - bittorrent/tests/Network/BitTorrent/DHTSpec.hs | 60 - .../Network/BitTorrent/Exchange/BitfieldSpec.hs | 14 - .../tests/Network/BitTorrent/Exchange/BlockSpec.hs | 35 - .../Network/BitTorrent/Exchange/ConnectionSpec.hs | 58 - .../Network/BitTorrent/Exchange/DownloadSpec.hs | 59 - .../Network/BitTorrent/Exchange/MessageSpec.hs | 102 -- .../Network/BitTorrent/Exchange/SessionSpec.hs | 64 - .../tests/Network/BitTorrent/Internal/CacheSpec.hs | 7 - .../Network/BitTorrent/Internal/ProgressSpec.hs | 13 - .../tests/Network/BitTorrent/Tracker/ListSpec.hs | 40 - .../Network/BitTorrent/Tracker/MessageSpec.hs | 173 --- .../Network/BitTorrent/Tracker/RPC/HTTPSpec.hs | 95 -- .../Network/BitTorrent/Tracker/RPC/UDPSpec.hs | 144 --- .../tests/Network/BitTorrent/Tracker/RPCSpec.hs | 79 -- .../Network/BitTorrent/Tracker/SessionSpec.hs | 61 - .../tests/Network/BitTorrent/Tracker/TestData.hs | 93 -- bittorrent/tests/Network/KRPC/MessageSpec.hs | 72 -- bittorrent/tests/Network/KRPC/MethodSpec.hs | 52 - bittorrent/tests/Network/KRPCSpec.hs | 59 - bittorrent/tests/Readme.md | 4 - bittorrent/tests/Spec.hs | 1 - bittorrent/tests/System/Torrent/FileMapSpec.hs | 116 -- bittorrent/tests/System/Torrent/StorageSpec.hs | 91 -- 78 files changed, 11878 deletions(-) delete mode 100644 bittorrent/README.md delete mode 100644 bittorrent/Readme.md delete mode 100644 bittorrent/bench/Main.hs delete mode 100644 bittorrent/bench/Throughtput.hs delete mode 100644 bittorrent/bench/TorrentFile.hs delete mode 100644 bittorrent/bittorrent.cabal delete mode 100644 bittorrent/dev/README.md delete mode 100755 bittorrent/dev/add-sources.sh delete mode 100755 bittorrent/dev/bench delete mode 100755 bittorrent/dev/test delete mode 100755 bittorrent/dev/update-dependencies.sh delete mode 100644 bittorrent/examples/Client.hs delete mode 100644 bittorrent/examples/FS.hs delete mode 100644 bittorrent/examples/MkTorrent.hs delete mode 100644 bittorrent/res/dapper-dvd-amd64.iso.torrent delete mode 100644 bittorrent/res/pkg.torrent delete mode 100644 bittorrent/res/testfile delete mode 100644 bittorrent/res/testfile.torrent delete mode 100644 bittorrent/src/Network/BitTorrent.hs delete mode 100644 bittorrent/src/Network/BitTorrent/Client.hs delete mode 100644 bittorrent/src/Network/BitTorrent/Client/Handle.hs delete mode 100644 bittorrent/src/Network/BitTorrent/Client/Types.hs delete mode 100644 bittorrent/src/Network/BitTorrent/Exchange.hs delete mode 100644 bittorrent/src/Network/BitTorrent/Exchange/Bitfield.hs delete mode 100644 bittorrent/src/Network/BitTorrent/Exchange/Block.hs delete mode 100644 bittorrent/src/Network/BitTorrent/Exchange/Connection.hs delete mode 100644 bittorrent/src/Network/BitTorrent/Exchange/Download.hs delete mode 100644 bittorrent/src/Network/BitTorrent/Exchange/Manager.hs delete mode 100644 bittorrent/src/Network/BitTorrent/Exchange/Message.hs delete mode 100644 bittorrent/src/Network/BitTorrent/Exchange/Session.hs delete mode 100644 bittorrent/src/Network/BitTorrent/Internal/Cache.hs delete mode 100644 bittorrent/src/Network/BitTorrent/Internal/Progress.hs delete mode 100644 bittorrent/src/Network/BitTorrent/Internal/Types.hs delete mode 100644 bittorrent/src/Network/BitTorrent/Readme.md delete mode 100644 bittorrent/src/Network/BitTorrent/Tracker.hs delete mode 100644 bittorrent/src/Network/BitTorrent/Tracker/List.hs delete mode 100644 bittorrent/src/Network/BitTorrent/Tracker/Message.hs delete mode 100644 bittorrent/src/Network/BitTorrent/Tracker/RPC.hs delete mode 100644 bittorrent/src/Network/BitTorrent/Tracker/RPC/HTTP.hs delete mode 100644 bittorrent/src/Network/BitTorrent/Tracker/RPC/UDP.hs delete mode 100644 bittorrent/src/Network/BitTorrent/Tracker/Session.hs delete mode 100644 bittorrent/src/System/Torrent/FileMap.hs delete mode 100644 bittorrent/src/System/Torrent/Storage.hs delete mode 100644 bittorrent/src/System/Torrent/Tree.hs delete mode 100644 bittorrent/tests/Config.hs delete mode 100644 bittorrent/tests/Data/TorrentSpec.hs delete mode 100644 bittorrent/tests/Main.hs delete mode 100644 bittorrent/tests/Network/BitTorrent/Client/HandleSpec.hs delete mode 100644 bittorrent/tests/Network/BitTorrent/CoreSpec.hs delete mode 100644 bittorrent/tests/Network/BitTorrent/DHT/MessageSpec.hs delete mode 100644 bittorrent/tests/Network/BitTorrent/DHT/QuerySpec.hs delete mode 100644 bittorrent/tests/Network/BitTorrent/DHT/RoutingSpec.hs delete mode 100644 bittorrent/tests/Network/BitTorrent/DHT/SessionSpec.hs delete mode 100644 bittorrent/tests/Network/BitTorrent/DHT/TestData.hs delete mode 100644 bittorrent/tests/Network/BitTorrent/DHT/TokenSpec.hs delete mode 100644 bittorrent/tests/Network/BitTorrent/DHTSpec.hs delete mode 100644 bittorrent/tests/Network/BitTorrent/Exchange/BitfieldSpec.hs delete mode 100644 bittorrent/tests/Network/BitTorrent/Exchange/BlockSpec.hs delete mode 100644 bittorrent/tests/Network/BitTorrent/Exchange/ConnectionSpec.hs delete mode 100644 bittorrent/tests/Network/BitTorrent/Exchange/DownloadSpec.hs delete mode 100644 bittorrent/tests/Network/BitTorrent/Exchange/MessageSpec.hs delete mode 100644 bittorrent/tests/Network/BitTorrent/Exchange/SessionSpec.hs delete mode 100644 bittorrent/tests/Network/BitTorrent/Internal/CacheSpec.hs delete mode 100644 bittorrent/tests/Network/BitTorrent/Internal/ProgressSpec.hs delete mode 100644 bittorrent/tests/Network/BitTorrent/Tracker/ListSpec.hs delete mode 100644 bittorrent/tests/Network/BitTorrent/Tracker/MessageSpec.hs delete mode 100644 bittorrent/tests/Network/BitTorrent/Tracker/RPC/HTTPSpec.hs delete mode 100644 bittorrent/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs delete mode 100644 bittorrent/tests/Network/BitTorrent/Tracker/RPCSpec.hs delete mode 100644 bittorrent/tests/Network/BitTorrent/Tracker/SessionSpec.hs delete mode 100644 bittorrent/tests/Network/BitTorrent/Tracker/TestData.hs delete mode 100644 bittorrent/tests/Network/KRPC/MessageSpec.hs delete mode 100644 bittorrent/tests/Network/KRPC/MethodSpec.hs delete mode 100644 bittorrent/tests/Network/KRPCSpec.hs delete mode 100644 bittorrent/tests/Readme.md delete mode 100644 bittorrent/tests/Spec.hs delete mode 100644 bittorrent/tests/System/Torrent/FileMapSpec.hs delete mode 100644 bittorrent/tests/System/Torrent/StorageSpec.hs (limited to 'bittorrent') diff --git a/bittorrent/README.md b/bittorrent/README.md deleted file mode 100644 index 32948896..00000000 --- a/bittorrent/README.md +++ /dev/null @@ -1,78 +0,0 @@ -### BitTorrent [![Build Status][1]][2] - -A [BitTorrent][0] library implementation. It allows to read/write -torrent files, transfer data files, query trackers and DHT. The -library is still in active development and have some subsystems -partially implemented. - -For lastest released version and reference documentation see [hackage][3] page. - -[0]: http://bittorrent.org/beps/bep_0000.html -[1]: https://travis-ci.org/cobit/bittorrent.png -[2]: https://travis-ci.org/cobit/bittorrent -[3]: http://hackage.haskell.org/package/bittorrent - -### Status - -The protocol has [many enchancements][bep-list]. This table keep track -if a particular BEP is "todo", "in progress" or "complete": - -| BEP # | Title | Status -|:-----:|:--------------------------------------------------:|:----------- -| 3 | [The BitTorrent Protocol Specification][bep3] | [In progress][bep3-impl] -| 4 | [Known Number Allocations][bep4] | [In progress][bep4-impl] -| 5 | [DHT][bep5] | [In progress][bep5-impl] -| 6 | [Fast Extension][bep6] | [In progress][bep6-impl] -| 7 | [IPv6 Tracker Extension][bep7] | [In progress][bep7-impl] -| 9 | [Extension for Peers to Send Metadata Files][bep9] | [In progress][bep9-impl] -| 10 | [Extension protocol][bep10] | [In progress][bep10-impl] -| 12 | [Multitracker Metadata Extension][bep10] | [In progress][bep12-impl] -| 15 | [UDP Tracker Protocol for BitTorrent][bep15] | [In progress][bep15-impl] -| 20 | [Peer ID Conventions][bep20] | [Implemented][bep20-impl] -| 23 | [Tracker Return Compact Peer Lists][bep23] | [Implemented][bep23-impl] - -[bep-list]: http://www.bittorrent.org/beps/bep_0000.html -[bep3]: http://www.bittorrent.org/beps/bep_0003.html -[bep4]: http://www.bittorrent.org/beps/bep_0004.html -[bep5]: http://www.bittorrent.org/beps/bep_0005.html -[bep6]: http://www.bittorrent.org/beps/bep_0006.html -[bep7]: http://www.bittorrent.org/beps/bep_0007.html -[bep9]: http://www.bittorrent.org/beps/bep_0009.html -[bep10]: http://www.bittorrent.org/beps/bep_0010.html -[bep12]: http://www.bittorrent.org/beps/bep_0012.html -[bep15]: http://www.bittorrent.org/beps/bep_0015.html -[bep20]: http://www.bittorrent.org/beps/bep_0020.html -[bep23]: http://www.bittorrent.org/beps/bep_0023.html - -[bep3-impl]: src -[bep4-impl]: src/Network/BitTorrent/Exchange/Message.hs -[bep5-impl]: src/Network/BitTorrent/DHT/Protocol.hs -[bep6-impl]: src/Network/BitTorrent/Exchange/Message.hs -[bep7-impl]: src/Network/BitTorrent/Tracker/Message.hs -[bep9-impl]: src/Network/BitTorrent/Exchange/Wire.hs -[bep10-impl]: src/Network/BitTorrent/Exchange/Message.hs -[bep12-impl]: src/Data/Torrent.hs -[bep15-impl]: src/Network/BitTorrent/Tracker/RPC/UDP.hs -[bep20-impl]: src/Network/BitTorrent/Core/Fingerprint.hs -[bep23-impl]: src/Network/BitTorrent/Tracker/Message.hs - -### Hacking - -The root directory layout is as follows: - -* examples -- includes demo utilities to get started; -* src -- the library source tree; -* tests -- the library test suite; -* res -- torrents and data files used in test suite. -* sub -- subprojects and submodules used by the library and still in dev. - -Some subdirectories includes README with futher explanations to get started. - -### Contacts - -* Discussions: IRC [#haskell-bittorrent][irc] at irc.freenode.net -* Bugs & issues: [issue tracker][tracker] -* Maintainer: - -[tracker]: https://github.com/cobit/bittorrent/issues/new -[irc]: http://webchat.freenode.net/?channels=haskell-bittorrent diff --git a/bittorrent/Readme.md b/bittorrent/Readme.md deleted file mode 100644 index e092c3ad..00000000 --- a/bittorrent/Readme.md +++ /dev/null @@ -1,8 +0,0 @@ -Layout -====== - -| module group | can import | main purpose | -|:-------------|:----------------:|:-----------------------:| -| /Network | /Data & /System | peer and data exchange | -| /System | /Data | filesystem interface | -| /Data | | torrent metadata | diff --git a/bittorrent/bench/Main.hs b/bittorrent/bench/Main.hs deleted file mode 100644 index f04485ab..00000000 --- a/bittorrent/bench/Main.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# OPTIONS -fno-warn-orphans #-} -module Main (main) where - -import Control.DeepSeq -import Network -import Control.Monad -import Control.Monad.Logger -import Control.Monad.Reader -import Criterion.Main -import Data.ByteString as BS -import Network.DatagramServer - - -import Network.BitTorrent.Exchange.Protocol as BT -import Data.Torrent.Block as BT -import Data.Torrent.Bitfield as BT - -instance KRPC ByteString ByteString where - method = "echo" - -instance MonadLogger IO where - monadLoggerLog _ _ _ _ = return () - - -instance NFData PortNumber where - rnf = rnf . (fromIntegral :: PortNumber -> Int) - -instance NFData BlockIx where - rnf (BlockIx a b c) = a `deepseq` b `deepseq` rnf c - -instance NFData Block where - rnf (Block a b c) = a `deepseq` b `deepseq` rnf c - -instance NFData Bitfield - -instance NFData Message where - rnf (Have i) = rnf i - rnf (Bitfield b) = rnf b - rnf (Request b) = rnf b - rnf (Piece b) = rnf b - rnf (Cancel b) = rnf b - rnf (Port i) = rnf i - rnf _ = () -- other fields are forced by pattern matching - -{- -encodeMessages :: [Message] -> ByteString -encodeMessages xs = runPut (mapM_ put xs) - -decodeMessages :: ByteString -> Either String [Message] -decodeMessages = runGet (many get) --} - -echo :: Handler IO -echo = handler $ \ _ bs -> return (bs :: ByteString) - -addr :: SockAddr -addr = SockAddrInet 6000 (256 * 256 * 256 + 127) - --- main :: IO () --- main = defaultMain [] -main :: IO () -main = withManager def addr [echo] $ \ m -> (`runReaderT` m) $ do - listen - liftIO $ defaultMain (benchmarks m) - where - sizes = [10, 100, 1000, 10000, 16 * 1024] - repetitions = [1, 10, 100, 1000] - benchmarks m = [mkbench m r s | r <- repetitions, s <- sizes] - where - mkbench action r n = - bench (show r ++ "times" ++ "/" ++ show n ++ "bytes") $ nfIO $ - replicateM r $ - runReaderT (query addr (BS.replicate n 0)) action diff --git a/bittorrent/bench/Throughtput.hs b/bittorrent/bench/Throughtput.hs deleted file mode 100644 index d0404405..00000000 --- a/bittorrent/bench/Throughtput.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE PatternGuards #-} -module Main (main) where - -import Control.Concurrent -import Data.Bitfield -import Network.BitTorrent -import System.Environment -import Control.Monad.Reader -import Data.IORef - - -main :: IO () -main = do - [path] <- getArgs - torrent <- fromFile path - - print (contentLayout "./" (tInfo torrent)) - - client <- newClient 100 [] - swarm <- newLeecher client torrent - - ref <- liftIO $ newIORef 0 - discover swarm $ do - forever $ do - e <- awaitEvent - case e of - Available bf - | Just m <- findMin bf -> yieldEvent (Want (BlockIx m 0 10)) - | otherwise -> return () - Want bix -> liftIO $ print bix - Fragment blk -> do - - sc <- liftIO $ getSessionCount swarm - addr <- asks connectedPeerAddr - - liftIO $ do - x <- atomicModifyIORef ref (\x -> (succ x, x)) - if x `mod` 100 == 0 - then print (x, sc, addr) - else return () - - yieldEvent (Want (BlockIx 0 0 (16 * 1024))) - - - print "Bye-bye! =_=" \ No newline at end of file diff --git a/bittorrent/bench/TorrentFile.hs b/bittorrent/bench/TorrentFile.hs deleted file mode 100644 index e91a9c10..00000000 --- a/bittorrent/bench/TorrentFile.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -module Main (main) where - -import Data.BEncode -import Data.ByteString as BS -import Data.Torrent -import Criterion.Main - - -tinyPath :: FilePath -tinyPath = "res/dapper-dvd-amd64.iso.torrent" - -largePath :: FilePath -largePath = "res/pkg.torrent" - -decoder :: ByteString -> Torrent -decoder bs = let Right r = decode bs in r - -main :: IO () -main = do - !tinyBin <- BS.readFile tinyPath - !largeBin <- BS.readFile largePath - - defaultMain - [ bench "read/tiny" $ nf decoder tinyBin - , bench "read/large" $ nf decoder largeBin - ] \ No newline at end of file diff --git a/bittorrent/bittorrent.cabal b/bittorrent/bittorrent.cabal deleted file mode 100644 index 8ec314e7..00000000 --- a/bittorrent/bittorrent.cabal +++ /dev/null @@ -1,412 +0,0 @@ -name: bittorrent -version: 0.0.0.3 -license: BSD3 -license-file: LICENSE -author: Sam Truzjan -maintainer: Sam Truzjan -copyright: (c) 2013, Sam Truzjan -category: Network -build-type: Custom -cabal-version: >= 1.10 -tested-with: GHC == 7.6.3 -homepage: https://github.com/cobit/bittorrent -bug-reports: https://github.com/cobit/bittorrent/issues -synopsis: BitTorrent protocol implementation. -description: - - A library for making Haskell bittorrent applications easy. - . - For more information see: - - -extra-source-files: res/dapper-dvd-amd64.iso.torrent - res/pkg.torrent - README.md - ChangeLog - cbits/*.h - - -source-repository head - type: git - location: git://github.com/cobit/bittorrent.git - -source-repository this - type: git - location: git://github.com/cobit/bittorrent.git - branch: master - tag: v0.0.0.3 - -flag testing - description: Whether to build tests. - default: False - -flag examples - description: Whether to build examples. - default: False - -flag network-uri - description: Use network-uri package. - default: True - -flag bits-extras - description: Use more-effecient bits-extras bitwise operations. - default: False - -flag dht-only - description: Build only DHT related modules. - default: True - -flag builder - description: Use older bytestring package and bytestring-builder. - default: False - -flag aeson - description: Use aeson for pretty-printing bencoded data. - default: True - -flag thread-debug - description: Add instrumentation to threads. - default: True - -library - default-language: Haskell2010 - default-extensions: PatternGuards - , OverloadedStrings - , RecordWildCards - hs-source-dirs: src, cryptonite-backport, . - exposed-modules: Network.SocketLike - Data.Digest.CRC32C - Data.Bits.ByteString - Data.Wrapper.PSQ - Data.Wrapper.PSQInt - Data.MinMaxPSQ - Network.Address - Network.Kademlia.Routing - Data.Torrent - Network.BitTorrent.DHT.ContactInfo - Network.BitTorrent.DHT.Token - Network.Kademlia.Search - Network.QueryResponse - Network.StreamServer - Data.BEncode.Pretty - Control.Concurrent.Tasks - Network.Kademlia - Network.BitTorrent.MainlineDHT - System.Global6 - Network.Tox - Network.Tox.Transport - Network.Tox.Crypto.Transport - Network.Tox.Onion.Handlers - Network.Tox.Onion.Transport - Network.Tox.DHT.Handlers - Network.Tox.DHT.Transport - Network.Tox.NodeId - Control.TriadCommittee - Crypto.Tox - Text.XXD - - build-depends: base - , containers - , array - , hashable - , iproute - , stm - , base16-bytestring - , base32-bytestring - , base64-bytestring - , psqueues - , reflection - , deepseq - , text - , filepath - , directory - , bencoding - , contravariant - - , cryptonite - , memory - , time - , random - , entropy - , cpu - - , cereal - , http-types - - , process - , split - , pretty - , convertible - , data-default - - , bifunctors - , lens - , lifted-async - , lifted-base - , monad-control - , transformers-base - , mtl - - if flag(network-uri) - Build-depends: network >= 2.6 - , network-uri >= 2.6 - else - Build-depends: network >= 2.4 && < 2.6 - - - other-modules: Paths_bittorrent - Crypto.Cipher.Salsa - Crypto.Cipher.XSalsa - Crypto.ECC.Class - Crypto.ECC.Simple.Prim - Crypto.ECC.Simple.Types - Crypto.Error.Types - Crypto.Internal.ByteArray - Crypto.Internal.Compat - Crypto.Internal.DeepSeq - Crypto.Internal.Imports - Crypto.PubKey.Curve25519 - - C-sources: cbits/cryptonite_xsalsa.c, cbits/cryptonite_salsa.c - - if !flag(dht-only) - exposed-modules: Network.BitTorrent - Network.BitTorrent.Client - Network.BitTorrent.Client.Types - Network.BitTorrent.Client.Handle - Network.BitTorrent.Exchange - Network.BitTorrent.Exchange.Bitfield - Network.BitTorrent.Exchange.Block - Network.BitTorrent.Exchange.Connection - Network.BitTorrent.Exchange.Download - Network.BitTorrent.Exchange.Manager - Network.BitTorrent.Exchange.Message - Network.BitTorrent.Exchange.Session - Network.BitTorrent.Tracker - Network.BitTorrent.Tracker.List - Network.BitTorrent.Tracker.Message - Network.BitTorrent.Tracker.RPC - Network.BitTorrent.Tracker.RPC.HTTP - Network.BitTorrent.Tracker.RPC.UDP - Network.BitTorrent.Tracker.Session - System.Torrent.Storage - if !flag(dht-only) - if flag(testing) - exposed-modules: - Network.BitTorrent.Internal.Cache - Network.BitTorrent.Internal.Progress - Network.BitTorrent.Internal.Types - System.Torrent.FileMap - System.Torrent.Tree - else - other-modules: - Network.BitTorrent.Internal.Cache - Network.BitTorrent.Internal.Progress - Network.BitTorrent.Internal.Types - System.Torrent.FileMap - System.Torrent.Tree - if flag(aeson) - build-depends: aeson, aeson-pretty, unordered-containers, vector - cpp-options: -DBENCODE_AESON - if flag(thread-debug) - exposed-modules: Control.Concurrent.Lifted.Instrument - Control.Concurrent.Async.Lifted.Instrument - cpp-options: -DTHREAD_DEBUG - - if flag(builder) - build-depends: bytestring >= 0.9, bytestring-builder - else - build-depends: bytestring >= 0.10 - if impl(ghc < 7.6) - build-depends: ghc-prim - ghc-options: -Wall -fdefer-typed-holes - ghc-prof-options: - - -test-suite spec - if !flag(testing) - buildable: False - default-language: Haskell2010 - default-extensions: OverloadedStrings - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: Main.hs - other-modules: Spec - Config - Network.KRPCSpec - Network.KRPC.MethodSpec - Network.DatagramServer.MainlineSpec - Data.TorrentSpec - Network.BitTorrent.Client.HandleSpec - Network.BitTorrent.CoreSpec - Network.BitTorrent.DHTSpec - Network.BitTorrent.DHT.TestData - Network.BitTorrent.DHT.MessageSpec - Network.BitTorrent.DHT.QuerySpec - Network.Kademlia.RoutingSpec - Network.BitTorrent.DHT.SessionSpec - Network.BitTorrent.DHT.TokenSpec - Network.BitTorrent.Internal.CacheSpec - Network.BitTorrent.Internal.ProgressSpec - Network.BitTorrent.Tracker.TestData - Network.BitTorrent.Tracker.ListSpec - Network.BitTorrent.Tracker.MessageSpec - Network.BitTorrent.Tracker.RPCSpec - Network.BitTorrent.Tracker.RPC.HTTPSpec - Network.BitTorrent.Tracker.RPC.UDPSpec - Network.BitTorrent.Tracker.SessionSpec - Network.BitTorrent.Exchange.BitfieldSpec - Network.BitTorrent.Exchange.ConnectionSpec - Network.BitTorrent.Exchange.DownloadSpec - Network.BitTorrent.Exchange.MessageSpec - Network.BitTorrent.Exchange.SessionSpec - System.Torrent.StorageSpec - System.Torrent.FileMapSpec - build-depends: base == 4.* - - -- * Concurrency - , async - - -- * Data - , bytestring - , bytestring-arbitrary - , containers - , convertible - , data-default - , text - , time - - -- * Serialization - , cereal - - -- * Monads - , mtl - , resourcet - , conduit - , conduit-extra - , monad-loops - , monad-logger - - -- * Network - , http-types - , iproute - - -- * System - , optparse-applicative >= 0.8 - , process - , directory - , filepath - - -- * Testing - , hspec >= 1.8.2 - , QuickCheck - , quickcheck-instances - - -- * Bittorrent - , bittorrent - , temporary - , bencoding >= 0.4.3 - if flag(network-uri) - Build-depends: network >= 2.6 - , network-uri >= 2.6 - else - Build-depends: network >= 2.4 && < 2.6 - ghc-options: -Wall -fno-warn-orphans - - ---benchmark bench --- default-language: Haskell2010 --- default-extensions: --- type: exitcode-stdio-1.0 --- hs-source-dirs: bench --- main-is: Main.hs --- build-depends: base --- , bytestring --- , cereal --- , network --- --- , criterion --- , deepseq --- --- , bittorrent --- ghc-options: -O2 -Wall -fno-warn-orphans -benchmark bench - type: exitcode-stdio-1.0 - default-language: Haskell2010 - hs-source-dirs: bench - main-is: Main.hs - build-depends: base == 4.* - , bytestring - , mtl - , monad-logger - , criterion - ghc-options: -O2 -fforce-recomp - -executable dht - hs-source-dirs: examples - main-is: dht.hs - default-language: Haskell2010 - build-depends: base, haskeline, network, bytestring, transformers - -executable dhtd - hs-source-dirs: examples - main-is: dhtd.hs - default-language: Haskell2010 - build-depends: base, network, bytestring, hashable, deepseq - , aeson - , pretty - , bittorrent - , unix - , containers - , stm - , cereal - , bencoding - if flag(thread-debug) - build-depends: time - cpp-options: -DTHREAD_DEBUG - --- Utility to work with torrent files. -executable mktorrent - if !flag(examples) - buildable: False - default-language: Haskell2010 - hs-source-dirs: examples - main-is: MkTorrent.hs - other-modules: Paths_bittorrent - build-depends: base == 4.* - , bytestring - , text - , pretty - - , mtl - , conduit - , lens - , lifted-async - , parallel-io - - , bittorrent - - , filepath - , optparse-applicative - , hslogger --- if flag(network-uri) --- Build-depends: - , network >= 2.6 - , network-uri >= 2.6 --- else --- Build-depends: network >= 2.4 && < 2.6 - ghc-options: -Wall -O2 -threaded - --- nonfunctioning example of very basic bittorrent client -executable client - if !flag(examples) - buildable: False - default-language: Haskell2010 - hs-source-dirs: examples - main-is: Client.hs - build-depends: base == 4.* - , bittorrent - , mtl - , pretty - , data-default - , optparse-applicative diff --git a/bittorrent/dev/README.md b/bittorrent/dev/README.md deleted file mode 100644 index e2cc51a6..00000000 --- a/bittorrent/dev/README.md +++ /dev/null @@ -1,4 +0,0 @@ -This directory is for some dev scripts and other dev only stuff which -we don't want to keep in the resulting `cabal sdist` generated -tarball. Do _not_ include any of these files to .cabal file, neither -to `extra-source-files` nor to `data-files` sections. diff --git a/bittorrent/dev/add-sources.sh b/bittorrent/dev/add-sources.sh deleted file mode 100755 index e125cade..00000000 --- a/bittorrent/dev/add-sources.sh +++ /dev/null @@ -1,5 +0,0 @@ -#!/bin/bash - -for s in $(ls $(dirname $0)/../sub); do - (cd $(dirname $0)/.. && cabal sandbox add-source sub/$s) -done diff --git a/bittorrent/dev/bench b/bittorrent/dev/bench deleted file mode 100755 index 5d03db3f..00000000 --- a/bittorrent/dev/bench +++ /dev/null @@ -1,4 +0,0 @@ -#!/bin/sh -cabal-dev build && - ./dist/build/benchmarks/benchmarks -o dist/build/benchmarks/result.html && - xdg-open dist/build/benchmarks/result.html \ No newline at end of file diff --git a/bittorrent/dev/test b/bittorrent/dev/test deleted file mode 100755 index 2eb85df2..00000000 --- a/bittorrent/dev/test +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/sh -cabal-dev build && cabal-dev test || echo "ERROR: Some tests failed." diff --git a/bittorrent/dev/update-dependencies.sh b/bittorrent/dev/update-dependencies.sh deleted file mode 100755 index c83694c3..00000000 --- a/bittorrent/dev/update-dependencies.sh +++ /dev/null @@ -1,11 +0,0 @@ -#!/bin/sh - -cd $(dirname $0)/.. - -git submodule init -git submodule foreach git fetch -git submodule update --recursive --checkout --force - -$(dirname $0)/add-sources.sh - -cabal install --enable-tests --only-dependencies --reinstall diff --git a/bittorrent/examples/Client.hs b/bittorrent/examples/Client.hs deleted file mode 100644 index 26711676..00000000 --- a/bittorrent/examples/Client.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE RecordWildCards #-} -module Main (main) where -import Control.Concurrent -import Control.Monad.Trans -import Data.Maybe -import Options.Applicative -import System.Environment -import System.Exit -import System.IO -import Text.Read - -import Network.BitTorrent - -#if MIN_VERSION_optparse_applicative(0,13,0) --- maybeReader imported from Options.Applicative.Builder -#elif MIN_VERSION_optparse_applicative(0,11,0) -maybeReader f = eitherReader (maybe (Left ":(") Right . f) -#else -maybeReader f = f -#endif - -{----------------------------------------------------------------------- --- Command line arguments ------------------------------------------------------------------------} - -data TorrentBox = forall s. TorrentSource s => TorrentBox { unTorrentBox :: s } - -data Args = Args - { topic :: TorrentBox - , contentDir :: FilePath - } - -argsParser :: Parser Args -argsParser = Args <$> (TorrentBox <$> infohashP <|> TorrentBox <$> torrentP) - <*> destDirP - where - infohashP :: Parser InfoHash - infohashP = argument (maybeReader readMaybe) - (metavar "SHA1" <> help "infohash of torrent file") - - torrentP :: Parser FilePath - torrentP = argument (maybeReader Just) - ( metavar "FILE" - <> help "A .torrent file" - ) - - destDirP :: Parser FilePath - destDirP = argument (maybeReader Just) - ( metavar "DIR" - <> help "Directory to put content" - ) - -argsInfo :: ParserInfo Args -argsInfo = info (helper <*> argsParser) - ( fullDesc - <> progDesc "A simple CLI bittorrent client" - <> header "foo" - ) - -{----------------------------------------------------------------------- --- Client ------------------------------------------------------------------------} - -run :: Args -> BitTorrent () -run (Args (TorrentBox t) dir) = do - h <- openHandle dir t - start h - liftIO $ threadDelay 10000000000 - -main :: IO () -main = execParser argsInfo >>= simpleClient . run diff --git a/bittorrent/examples/FS.hs b/bittorrent/examples/FS.hs deleted file mode 100644 index 550d85a7..00000000 --- a/bittorrent/examples/FS.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module Main (main) where - -import Control.Arrow -import Data.ByteString.Char8 as BC -import Data.List as L -import Data.Map as M -import Data.Torrent as T -import Data.Torrent.Tree as T -import System.Environment -import System.Fuse -import System.FilePath -import System.Posix.Files - - -defStat :: FileStat -defStat = FileStat - { statEntryType = Unknown - , statFileMode = ownerReadMode - , statLinkCount = 2 - - , statFileOwner = 0 - , statFileGroup = 0 - - , statSpecialDeviceID = 0 - - , statFileSize = 0 - , statBlocks = 0 - - , statAccessTime = 0 - , statModificationTime = 0 - , statStatusChangeTime = 0 - } - -dirStat :: FileStat -dirStat = defStat { - statEntryType = Directory - } - -type Result a = IO (Either Errno a) -type Result' = IO Errno - -fsGetFileStat :: Torrent -> FilePath -> Result FileStat -fsGetFileStat _ path = return $ Right dirStat - -fsOpenDirectory :: Torrent -> FilePath -> Result' -fsOpenDirectory _ _ = return eOK - -fsReadDirectory :: Torrent -> FilePath -> Result [(FilePath, FileStat)] -fsReadDirectory Torrent {tInfoDict = InfoDict {..}} path - | Just cs <- T.lookupDir (L.tail (splitDirectories path)) tree = - return $ Right $ L.map (BC.unpack *** const defStat) cs - | otherwise = return $ Left eNOENT - where - tree = build $ idLayoutInfo - -fsReleaseDirectory :: Torrent -> FilePath -> Result' -fsReleaseDirectory _ _ = return eOK - -exfsOps :: Torrent -> FuseOperations () -exfsOps t = defaultFuseOps - { fuseGetFileStat = fsGetFileStat t - - , fuseOpenDirectory = fsOpenDirectory t - , fuseReadDirectory = fsReadDirectory t - , fuseReleaseDirectory = fsReleaseDirectory t - } - -main :: IO () -main = do - x : xs <- getArgs - t <- fromFile x - withArgs xs $ do - fuseMain (exfsOps t) defaultExceptionHandler \ No newline at end of file diff --git a/bittorrent/examples/MkTorrent.hs b/bittorrent/examples/MkTorrent.hs deleted file mode 100644 index 88a84893..00000000 --- a/bittorrent/examples/MkTorrent.hs +++ /dev/null @@ -1,500 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS -fno-warn-orphans #-} -module Main (main) where - -import Prelude as P -import Control.Concurrent -import Control.Concurrent.Async.Lifted -import Control.Concurrent.ParallelIO -import Control.Exception -import Control.Lens hiding (argument, (<.>)) -import Control.Monad as M -import Control.Monad.Trans -import Data.Conduit as C -import Data.Conduit.List as C -import Data.List as L -import Data.Maybe as L -import Data.Monoid -import Data.Text as T -import qualified Data.Text.IO as T -import Data.Text.Read as T -import Data.Version -import Network -import Network.URI -import Options.Applicative -import System.Exit -import System.FilePath -import System.Log -import System.Log.Logger -import Text.Read -import Text.PrettyPrint.HughesPJClass hiding ((<>),($$)) - -import Paths_bittorrent (version) -import Data.Torrent hiding (Magnet (Magnet)) -import Network.Address -import Network.BitTorrent.DHT.Session hiding (Options, options) -import Network.BitTorrent.DHT as DHT hiding (Options) -import Network.BitTorrent.Exchange.Bitfield as BF -import Network.BitTorrent.Exchange.Connection hiding (Options) -import Network.BitTorrent.Exchange.Message -import Network.BitTorrent.Exchange.Session -import System.Torrent.Storage - -#if MIN_VERSION_optparse_applicative(0,13,0) --- maybeReader imported from Options.Applicative.Builder -#elif MIN_VERSION_optparse_applicative(0,11,0) -maybeReader f = eitherReader (maybe (Left ":(") Right . f) -#else -maybeReader f = f -#endif - - -{----------------------------------------------------------------------- --- Dialogs ------------------------------------------------------------------------} - -instance Read URI where - readsPrec _ = f . parseURI - where - f Nothing = [] - f (Just u) = [(u, "")] - -question :: Show a => Text -> Maybe a -> IO () -question q defVal = do - T.putStrLn q - case defVal of - Nothing -> return () - Just v -> T.putStrLn $ "[default: " <> T.pack (show v) <> "]" - -ask :: Read a => Text -> IO a -ask q = question q (Just True) >> getReply - where - getReply = do - resp <- P.getLine - maybe getReply return $ readMaybe resp - -askMaybe :: Read a => Text -> IO (Maybe a) -askMaybe q = question q (Just False) >> getReply - where - getReply = do - resp <- P.getLine - if resp == [] - then return Nothing - else maybe getReply return $ readMaybe resp - -askURI :: IO URI -askURI = do - s <- P.getLine - case parseURI s of - Nothing -> T.putStrLn "incorrect URI" >> askURI - Just u -> return u - -askFreeform :: IO Text -askFreeform = do - s <- T.getLine - if T.null s - then askFreeform - else return s - -askInRange :: Int -> Int -> IO Int -askInRange a b = do - s <- T.getLine - case T.decimal s of - Left msg -> do - P.putStrLn msg - askInRange a b - Right (i, _) - | a <= i && i < b -> return i - | otherwise -> do - T.putStrLn "not in range " - askInRange a b - -askChoice :: [(Text, a)] -> IO a -askChoice kvs = do - forM_ (L.zip [1 :: Int ..] $ L.map fst kvs) $ \(i, lbl) -> do - T.putStrLn $ " " <> T.pack (show i) <> ") " <> lbl - T.putStrLn "Your choice?" - n <- askInRange 1 (succ (L.length kvs)) - return $ snd (kvs !! pred n) - -{----------------------------------------------------------------------- --- Helpers ------------------------------------------------------------------------} - -torrentFile :: Parser FilePath -torrentFile = argument (maybeReader Just) - ( metavar "TORRENT_FILE_PATH" - <> help "A .torrent file" - ) - -{----------------------------------------------------------------------- --- Amend command - edit a field of torrent file ------------------------------------------------------------------------} - -data AmendOpts = AmendOpts FilePath - deriving Show - -amendInfo :: ParserInfo AmendOpts -amendInfo = info (helper <*> parser) modifier - where - modifier = progDesc "Edit info fields of existing torrent" - parser = AmendOpts <$> torrentFile - -type Amend = Torrent -> Torrent - -fields :: [(Text, IO Amend)] -fields = [ ("announce", set announce . Just <$> askURI) - , ("comment", set comment . Just <$> askFreeform) - , ("created by", set createdBy . Just <$> askFreeform) - , ("publisher url", set publisherURL . Just <$> askURI) - ] - -askAmend :: IO Amend -askAmend = join $ T.putStrLn "Choose a field:" >> askChoice fields - -amend :: AmendOpts -> IO () -amend (AmendOpts tpath) = do - t <- fromFile tpath - a <- askAmend - toFile tpath $ a t - -{----------------------------------------------------------------------- --- Check command -- validate content files using torrent file ------------------------------------------------------------------------} --- TODO progress bar - -data CheckOpts = CheckOpts - { checkTorrentPath :: FilePath -- ^ validation torrent file - , checkContentPath :: FilePath -- ^ root dir for content files - } deriving Show - -checkInfo :: ParserInfo CheckOpts -checkInfo = info (helper <*> parser) modifier - where - modifier = progDesc "Validate integrity of torrent data" - <> header "append +RTS -N$NUMBER_OF_CORES -RTS for parallel execution" - parser = CheckOpts - <$> torrentFile - <*> argument (maybeReader Just) - ( metavar "CONTENT_DIR_PATH" - <> value "." - <> help "Content directory or a single file" - ) - -validatePiece :: Storage -> PieceInfo -> PieceIx -> IO (Maybe PieceIx) -validatePiece s pinfo pix = do - valid <- verifyPiece s pinfo pix - if valid - then do infoM "check" $ "valid piece " ++ show pix - return (Just pix) - else do infoM "check" $ "invalid piece " ++ show pix - return Nothing - -validateStorage :: Storage -> PieceInfo -> IO Bitfield -validateStorage s pinfo = do - infoM "check" "start storage validation" - let total = totalPieces s - pixs <- parallel $ L.map (validatePiece s pinfo) [0 .. total - 1] - infoM "check" "storage validation finished" - return $ fromList total $ L.catMaybes pixs - --- TODO use local thread pool -checkContent :: Storage -> PieceInfo -> IO () -checkContent s pinfo = do - invalids <- BF.complement <$> validateStorage s pinfo - if BF.null invalids - then noticeM "check" "all files are complete and valid" - else do - emergencyM "check" $ "there are some invalid pieces" ++ show invalids - exitFailure - -checkTorrent :: CheckOpts -> IO () -checkTorrent CheckOpts {..} = do - infoM "check" "openning torrent file..." - InfoDict {..} <- tInfoDict <$> fromFile checkTorrentPath - let layout = flatLayout checkContentPath idLayoutInfo - infoM "check" "mapping content files..." - withStorage ReadOnly (piPieceLength idPieceInfo) layout $ \ s -> do - infoM "check" "files mapped" - checkContent s idPieceInfo - infoM "check" "unmapping files" - -{----------------------------------------------------------------------- --- Create command ------------------------------------------------------------------------} --- TODO progress bar --- TODO multifile torrents --- TODO interactive mode --- TODO non interactive mode --- TODO --ignore-dot-files --- TODO --md5 --- TODO --piece-size - -{- -createFlags :: Parser CreateFlags -createFlags = CreateFlags - <$> optional (option - ( long "piece-size" - <> short 's' - <> metavar "SIZE" - <> help "Set size of torrent pieces" - )) - <*> switch - ( long "md5" - <> short '5' - <> help "Include md5 hash of each file" - ) - <*> switch - ( long "ignore-dot-files" - <> short 'd' - <> help "Do not include .* files" - ) - - -createOpts :: Parser CreateOpts -createOpts = CreateOpts - <$> argument (maybeReader Just) - ( metavar "PATH" - <> help "Content directory or a single file" - ) - <*> optional (argument (maybeReader Just) - ( metavar "FILE" - <> help "Place for the output .torrent file" - )) - <*> createFlags - -createInfo :: ParserInfo CreateOpts -createInfo = info (helper <*> createOpts) modifier - where - modifier = progDesc "Make a new .torrent file" --} - -{----------------------------------------------------------------------- --- Magnet command -- print magnet link for given torrent file ------------------------------------------------------------------------} - -data MagnetOpts = MagnetOpts - { magnetFile :: FilePath -- ^ path to torrent file - , detailed :: Bool -- ^ whether to append additional uri params - } deriving Show - -magnetInfo :: ParserInfo MagnetOpts -magnetInfo = info (helper <*> parser) modifier - where - modifier = progDesc "Print magnet link" - parser = MagnetOpts - <$> torrentFile - <*> switch ( long "detailed" ) - -magnet :: MagnetOpts -> IO () -magnet MagnetOpts {..} = print . magnetLink =<< fromFile magnetFile - where - magnetLink = if detailed then detailedMagnet else simpleMagnet - -{----------------------------------------------------------------------- --- Show command - print torrent file information ------------------------------------------------------------------------} - -data ShowOpts = ShowOpts - { showPath :: FilePath -- ^ torrent file to inspect; - , infoHashOnly :: Bool -- ^ omit everything except infohash. - } deriving Show - -showInfo :: ParserInfo ShowOpts -showInfo = info (helper <*> parser) modifier - where - modifier = progDesc "Print .torrent file metadata" - parser = ShowOpts - <$> torrentFile - <*> switch - ( long "infohash" - <> help "Show only hash of the torrent info part" - ) - -showTorrent :: ShowOpts -> Torrent -> ShowS -showTorrent ShowOpts {..} torrent - | infoHashOnly = shows $ idInfoHash (tInfoDict torrent) - | otherwise = shows $ pPrint torrent - -putTorrent :: ShowOpts -> IO () -putTorrent opts @ ShowOpts {..} = do - torrent <- fromFile showPath `onException` putStrLn msg - putStrLn $ showTorrent opts torrent [] - where - msg = "Torrent file is either invalid or do not exist" - -{----------------------------------------------------------------------- --- Get command - fetch torrent by infohash ------------------------------------------------------------------------} - -data GetOpts = GetOpts - { topic :: InfoHash - , servPort :: PortNumber - , bootNode :: NodeAddr IPv4 - , buckets :: Int - } deriving Show - -#if !MIN_VERSION_network(2,6,3) -instance Read PortNumber where - readsPrec i s = [ (toEnum a, t) | (a, t) <- readsPrec i s] -#endif - -paramsParser :: Parser GetOpts -paramsParser = GetOpts - <$> argument (maybeReader readMaybe) - (metavar "SHA1" <> help "infohash of torrent file") - <*> option auto (long "port" <> short 'p' - <> value 7000 <> showDefault - <> metavar "NUM" <> help "port number to bind" - ) - <*> option auto (long "boot" <> short 'b' - <> metavar "NODE" <> help "bootstrap node address" - ) - <*> option auto (long "bucket" <> short 'n' - <> value 2 <> showDefault - <> metavar "NUM" <> help "number of buckets to maintain" - ) - -getInfo :: ParserInfo GetOpts -getInfo = info (helper <*> paramsParser) - ( fullDesc - <> progDesc "Get torrent file by infohash" - <> header "get torrent file by infohash" - ) - - -- TODO add tNodes, tCreated, etc? -getTorrent :: GetOpts -> IO () -getTorrent GetOpts {..} = do - infoM "get" "searching for peers..." - s <- newSession (\ _ _ _ _ -> return ()) (PeerAddr Nothing Nothing 7000) "/tmp" (Left topic) - dht (def { optBucketCount = buckets }) (NodeAddr "0.0.0.0" servPort) $ do - bootstrap [bootNode] - infodict <- withAsync (DHT.lookup topic $$ connectSink s) - (const (liftIO $ waitMetadata s)) - liftIO $ toFile (show topic <.> torrentExt) $ nullTorrent infodict - infoM "get" "saved torrent file" - -{----------------------------------------------------------------------- --- Command ------------------------------------------------------------------------} - -data Command - = Amend AmendOpts - | Check CheckOpts --- | Create CreateOpts - | Get GetOpts - | Magnet MagnetOpts - | Show ShowOpts - deriving Show - -commandOpts :: Parser Command -commandOpts = subparser $ mconcat - [ command "amend" (Amend <$> amendInfo) - , command "check" (Check <$> checkInfo) --- , command "create" (Create <$> createInfo) - , command "get" (Get <$> getInfo) - , command "magnet" (Magnet <$> magnetInfo) - , command "show" (Show <$> showInfo) - ] - -{----------------------------------------------------------------------- --- Global Options ------------------------------------------------------------------------} - -data GlobalOpts = GlobalOpts - { verbosity :: Priority - } deriving Show - -#if !MIN_VERSION_hslogger(1,2,9) -deriving instance Enum Priority -deriving instance Bounded Priority -#endif - -priorities :: [Priority] -priorities = [minBound..maxBound] - -defaultPriority :: Priority -defaultPriority = WARNING - -verbosityOpts :: Parser Priority -verbosityOpts = verbosityP <|> verboseP <|> quietP - where - verbosityP = option auto - ( long "verbosity" - <> metavar "LEVEL" - <> help ("Set verbosity level\n" - ++ "Possible values are " ++ show priorities) - ) - - verboseP = flag defaultPriority INFO - ( long "verbose" - <> short 'v' - <> help "Verbose mode" - ) - - quietP = flag defaultPriority CRITICAL - ( long "quiet" - <> short 'q' - <> help "Silent mode" - ) - - -globalOpts :: Parser GlobalOpts -globalOpts = GlobalOpts <$> verbosityOpts - -data Options = Options - { cmdOpts :: Command - , globOpts :: GlobalOpts - } deriving Show - -options :: Parser Options -options = Options <$> commandOpts <*> globalOpts - -versioner :: String -> Version -> Parser (a -> a) -#if MIN_VERSION_optparse_applicative(0,10,0) -versioner prog ver = nullOption disabled $ mconcat -#else -versioner prog ver = nullOption $ mconcat -#endif - [ long "version" - , help "Show program version and exit" - , value id - , metavar "" - , hidden - , mempty -- reader $ const $ undefined -- Left $ ErrorMsg versionStr - ] - where - versionStr = prog ++ " version " ++ showVersion ver - -parserInfo :: ParserInfo Options -parserInfo = info parser modifier - where - parser = helper <*> versioner "mktorrent" version <*> options - modifier = header synopsis <> progDesc description <> fullDesc - synopsis = "Torrent management utility" - description = "" -- TODO - -{----------------------------------------------------------------------- --- Dispatch ------------------------------------------------------------------------} - -run :: Command -> IO () -run (Amend opts) = amend opts -run (Check opts) = checkTorrent opts ---run (Create opts) = createTorrent opts -run (Get opts) = getTorrent opts -run (Magnet opts) = magnet opts -run (Show opts) = putTorrent opts - -prepare :: GlobalOpts -> IO () -prepare GlobalOpts {..} = do - updateGlobalLogger rootLoggerName (setLevel verbosity) - -main :: IO () -main = do - Options {..} <- execParser parserInfo - prepare globOpts - run cmdOpts diff --git a/bittorrent/res/dapper-dvd-amd64.iso.torrent b/bittorrent/res/dapper-dvd-amd64.iso.torrent deleted file mode 100644 index 5713344b..00000000 Binary files a/bittorrent/res/dapper-dvd-amd64.iso.torrent and /dev/null differ diff --git a/bittorrent/res/pkg.torrent b/bittorrent/res/pkg.torrent deleted file mode 100644 index be89e9e0..00000000 Binary files a/bittorrent/res/pkg.torrent and /dev/null differ diff --git a/bittorrent/res/testfile b/bittorrent/res/testfile deleted file mode 100644 index 8e984818..00000000 Binary files a/bittorrent/res/testfile and /dev/null differ diff --git a/bittorrent/res/testfile.torrent b/bittorrent/res/testfile.torrent deleted file mode 100644 index 297f56a2..00000000 --- a/bittorrent/res/testfile.torrent +++ /dev/null @@ -1 +0,0 @@ -d8:announce44:udp://tracker.openbittorrent.com:80/announce10:created by26:Enhanced-CTorrent/dnh3.3.213:creation datei1387753787e4:infod6:lengthi8192e4:name8:testfile12:piece lengthi262144e6:pieces20:œd•Dú—uÈÔtÝ®aÿöK³2e5:nodesll21:router.bittorrent.comi6881eeee \ No newline at end of file diff --git a/bittorrent/src/Network/BitTorrent.hs b/bittorrent/src/Network/BitTorrent.hs deleted file mode 100644 index 91a58887..00000000 --- a/bittorrent/src/Network/BitTorrent.hs +++ /dev/null @@ -1,61 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- -{-# LANGUAGE RecordWildCards #-} -module Network.BitTorrent - ( -- * Client - Options (..) - - -- ** Session - , Client - , clientPeerId - , clientListenerPort - , allowedExtensions - - -- ** Initialization - , LogFun - , newClient - , closeClient - , withClient - - -- ** Monadic - , MonadBitTorrent (..) - , BitTorrent - , runBitTorrent - , getClient - , simpleClient - - -- * Torrent - -- ** Source - , InfoHash - , Magnet - , InfoDict - , Torrent - - -- ** Handle - , Handle - , handleTopic - , handleTrackers - , handleExchange - - , TorrentSource(openHandle) - , closeHandle - , getHandle - , getIndex - - -- ** Control - , start - , pause - , stop - - -- * Events - , EventSource (..) - ) where - -import Data.Torrent -import Network.BitTorrent.Client -import Network.BitTorrent.Internal.Types \ No newline at end of file diff --git a/bittorrent/src/Network/BitTorrent/Client.hs b/bittorrent/src/Network/BitTorrent/Client.hs deleted file mode 100644 index c84290dd..00000000 --- a/bittorrent/src/Network/BitTorrent/Client.hs +++ /dev/null @@ -1,195 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -module Network.BitTorrent.Client - ( -- * Options - Options (..) - - -- * Client session - , Client - - -- ** Session data - , clientPeerId - , clientListenerPort - , allowedExtensions - - -- ** Session initialization - , LogFun - , newClient - , closeClient - , withClient - , simpleClient - - -- * BitTorrent monad - , MonadBitTorrent (..) - , BitTorrent - , runBitTorrent - , getClient - - -- * Handle - , Handle - , handleTopic - , handleTrackers - , handleExchange - - -- ** Construction - , TorrentSource (..) - , closeHandle - - -- ** Query - , getHandle - , getIndex - - -- ** Management - , start - , pause - , stop - ) where - -import Control.Applicative -import Control.Exception -import Control.Concurrent -import Control.Concurrent.Chan.Split as CS -import Control.Monad.Logger -import Control.Monad.Trans -import Control.Monad.Trans.Resource - -import Data.Default -import Data.HashMap.Strict as HM -import Data.Text -import Network - -import Data.Torrent -import Network.Address -import Network.BitTorrent.Client.Types -import Network.BitTorrent.Client.Handle -import Network.BitTorrent.DHT as DHT hiding (Options) -import Network.BitTorrent.Tracker as Tracker hiding (Options) -import Network.BitTorrent.Exchange as Exchange hiding (Options) -import qualified Network.BitTorrent.Exchange as Exchange (Options(..)) - - -data Options = Options - { optFingerprint :: Fingerprint - , optName :: Text - , optPort :: PortNumber - , optExtensions :: [Extension] - , optNodeAddr :: NodeAddr IPv4 - , optBootNode :: Maybe (NodeAddr IPv4) - } - -instance Default Options where - def = Options - { optFingerprint = def - , optName = "hs-bittorrent" - , optPort = 6882 - , optExtensions = [] - , optNodeAddr = "0.0.0.0:6882" - , optBootNode = Nothing - } - -exchangeOptions :: PeerId -> Options -> Exchange.Options -exchangeOptions pid Options {..} = Exchange.Options - { optPeerAddr = PeerAddr (Just pid) (peerHost def) optPort - , optBacklog = optBacklog def - } - -connHandler :: MVar (HashMap InfoHash Handle) -> Exchange.Handler -connHandler tmap ih = do - m <- readMVar tmap - case HM.lookup ih m of - Nothing -> error "torrent not found" - Just (Handle {..}) -> return handleExchange - -initClient :: Options -> LogFun -> ResIO Client -initClient opts @ Options {..} logFun = do - pid <- liftIO genPeerId - tmap <- liftIO $ newMVar HM.empty - - let peerInfo = PeerInfo pid Nothing optPort - let mkTracker = Tracker.newManager def peerInfo - (_, tmgr) <- allocate mkTracker Tracker.closeManager - - let mkEx = Exchange.newManager (exchangeOptions pid opts) (connHandler tmap) - (_, emgr) <- allocate mkEx Exchange.closeManager - - let mkNode = DHT.newNode defaultHandlers def optNodeAddr logFun Nothing - (_, node) <- allocate mkNode DHT.closeNode - - resourceMap <- getInternalState - eventStream <- liftIO newSendPort - - return Client - { clientPeerId = pid - , clientListenerPort = optPort - , allowedExtensions = toCaps optExtensions - , clientResources = resourceMap - , trackerManager = tmgr - , exchangeManager = emgr - , clientNode = node - , clientTorrents = tmap - , clientLogger = logFun - , clientEvents = eventStream - } - -newClient :: Options -> LogFun -> IO Client -newClient opts logFun = do - s <- createInternalState - runInternalState (initClient opts logFun) s - `onException` closeInternalState s - -closeClient :: Client -> IO () -closeClient Client {..} = closeInternalState clientResources - -withClient :: Options -> LogFun -> (Client -> IO a) -> IO a -withClient opts lf action = bracket (newClient opts lf) closeClient action - --- do not perform IO in 'initClient', do it in the 'boot' ---boot :: BitTorrent () ---boot = do --- Options {..} <- asks options --- liftDHT $ bootstrap (maybeToList optBootNode) - --- | Run bittorrent client with default options and log to @stderr@. --- --- For testing purposes only. --- -simpleClient :: BitTorrent () -> IO () -simpleClient m = do - runStderrLoggingT $ LoggingT $ \ logger -> do - withClient def logger (`runBitTorrent` m) - -{----------------------------------------------------------------------- --- Torrent identifiers ------------------------------------------------------------------------} - -class TorrentSource s where - openHandle :: FilePath -> s -> BitTorrent Handle - -instance TorrentSource InfoHash where - openHandle path ih = openMagnet path (nullMagnet ih) - {-# INLINE openHandle #-} - -instance TorrentSource Magnet where - openHandle = openMagnet - {-# INLINE openHandle #-} - -instance TorrentSource InfoDict where - openHandle path dict = openTorrent path (nullTorrent dict) - {-# INLINE openHandle #-} - -instance TorrentSource Torrent where - openHandle = openTorrent - {-# INLINE openHandle #-} - -instance TorrentSource FilePath where - openHandle contentDir torrentPath = do - t <- liftIO $ fromFile torrentPath - openTorrent contentDir t - {-# INLINE openHandle #-} - -getIndex :: BitTorrent [Handle] -getIndex = do - Client {..} <- getClient - elems <$> liftIO (readMVar clientTorrents) diff --git a/bittorrent/src/Network/BitTorrent/Client/Handle.hs b/bittorrent/src/Network/BitTorrent/Client/Handle.hs deleted file mode 100644 index 66baac48..00000000 --- a/bittorrent/src/Network/BitTorrent/Client/Handle.hs +++ /dev/null @@ -1,188 +0,0 @@ -module Network.BitTorrent.Client.Handle - ( -- * Handle - Handle - - -- * Initialization - , openTorrent - , openMagnet - , closeHandle - - -- * Control - , start - , pause - , stop - - -- * Query - , getHandle - , getStatus - ) where - -import Control.Concurrent.Chan.Split -import Control.Concurrent.Lifted as L -import Control.Monad -import Control.Monad.Trans -import Data.Default -import Data.List as L -import Data.HashMap.Strict as HM - -import Data.Torrent -import Network.BitTorrent.Client.Types as Types -import Network.BitTorrent.DHT as DHT -import Network.BitTorrent.Exchange as Exchange -import Network.BitTorrent.Tracker as Tracker - -{----------------------------------------------------------------------- --- Safe handle set manupulation ------------------------------------------------------------------------} - -allocHandle :: InfoHash -> BitTorrent Handle -> BitTorrent Handle -allocHandle ih m = do - Client {..} <- getClient - - (h, added) <- modifyMVar clientTorrents $ \ handles -> do - case HM.lookup ih handles of - Just h -> return (handles, (h, False)) - Nothing -> do - h <- m - return (HM.insert ih h handles, (h, True)) - - when added $ do - liftIO $ send clientEvents (TorrentAdded ih) - - return h - -freeHandle :: InfoHash -> BitTorrent () -> BitTorrent () -freeHandle ih finalizer = do - Client {..} <- getClient - - modifyMVar_ clientTorrents $ \ handles -> do - case HM.lookup ih handles of - Nothing -> return handles - Just _ -> do - finalizer - return (HM.delete ih handles) - -lookupHandle :: InfoHash -> BitTorrent (Maybe Handle) -lookupHandle ih = do - Client {..} <- getClient - handles <- readMVar clientTorrents - return (HM.lookup ih handles) - -{----------------------------------------------------------------------- --- Initialization ------------------------------------------------------------------------} - -newExchangeSession :: FilePath -> Either InfoHash InfoDict -> BitTorrent Exchange.Session -newExchangeSession rootPath source = do - c @ Client {..} <- getClient - liftIO $ Exchange.newSession clientLogger (externalAddr c) rootPath source - --- | Open a torrent in 'stop'ed state. Use 'nullTorrent' to open --- handle from 'InfoDict'. This operation do not block. -openTorrent :: FilePath -> Torrent -> BitTorrent Handle -openTorrent rootPath t @ Torrent {..} = do - let ih = idInfoHash tInfoDict - allocHandle ih $ do - statusVar <- newMVar Types.Stopped - tses <- liftIO $ Tracker.newSession ih (trackerList t) - eses <- newExchangeSession rootPath (Right tInfoDict) - eventStream <- liftIO newSendPort - return $ Handle - { handleTopic = ih - , handlePrivate = idPrivate tInfoDict - , handleStatus = statusVar - , handleTrackers = tses - , handleExchange = eses - , handleEvents = eventStream - } - --- | Use 'nullMagnet' to open handle from 'InfoHash'. -openMagnet :: FilePath -> Magnet -> BitTorrent Handle -openMagnet rootPath Magnet {..} = do - allocHandle exactTopic $ do - statusVar <- newMVar Types.Stopped - tses <- liftIO $ Tracker.newSession exactTopic def - eses <- newExchangeSession rootPath (Left exactTopic) - eventStream <- liftIO newSendPort - return $ Handle - { handleTopic = exactTopic - , handlePrivate = False - , handleStatus = statusVar - , handleTrackers = tses - , handleExchange = eses - , handleEvents = eventStream - } - --- | Stop torrent and destroy all sessions. You don't need to close --- handles at application exit, all handles will be automatically --- closed at 'Network.BitTorrent.Client.closeClient'. This operation --- may block. -closeHandle :: Handle -> BitTorrent () -closeHandle h @ Handle {..} = do - freeHandle handleTopic $ do - Client {..} <- getClient - stop h - liftIO $ Exchange.closeSession handleExchange - liftIO $ Tracker.closeSession trackerManager handleTrackers - -{----------------------------------------------------------------------- --- Control ------------------------------------------------------------------------} - -modifyStatus :: HandleStatus -> Handle -> (HandleStatus -> BitTorrent ()) -> BitTorrent () -modifyStatus targetStatus Handle {..} targetAction = do - modifyMVar_ handleStatus $ \ actualStatus -> do - unless (actualStatus == targetStatus) $ do - targetAction actualStatus - return targetStatus - liftIO $ send handleEvents (StatusChanged targetStatus) - --- | Start downloading, uploading and announcing this torrent. --- --- This operation is blocking, use --- 'Control.Concurrent.Async.Lifted.async' if needed. -start :: Handle -> BitTorrent () -start h @ Handle {..} = do - modifyStatus Types.Running h $ \ status -> do - case status of - Types.Running -> return () - Types.Stopped -> do - Client {..} <- getClient - liftIO $ Tracker.notify trackerManager handleTrackers Tracker.Started - unless handlePrivate $ do - liftDHT $ DHT.insert handleTopic (error "start") - liftIO $ do - peers <- askPeers trackerManager handleTrackers - print $ "got: " ++ show (L.length peers) ++ " peers" - forM_ peers $ \ peer -> do - Exchange.connect peer handleExchange - --- | Stop downloading this torrent. -pause :: Handle -> BitTorrent () -pause _ = return () - --- | Stop downloading, uploading and announcing this torrent. -stop :: Handle -> BitTorrent () -stop h @ Handle {..} = do - modifyStatus Types.Stopped h $ \ status -> do - case status of - Types.Stopped -> return () - Types.Running -> do - Client {..} <- getClient - unless handlePrivate $ do - liftDHT $ DHT.delete handleTopic (error "stop") - liftIO $ Tracker.notify trackerManager handleTrackers Tracker.Stopped - -{----------------------------------------------------------------------- --- Query ------------------------------------------------------------------------} - -getHandle :: InfoHash -> BitTorrent Handle -getHandle ih = do - mhandle <- lookupHandle ih - case mhandle of - Nothing -> error "should we throw some exception?" - Just h -> return h - -getStatus :: Handle -> IO HandleStatus -getStatus Handle {..} = readMVar handleStatus diff --git a/bittorrent/src/Network/BitTorrent/Client/Types.hs b/bittorrent/src/Network/BitTorrent/Client/Types.hs deleted file mode 100644 index e2ad858f..00000000 --- a/bittorrent/src/Network/BitTorrent/Client/Types.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Network.BitTorrent.Client.Types - ( -- * Core types - HandleStatus (..) - , Handle (..) - , Client (..) - , externalAddr - - -- * Monad BitTorrent - , BitTorrent (..) - , runBitTorrent - , getClient - - , MonadBitTorrent (..) - - -- * Events - , Types.Event (..) - ) where - -import Control.Applicative -import Control.Concurrent -import Control.Concurrent.Chan.Split as CS -import Control.Monad.Base -import Control.Monad.Logger -import Control.Monad.Reader -import Control.Monad.Trans.Control -import Control.Monad.Trans.Resource -import Data.Function -import Data.HashMap.Strict as HM -import Data.Ord -import Network -import System.Log.FastLogger - -import Data.Torrent -import Network.Address -import Network.BitTorrent.Internal.Types as Types -import Network.BitTorrent.DHT as DHT -import Network.BitTorrent.Exchange as Exchange -import Network.BitTorrent.Tracker as Tracker hiding (Event) - -data HandleStatus - = Running - | Stopped - deriving (Show, Eq) - -data Handle = Handle - { handleTopic :: !InfoHash - , handlePrivate :: !Bool - - , handleStatus :: !(MVar HandleStatus) - , handleTrackers :: !Tracker.Session - , handleExchange :: !Exchange.Session - , handleEvents :: !(SendPort (Event Handle)) - } - -instance EventSource Handle where - data Event Handle = StatusChanged HandleStatus - listen Handle {..} = CS.listen undefined - -data Client = Client - { clientPeerId :: !PeerId - , clientListenerPort :: !PortNumber - , allowedExtensions :: !Caps - , clientResources :: !InternalState - , trackerManager :: !Tracker.Manager - , exchangeManager :: !Exchange.Manager - , clientNode :: !(Node IPv4) - , clientTorrents :: !(MVar (HashMap InfoHash Handle)) - , clientLogger :: !LogFun - , clientEvents :: !(SendPort (Event Client)) - } - -instance Eq Client where - (==) = (==) `on` clientPeerId - -instance Ord Client where - compare = comparing clientPeerId - -instance EventSource Client where - data Event Client = TorrentAdded InfoHash - listen Client {..} = CS.listen clientEvents - --- | External IP address of a host running a bittorrent client --- software may be used to acknowledge remote peer the host connected --- to. See 'Network.BitTorrent.Exchange.Message.ExtendedHandshake'. -externalAddr :: Client -> PeerAddr (Maybe IP) -externalAddr Client {..} = PeerAddr - { peerId = Just clientPeerId - , peerHost = Nothing -- TODO return external IP address, if known - , peerPort = clientListenerPort - } - -{----------------------------------------------------------------------- --- BitTorrent monad ------------------------------------------------------------------------} - -newtype BitTorrent a = BitTorrent - { unBitTorrent :: ReaderT Client IO a - } deriving ( Functor, Applicative, Monad - , MonadIO, MonadThrow, MonadBase IO - ) - -class MonadBitTorrent m where - liftBT :: BitTorrent a -> m a - -#if MIN_VERSION_monad_control(1,0,0) -newtype BTStM a = BTStM { unBTSt :: StM (ReaderT Client IO) a } - -instance MonadBaseControl IO BitTorrent where - type StM BitTorrent a = BTStM a - liftBaseWith cc = BitTorrent $ liftBaseWith $ \ cc' -> - cc $ \ (BitTorrent m) -> BTStM <$> cc' m - {-# INLINE liftBaseWith #-} - - restoreM = BitTorrent . restoreM . unBTSt - {-# INLINE restoreM #-} -#else -instance MonadBaseControl IO BitTorrent where - newtype StM BitTorrent a = StM { unSt :: StM (ReaderT Client IO) a } - liftBaseWith cc = BitTorrent $ liftBaseWith $ \ cc' -> - cc $ \ (BitTorrent m) -> StM <$> cc' m - {-# INLINE liftBaseWith #-} - - restoreM = BitTorrent . restoreM . unSt - {-# INLINE restoreM #-} -#endif - --- | NOP. -instance MonadBitTorrent BitTorrent where - liftBT = id - -instance MonadTrans t => MonadBitTorrent (t BitTorrent) where - liftBT = lift - --- | Registered but not closed manually resources will be --- automatically closed at 'Network.BitTorrent.Client.closeClient' -instance MonadResource BitTorrent where - liftResourceT m = BitTorrent $ do - s <- asks clientResources - liftIO $ runInternalState m s - --- | Run DHT operation, only if the client node is running. -instance MonadDHT BitTorrent where - liftDHT action = BitTorrent $ do - node <- asks clientNode - liftIO $ runDHT node action - -instance MonadLogger BitTorrent where - monadLoggerLog loc src lvl msg = BitTorrent $ do - logger <- asks clientLogger - liftIO $ logger loc src lvl (toLogStr msg) - -runBitTorrent :: Client -> BitTorrent a -> IO a -runBitTorrent client action = runReaderT (unBitTorrent action) client -{-# INLINE runBitTorrent #-} - -getClient :: BitTorrent Client -getClient = BitTorrent ask -{-# INLINE getClient #-} diff --git a/bittorrent/src/Network/BitTorrent/Exchange.hs b/bittorrent/src/Network/BitTorrent/Exchange.hs deleted file mode 100644 index 143bf090..00000000 --- a/bittorrent/src/Network/BitTorrent/Exchange.hs +++ /dev/null @@ -1,35 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- -module Network.BitTorrent.Exchange - ( -- * Manager - Options (..) - , Manager - , Handler - , newManager - , closeManager - - -- * Session - , Caps - , Extension - , toCaps - , Session - , newSession - , closeSession - - -- * Query - , waitMetadata - , takeMetadata - - -- * Connections - , connect - , connectSink - ) where - -import Network.BitTorrent.Exchange.Manager -import Network.BitTorrent.Exchange.Message -import Network.BitTorrent.Exchange.Session diff --git a/bittorrent/src/Network/BitTorrent/Exchange/Bitfield.hs b/bittorrent/src/Network/BitTorrent/Exchange/Bitfield.hs deleted file mode 100644 index 1be9f970..00000000 --- a/bittorrent/src/Network/BitTorrent/Exchange/Bitfield.hs +++ /dev/null @@ -1,405 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- This modules provides all necessary machinery to work with --- bitfields. Bitfields are used to keep track indices of complete --- pieces either this peer have or remote peer have. --- --- There are also commonly used piece selection algorithms --- which used to find out which one next piece to download. --- Selectors considered to be used in the following order: --- --- * 'randomFirst' - at the start of download. --- --- * 'rarestFirst' - performed to avoid situation when --- rarest piece is unaccessible. --- --- * 'endGame' - performed after a peer has requested all --- the subpieces of the content. --- --- Note that BitTorrent protocol recommend (TODO link?) the --- 'strictFirst' priority policy for /subpiece/ or /blocks/ --- selection. --- -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RecordWildCards #-} -module Network.BitTorrent.Exchange.Bitfield - ( -- * Bitfield - PieceIx - , PieceCount - , Bitfield - - -- * Construction - , haveAll - , haveNone - , have - , singleton - , interval - , adjustSize - - -- * Query - -- ** Cardinality - , Network.BitTorrent.Exchange.Bitfield.null - , Network.BitTorrent.Exchange.Bitfield.full - , haveCount - , totalCount - , completeness - - -- ** Membership - , member - , notMember - , findMin - , findMax - , isSubsetOf - - -- ** Availability - , complement - , Frequency - , frequencies - , rarest - - -- * Combine - , insert - , union - , intersection - , difference - - -- * Conversion - , toList - , fromList - - -- * Serialization - , fromBitmap - , toBitmap - - -- * Piece selection - , Selector - , selector - , strategyClass - - , strictFirst - , strictLast - , rarestFirst - , randomFirst - , endGame - ) where - -import Control.Monad -import Control.Monad.ST -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as Lazy -import Data.Vector.Unboxed (Vector) -import qualified Data.Vector.Unboxed as V -import qualified Data.Vector.Unboxed.Mutable as VM -import Data.IntervalSet (IntSet) -import qualified Data.IntervalSet as S -import qualified Data.IntervalSet.ByteString as S -import Data.List (foldl') -import Data.Monoid -import Data.Ratio - -import Data.Torrent - --- TODO cache some operations - --- | Bitfields are represented just as integer sets but with a restriction: --- each integer in the set should be within the given interval. The greatest --- lower bound of the interval must be zero, so intervals may be specified by --- providing a maximum set size. For example, a bitfield of size 10 might --- contain only indices in interval [0..9]. --- --- By convention, we use the following aliases for Int: --- --- [ PieceIx ] an Int member of the Bitfield. --- --- [ PieceCount ] maximum set size for a Bitfield. -data Bitfield = Bitfield { - bfSize :: !PieceCount - , bfSet :: !IntSet - } deriving (Show, Read, Eq) - --- Invariants: all elements of bfSet lie in [0..bfSize - 1]; - -instance Monoid Bitfield where - {-# SPECIALIZE instance Monoid Bitfield #-} - mempty = haveNone 0 - mappend = union - mconcat = unions - -{----------------------------------------------------------------------- - Construction ------------------------------------------------------------------------} - --- | The empty bitfield of the given size. -haveNone :: PieceCount -> Bitfield -haveNone s = Bitfield s S.empty - --- | The full bitfield containing all piece indices for the given size. -haveAll :: PieceCount -> Bitfield -haveAll s = Bitfield s (S.interval 0 (s - 1)) - --- | Insert the index in the set ignoring out of range indices. -have :: PieceIx -> Bitfield -> Bitfield -have ix Bitfield {..} - | 0 <= ix && ix < bfSize = Bitfield bfSize (S.insert ix bfSet) - | otherwise = Bitfield bfSize bfSet - -singleton :: PieceIx -> PieceCount -> Bitfield -singleton ix pc = have ix (haveNone pc) - --- | Assign new size to bitfield. FIXME Normally, size should be only --- decreased, otherwise exception raised. -adjustSize :: PieceCount -> Bitfield -> Bitfield -adjustSize s Bitfield {..} = Bitfield s bfSet - --- | NOTE: for internal use only -interval :: PieceCount -> PieceIx -> PieceIx -> Bitfield -interval pc a b = Bitfield pc (S.interval a b) - -{----------------------------------------------------------------------- - Query ------------------------------------------------------------------------} - --- | Test if bitifield have no one index: peer do not have anything. -null :: Bitfield -> Bool -null Bitfield {..} = S.null bfSet - --- | Test if bitfield have all pieces. -full :: Bitfield -> Bool -full Bitfield {..} = S.size bfSet == bfSize - --- | Count of peer have pieces. -haveCount :: Bitfield -> PieceCount -haveCount = S.size . bfSet - --- | Total count of pieces and its indices. -totalCount :: Bitfield -> PieceCount -totalCount = bfSize - --- | Ratio of /have/ piece count to the /total/ piece count. --- --- > forall bf. 0 <= completeness bf <= 1 --- -completeness :: Bitfield -> Ratio PieceCount -completeness b = haveCount b % totalCount b - -inRange :: PieceIx -> Bitfield -> Bool -inRange ix Bitfield {..} = 0 <= ix && ix < bfSize - -member :: PieceIx -> Bitfield -> Bool -member ix bf @ Bitfield {..} - | ix `inRange` bf = ix `S.member` bfSet - | otherwise = False - -notMember :: PieceIx -> Bitfield -> Bool -notMember ix bf @ Bitfield {..} - | ix `inRange` bf = ix `S.notMember` bfSet - | otherwise = True - --- | Find first available piece index. -findMin :: Bitfield -> PieceIx -findMin = S.findMin . bfSet -{-# INLINE findMin #-} - --- | Find last available piece index. -findMax :: Bitfield -> PieceIx -findMax = S.findMax . bfSet -{-# INLINE findMax #-} - --- | Check if all pieces from first bitfield present if the second bitfield -isSubsetOf :: Bitfield -> Bitfield -> Bool -isSubsetOf a b = bfSet a `S.isSubsetOf` bfSet b -{-# INLINE isSubsetOf #-} - --- | Resulting bitfield includes only missing pieces. -complement :: Bitfield -> Bitfield -complement Bitfield {..} = Bitfield - { bfSet = uni `S.difference` bfSet - , bfSize = bfSize - } - where - Bitfield _ uni = haveAll bfSize -{-# INLINE complement #-} - -{----------------------------------------------------------------------- --- Availability ------------------------------------------------------------------------} - --- | Frequencies are needed in piece selection startegies which use --- availability quantity to find out the optimal next piece index to --- download. -type Frequency = Int - --- TODO rename to availability --- | How many times each piece index occur in the given bitfield set. -frequencies :: [Bitfield] -> Vector Frequency -frequencies [] = V.fromList [] -frequencies xs = runST $ do - v <- VM.new size - VM.set v 0 - forM_ xs $ \ Bitfield {..} -> do - forM_ (S.toList bfSet) $ \ x -> do - fr <- VM.read v x - VM.write v x (succ fr) - V.unsafeFreeze v - where - size = maximum (map bfSize xs) - --- TODO it seems like this operation is veeery slow - --- | Find least available piece index. If no piece available return --- 'Nothing'. -rarest :: [Bitfield] -> Maybe PieceIx -rarest xs - | V.null freqMap = Nothing - | otherwise - = Just $ fst $ V.ifoldr' minIx (0, freqMap V.! 0) freqMap - where - freqMap = frequencies xs - {-# NOINLINE freqMap #-} - - minIx :: PieceIx -> Frequency - -> (PieceIx, Frequency) - -> (PieceIx, Frequency) - minIx ix fr acc@(_, fra) - | fr < fra && fr > 0 = (ix, fr) - | otherwise = acc - - -{----------------------------------------------------------------------- - Combine ------------------------------------------------------------------------} - -insert :: PieceIx -> Bitfield -> Bitfield -insert pix bf @ Bitfield {..} - | 0 <= pix && pix < bfSize = Bitfield - { bfSet = S.insert pix bfSet - , bfSize = bfSize - } - | otherwise = bf - --- | Find indices at least one peer have. -union :: Bitfield -> Bitfield -> Bitfield -union a b = {-# SCC union #-} Bitfield { - bfSize = bfSize a `max` bfSize b - , bfSet = bfSet a `S.union` bfSet b - } - --- | Find indices both peers have. -intersection :: Bitfield -> Bitfield -> Bitfield -intersection a b = {-# SCC intersection #-} Bitfield { - bfSize = bfSize a `min` bfSize b - , bfSet = bfSet a `S.intersection` bfSet b - } - --- | Find indices which have first peer but do not have the second peer. -difference :: Bitfield -> Bitfield -> Bitfield -difference a b = {-# SCC difference #-} Bitfield { - bfSize = bfSize a -- FIXME is it reasonable? - , bfSet = bfSet a `S.difference` bfSet b - } - --- | Find indices the any of the peers have. -unions :: [Bitfield] -> Bitfield -unions = {-# SCC unions #-} foldl' union (haveNone 0) - -{----------------------------------------------------------------------- - Serialization ------------------------------------------------------------------------} - --- | List all /have/ indexes. -toList :: Bitfield -> [PieceIx] -toList Bitfield {..} = S.toList bfSet - --- | Make bitfield from list of /have/ indexes. -fromList :: PieceCount -> [PieceIx] -> Bitfield -fromList s ixs = Bitfield { - bfSize = s - , bfSet = S.splitGT (-1) $ S.splitLT s $ S.fromList ixs - } - --- | Unpack 'Bitfield' from tightly packed bit array. Note resulting --- size might be more than real bitfield size, use 'adjustSize'. -fromBitmap :: ByteString -> Bitfield -fromBitmap bs = {-# SCC fromBitmap #-} Bitfield { - bfSize = B.length bs * 8 - , bfSet = S.fromByteString bs - } -{-# INLINE fromBitmap #-} - --- | Pack a 'Bitfield' to tightly packed bit array. -toBitmap :: Bitfield -> Lazy.ByteString -toBitmap Bitfield {..} = {-# SCC toBitmap #-} Lazy.fromChunks [intsetBM, alignment] - where - byteSize = bfSize `div` 8 + if bfSize `mod` 8 == 0 then 0 else 1 - alignment = B.replicate (byteSize - B.length intsetBM) 0 - intsetBM = S.toByteString bfSet - -{----------------------------------------------------------------------- --- Piece selection ------------------------------------------------------------------------} - -type Selector = Bitfield -- ^ Indices of client /have/ pieces. - -> Bitfield -- ^ Indices of peer /have/ pieces. - -> [Bitfield] -- ^ Indices of other peers /have/ pieces. - -> Maybe PieceIx -- ^ Zero-based index of piece to request - -- to, if any. - -selector :: Selector -- ^ Selector to use at the start. - -> Ratio PieceCount - -> Selector -- ^ Selector to use after the client have - -- the C pieces. - -> Selector -- ^ Selector that changes behaviour based - -- on completeness. -selector start pt ready h a xs = - case strategyClass pt h of - SCBeginning -> start h a xs - SCReady -> ready h a xs - SCEnd -> endGame h a xs - -data StartegyClass - = SCBeginning - | SCReady - | SCEnd - deriving (Show, Eq, Ord, Enum, Bounded) - - -strategyClass :: Ratio PieceCount -> Bitfield -> StartegyClass -strategyClass threshold = classify . completeness - where - classify c - | c < threshold = SCBeginning - | c + 1 % numerator c < 1 = SCReady - -- FIXME numerator have is not total count - | otherwise = SCEnd - - --- | Select the first available piece. -strictFirst :: Selector -strictFirst h a _ = Just $ findMin (difference a h) - --- | Select the last available piece. -strictLast :: Selector -strictLast h a _ = Just $ findMax (difference a h) - --- | -rarestFirst :: Selector -rarestFirst h a xs = rarest (map (intersection want) xs) - where - want = difference h a - --- | In average random first is faster than rarest first strategy but --- only if all pieces are available. -randomFirst :: Selector -randomFirst = do --- randomIO - error "TODO: randomFirst" - -endGame :: Selector -endGame = strictLast diff --git a/bittorrent/src/Network/BitTorrent/Exchange/Block.hs b/bittorrent/src/Network/BitTorrent/Exchange/Block.hs deleted file mode 100644 index bc9a3d24..00000000 --- a/bittorrent/src/Network/BitTorrent/Exchange/Block.hs +++ /dev/null @@ -1,369 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- Blocks are used to transfer pieces. --- -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Network.BitTorrent.Exchange.Block - ( -- * Block attributes - BlockOffset - , BlockCount - , BlockSize - , defaultTransferSize - - -- * Block index - , BlockIx(..) - , blockIxRange - - -- * Block data - , Block(..) - , blockIx - , blockSize - , blockRange - , isPiece - , leadingBlock - - -- * Block bucket - , Bucket - - -- ** Query - , Network.BitTorrent.Exchange.Block.null - , Network.BitTorrent.Exchange.Block.full - , Network.BitTorrent.Exchange.Block.size - , Network.BitTorrent.Exchange.Block.spans - - -- ** Construction - , Network.BitTorrent.Exchange.Block.empty - , Network.BitTorrent.Exchange.Block.insert - , Network.BitTorrent.Exchange.Block.insertLazy - , Network.BitTorrent.Exchange.Block.merge - , Network.BitTorrent.Exchange.Block.fromList - - -- ** Rendering - , Network.BitTorrent.Exchange.Block.toPiece - - -- ** Debug - , Network.BitTorrent.Exchange.Block.valid - ) where - -import Prelude hiding (span) -import Control.Applicative -import Data.ByteString as BS hiding (span) -import Data.ByteString.Lazy as BL hiding (span) -import Data.ByteString.Lazy.Builder as BS -import Data.Default -import Data.Monoid -import Data.List as L hiding (span) -import Data.Serialize as S -import Data.Typeable -import Numeric -import Text.PrettyPrint as PP hiding ((<>)) -import Text.PrettyPrint.HughesPJClass hiding ((<>),($$)) - -import Data.Torrent - -{----------------------------------------------------------------------- --- Block attributes ------------------------------------------------------------------------} - --- | Offset of a block in a piece in bytes. Should be multiple of --- the choosen block size. -type BlockOffset = Int - --- | Size of a block in bytes. Should be power of 2. --- --- Normally block size is equal to 'defaultTransferSize'. --- -type BlockSize = Int - --- | Number of block in a piece of a torrent. Used to distinguish --- block count from piece count. -type BlockCount = Int - --- | Widely used semi-official block size. Some clients can ignore if --- block size of BlockIx in Request message is not equal to this --- value. --- -defaultTransferSize :: BlockSize -defaultTransferSize = 16 * 1024 - -{----------------------------------------------------------------------- - Block Index ------------------------------------------------------------------------} - --- | BlockIx correspond. -data BlockIx = BlockIx { - -- | Zero-based piece index. - ixPiece :: {-# UNPACK #-} !PieceIx - - -- | Zero-based byte offset within the piece. - , ixOffset :: {-# UNPACK #-} !BlockOffset - - -- | Block size starting from offset. - , ixLength :: {-# UNPACK #-} !BlockSize - } deriving (Show, Eq, Typeable) - --- | First block in torrent. Useful for debugging. -instance Default BlockIx where - def = BlockIx 0 0 defaultTransferSize - -getInt :: S.Get Int -getInt = fromIntegral <$> S.getWord32be -{-# INLINE getInt #-} - -putInt :: S.Putter Int -putInt = S.putWord32be . fromIntegral -{-# INLINE putInt #-} - -instance Serialize BlockIx where - {-# SPECIALIZE instance Serialize BlockIx #-} - get = BlockIx <$> getInt - <*> getInt - <*> getInt - {-# INLINE get #-} - - put BlockIx {..} = do - putInt ixPiece - putInt ixOffset - putInt ixLength - {-# INLINE put #-} - -instance Pretty BlockIx where - pPrint BlockIx {..} = - ("piece = " <> int ixPiece <> ",") <+> - ("offset = " <> int ixOffset <> ",") <+> - ("length = " <> int ixLength) - --- | Get location of payload bytes in the torrent content. -blockIxRange :: (Num a, Integral a) => PieceSize -> BlockIx -> (a, a) -blockIxRange piSize BlockIx {..} = (offset, offset + len) - where - offset = fromIntegral piSize * fromIntegral ixPiece - + fromIntegral ixOffset - len = fromIntegral ixLength -{-# INLINE blockIxRange #-} - -{----------------------------------------------------------------------- - Block ------------------------------------------------------------------------} - -data Block payload = Block { - -- | Zero-based piece index. - blkPiece :: {-# UNPACK #-} !PieceIx - - -- | Zero-based byte offset within the piece. - , blkOffset :: {-# UNPACK #-} !BlockOffset - - -- | Payload bytes. - , blkData :: !payload - } deriving (Show, Eq, Functor, Typeable) - --- | Payload is ommitted. -instance Pretty (Block BL.ByteString) where - pPrint = pPrint . blockIx - {-# INLINE pPrint #-} - --- | Get size of block /payload/ in bytes. -blockSize :: Block BL.ByteString -> BlockSize -blockSize = fromIntegral . BL.length . blkData -{-# INLINE blockSize #-} - --- | Get block index of a block. -blockIx :: Block BL.ByteString -> BlockIx -blockIx = BlockIx <$> blkPiece <*> blkOffset <*> blockSize - --- | Get location of payload bytes in the torrent content. -blockRange :: (Num a, Integral a) - => PieceSize -> Block BL.ByteString -> (a, a) -blockRange piSize = blockIxRange piSize . blockIx -{-# INLINE blockRange #-} - --- | Test if a block can be safely turned into a piece. -isPiece :: PieceSize -> Block BL.ByteString -> Bool -isPiece pieceLen blk @ (Block i offset _) = - offset == 0 && blockSize blk == pieceLen && i >= 0 -{-# INLINE isPiece #-} - --- | First block in the piece. -leadingBlock :: PieceIx -> BlockSize -> BlockIx -leadingBlock pix blockSize = BlockIx - { ixPiece = pix - , ixOffset = 0 - , ixLength = blockSize - } -{-# INLINE leadingBlock #-} - -{----------------------------------------------------------------------- --- Bucket ------------------------------------------------------------------------} - -type Pos = Int -type ChunkSize = Int - --- | A sparse set of blocks used to represent an /in progress/ piece. -data Bucket - = Nil - | Span {-# UNPACK #-} !ChunkSize !Bucket - | Fill {-# UNPACK #-} !ChunkSize !Builder !Bucket - -instance Show Bucket where - showsPrec i Nil = showString "" - showsPrec i (Span s xs) = showString "Span " <> showInt s - <> showString " " <> showsPrec i xs - showsPrec i (Fill s _ xs) = showString "Fill " <> showInt s - <> showString " " <> showsPrec i xs - --- | INVARIANT: 'Nil' should appear only after 'Span' of 'Fill'. -nilInvFailed :: a -nilInvFailed = error "Nil: bucket invariant failed" - -valid :: Bucket -> Bool -valid = check Nothing - where - check Nothing Nil = False -- see 'nilInvFailed' - check (Just _) _ = True - check prevIsSpan (Span sz xs) = - prevIsSpan /= Just True && -- Span n (NotSpan .. ) invariant - sz > 0 && -- Span is always non-empty - check (Just True) xs - check prevIsSpan (Fill sz b xs) = - prevIsSpan /= Just True && -- Fill n (NotFill .. ) invariant - sz > 0 && -- Fill is always non-empty - check (Just False) xs - -instance Pretty Bucket where - pPrint Nil = nilInvFailed - pPrint bkt = go bkt - where - go Nil = PP.empty - go (Span sz xs) = "Span" <+> PP.int sz <+> go xs - go (Fill sz b xs) = "Fill" <+> PP.int sz <+> go xs - --- | Smart constructor: use it when some block is /deleted/ from --- bucket. -span :: ChunkSize -> Bucket -> Bucket -span sz (Span sz' xs) = Span (sz + sz') xs -span sz xxs = Span sz xxs -{-# INLINE span #-} - --- | Smart constructor: use it when some block is /inserted/ to --- bucket. -fill :: ChunkSize -> Builder -> Bucket -> Bucket -fill sz b (Fill sz' b' xs) = Fill (sz + sz') (b <> b') xs -fill sz b xxs = Fill sz b xxs -{-# INLINE fill #-} - -{----------------------------------------------------------------------- --- Bucket queries ------------------------------------------------------------------------} - --- | /O(1)/. Test if this bucket is empty. -null :: Bucket -> Bool -null Nil = nilInvFailed -null (Span _ Nil) = True -null _ = False -{-# INLINE null #-} - --- | /O(1)/. Test if this bucket is complete. -full :: Bucket -> Bool -full Nil = nilInvFailed -full (Fill _ _ Nil) = True -full _ = False -{-# INLINE full #-} - --- | /O(n)/. Total size of the incompleted piece. -size :: Bucket -> PieceSize -size Nil = nilInvFailed -size bkt = go bkt - where - go Nil = 0 - go (Span sz xs) = sz + go xs - go (Fill sz _ xs) = sz + go xs - --- | /O(n)/. List incomplete blocks to download. If some block have --- size more than the specified 'BlockSize' then block is split into --- smaller blocks to satisfy given 'BlockSize'. Small (for --- e.g. trailing) blocks is not ignored, but returned in-order. -spans :: BlockSize -> Bucket -> [(BlockOffset, BlockSize)] -spans expectedSize = go 0 - where - go _ Nil = [] - go off (Span sz xs) = listChunks off sz ++ go (off + sz) xs - go off (Fill sz _ xs) = go (off + sz) xs - - listChunks off restSize - | restSize <= 0 = [] - | otherwise = (off, blkSize) - : listChunks (off + blkSize) (restSize - blkSize) - where - blkSize = min expectedSize restSize - -{----------------------------------------------------------------------- --- Bucket contstruction ------------------------------------------------------------------------} - --- | /O(1)/. A new empty bucket capable to alloof specified size. -empty :: PieceSize -> Bucket -empty sz - | sz < 0 = error "empty: Bucket size must be a non-negative value" - | otherwise = Span sz Nil -{-# INLINE empty #-} - -insertSpan :: Pos -> BS.ByteString -> ChunkSize -> Bucket -> Bucket -insertSpan !pos !bs !span_sz !xs = - let pref_len = pos - fill_len = span_sz - pos `min` BS.length bs - suff_len = (span_sz - pos) - fill_len - in mkSpan pref_len $ - fill fill_len (byteString (BS.take fill_len bs)) $ - mkSpan suff_len $ - xs - where - mkSpan 0 xs = xs - mkSpan sz xs = Span sz xs - --- | /O(n)/. Insert a strict bytestring at specified position. --- --- Best case: if blocks are inserted in sequential order, then this --- operation should take /O(1)/. --- -insert :: Pos -> BS.ByteString -> Bucket -> Bucket -insert _ _ Nil = nilInvFailed -insert dstPos bs bucket = go 0 bucket - where - intersects curPos sz = dstPos >= curPos && dstPos <= curPos + sz - - go _ Nil = Nil - go curPos (Span sz xs) - | intersects curPos sz = insertSpan (dstPos - curPos) bs sz xs - | otherwise = span sz (go (curPos + sz) xs) - go curPos bkt @ (Fill sz br xs) - | intersects curPos sz = bkt - | otherwise = fill sz br (go (curPos + sz) xs) - -fromList :: PieceSize -> [(Pos, BS.ByteString)] -> Bucket -fromList s = L.foldr (uncurry Network.BitTorrent.Exchange.Block.insert) - (Network.BitTorrent.Exchange.Block.empty s) - --- TODO zero-copy -insertLazy :: Pos -> BL.ByteString -> Bucket -> Bucket -insertLazy pos bl = Network.BitTorrent.Exchange.Block.insert pos (BL.toStrict bl) - --- | /O(n)/. -merge :: Bucket -> Bucket -> Bucket -merge = error "Bucket.merge: not implemented" - --- | /O(1)/. -toPiece :: Bucket -> Maybe BL.ByteString -toPiece Nil = nilInvFailed -toPiece (Fill _ b Nil) = Just (toLazyByteString b) -toPiece _ = Nothing diff --git a/bittorrent/src/Network/BitTorrent/Exchange/Connection.hs b/bittorrent/src/Network/BitTorrent/Exchange/Connection.hs deleted file mode 100644 index 6804d0a2..00000000 --- a/bittorrent/src/Network/BitTorrent/Exchange/Connection.hs +++ /dev/null @@ -1,1012 +0,0 @@ --- | --- Module : Network.BitTorrent.Exchange.Wire --- Copyright : (c) Sam Truzjan 2013 --- (c) Daniel Gröber 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- Each peer wire connection is identified by triple @(topic, --- remote_addr, this_addr)@. This means that connections are the --- same if and only if their 'ConnectionId' are the same. Of course, --- you /must/ avoid duplicated connections. --- --- This module control /integrity/ of data send and received. --- -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Network.BitTorrent.Exchange.Connection - ( -- * Wire - Connected - , Wire - , ChannelSide (..) - - -- * Connection - , Connection - , connInitiatedBy - - -- ** Identity - , connRemoteAddr - , connTopic - , connRemotePeerId - , connThisPeerId - - -- ** Capabilities - , connProtocol - , connCaps - , connExtCaps - , connRemoteEhs - - -- ** State - , connStatus - , connBitfield - - -- ** Env - , connOptions - , connSession - , connStats - - -- ** Status - , PeerStatus (..) - , ConnectionStatus (..) - , updateStatus - , statusUpdates - , clientStatus - , remoteStatus - , canUpload - , canDownload - , defaultUnchokeSlots - , defaultRechokeInterval - - - -- * Setup - , ConnectionPrefs (..) - , SessionLink (..) - , ConnectionConfig (..) - - -- ** Initiate - , connectWire - - -- ** Accept - , PendingConnection - , newPendingConnection - , pendingPeer - , pendingCaps - , pendingTopic - , closePending - , acceptWire - - -- ** Post setup actions - , resizeBitfield - - -- * Messaging - , recvMessage - , sendMessage - , filterQueue - , getMaxQueueLength - - -- * Exceptions - , ProtocolError (..) - , WireFailure (..) - , peerPenalty - , isWireFailure - , disconnectPeer - - -- * Stats - , ByteStats (..) - , FlowStats (..) - , ConnectionStats (..) - - -- * Flood detection - , FloodDetector (..) - - -- * Options - , Options (..) - ) where - -import Control.Applicative -import Control.Concurrent hiding (yield) -import Control.Exception -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Trans.Resource -import Control.Lens -import Data.ByteString as BS -import Data.ByteString.Lazy as BSL -import Data.Conduit as C -import Data.Conduit.Cereal -import Data.Conduit.List -import Data.Conduit.Network -import Data.Default -import Data.IORef -import Data.List as L -import Data.Maybe as M -import Data.Monoid -import Data.Serialize as S -import Data.Typeable -import Network -import Network.Socket hiding (Connected) -import Network.Socket.ByteString as BS -import Text.PrettyPrint as PP hiding ((<>)) -import Text.PrettyPrint.HughesPJClass hiding ((<>),($$)) -import Text.Show.Functions () -import System.Log.FastLogger (ToLogStr(..)) -import System.Timeout - -import Data.Torrent -import Network.Address -import Network.BitTorrent.Exchange.Bitfield as BF -import Network.BitTorrent.Exchange.Message as Msg - --- TODO handle port message? --- TODO handle limits? --- TODO filter not requested PIECE messages --- TODO metadata piece request flood protection --- TODO piece request flood protection --- TODO protect against flood attacks -{----------------------------------------------------------------------- --- Exceptions ------------------------------------------------------------------------} - --- | Used to specify initiator of 'ProtocolError'. -data ChannelSide - = ThisPeer - | RemotePeer - deriving (Show, Eq, Enum, Bounded) - -instance Default ChannelSide where - def = ThisPeer - -instance Pretty ChannelSide where - pPrint = PP.text . show - --- | A protocol errors occur when a peer violates protocol --- specification. -data ProtocolError - -- | Protocol string should be 'BitTorrent Protocol' but remote - -- peer have sent a different string. - = InvalidProtocol ProtocolName - - -- | Sent and received protocol strings do not match. Can occur - -- in 'connectWire' only. - | UnexpectedProtocol ProtocolName - - -- | /Remote/ peer replied with invalid 'hsInfoHash' which do not - -- match with 'hsInfoHash' /this/ peer have sent. Can occur in - -- 'connectWire' or 'acceptWire' only. - | UnexpectedTopic InfoHash - - -- | Some trackers or DHT can return 'PeerId' of a peer. If a - -- remote peer handshaked with different 'hsPeerId' then this - -- exception is raised. Can occur in 'connectWire' only. - | UnexpectedPeerId PeerId - - -- | Accepted peer have sent unknown torrent infohash in - -- 'hsInfoHash' field. This situation usually happen when /this/ - -- peer have deleted the requested torrent. The error can occur in - -- 'acceptWire' function only. - | UnknownTopic InfoHash - - -- | A remote peer have 'ExtExtended' enabled but did not send an - -- 'ExtendedHandshake' back. - | HandshakeRefused - - -- | 'Network.BitTorrent.Exchange.Message.Bitfield' message MUST - -- be send either once or zero times, but either this peer or - -- remote peer send a bitfield message the second time. - | BitfieldAlreadySent ChannelSide - - -- | Capabilities violation. For example this exception can occur - -- when a peer have sent 'Port' message but 'ExtDHT' is not - -- allowed in 'connCaps'. - | DisallowedMessage - { -- | Who sent invalid message. - violentSender :: ChannelSide - - -- | If the 'violentSender' reconnect with this extension - -- enabled then he can try to send this message. - , extensionRequired :: Extension - } - deriving Show - -instance Pretty ProtocolError where - pPrint = PP.text . show - -errorPenalty :: ProtocolError -> Int -errorPenalty (InvalidProtocol _) = 1 -errorPenalty (UnexpectedProtocol _) = 1 -errorPenalty (UnexpectedTopic _) = 1 -errorPenalty (UnexpectedPeerId _) = 1 -errorPenalty (UnknownTopic _) = 0 -errorPenalty (HandshakeRefused ) = 1 -errorPenalty (BitfieldAlreadySent _) = 1 -errorPenalty (DisallowedMessage _ _) = 1 - --- | Exceptions used to interrupt the current P2P session. -data WireFailure - = ConnectionRefused IOError - - -- | Force termination of wire connection. - -- - -- Normally you should throw only this exception from event loop - -- using 'disconnectPeer', other exceptions are thrown - -- automatically by functions from this module. - -- - | DisconnectPeer - - -- | A peer not responding and did not send a 'KeepAlive' message - -- for a specified period of time. - | PeerDisconnected - - -- | A remote peer have sent some unknown message we unable to - -- parse. - | DecodingError GetException - - -- | See 'ProtocolError' for more details. - | ProtocolError ProtocolError - - -- | A possible malicious peer have sent too many control messages - -- without making any progress. - | FloodDetected ConnectionStats - deriving (Show, Typeable) - -instance Exception WireFailure - -instance Pretty WireFailure where - pPrint = PP.text . show - --- TODO --- data Penalty = Ban | Penalty Int - -peerPenalty :: WireFailure -> Int -peerPenalty DisconnectPeer = 0 -peerPenalty PeerDisconnected = 0 -peerPenalty (DecodingError _) = 1 -peerPenalty (ProtocolError e) = errorPenalty e -peerPenalty (FloodDetected _) = 1 - --- | Do nothing with exception, used with 'handle' or 'try'. -isWireFailure :: Monad m => WireFailure -> m () -isWireFailure _ = return () - -protocolError :: MonadThrow m => ProtocolError -> m a -protocolError = monadThrow . ProtocolError - -{----------------------------------------------------------------------- --- Stats ------------------------------------------------------------------------} - --- | Message stats in one direction. -data FlowStats = FlowStats - { -- | Number of the messages sent or received. - messageCount :: {-# UNPACK #-} !Int - -- | Sum of byte sequences of all messages. - , messageBytes :: {-# UNPACK #-} !ByteStats - } deriving Show - -instance Pretty FlowStats where - pPrint FlowStats {..} = - PP.int messageCount <+> "messages" $+$ - pPrint messageBytes - --- | Zeroed stats. -instance Default FlowStats where - def = FlowStats 0 def - --- | Monoid under addition. -instance Monoid FlowStats where - mempty = def - mappend a b = FlowStats - { messageBytes = messageBytes a <> messageBytes b - , messageCount = messageCount a + messageCount b - } - --- | Find average length of byte sequences per message. -avgByteStats :: FlowStats -> ByteStats -avgByteStats (FlowStats n ByteStats {..}) = ByteStats - { overhead = overhead `quot` n - , control = control `quot` n - , payload = payload `quot` n - } - --- | Message stats in both directions. This data can be retrieved --- using 'getStats' function. --- --- Note that this stats is completely different from --- 'Data.Torrent.Progress.Progress': payload bytes not necessary --- equal to downloaded\/uploaded bytes since a peer can send a --- broken block. --- -data ConnectionStats = ConnectionStats - { -- | Received messages stats. - incomingFlow :: !FlowStats - -- | Sent messages stats. - , outcomingFlow :: !FlowStats - } deriving Show - -instance Pretty ConnectionStats where - pPrint ConnectionStats {..} = vcat - [ "Recv:" <+> pPrint incomingFlow - , "Sent:" <+> pPrint outcomingFlow - , "Both:" <+> pPrint (incomingFlow <> outcomingFlow) - ] - --- | Zeroed stats. -instance Default ConnectionStats where - def = ConnectionStats def def - --- | Monoid under addition. -instance Monoid ConnectionStats where - mempty = def - mappend a b = ConnectionStats - { incomingFlow = incomingFlow a <> incomingFlow b - , outcomingFlow = outcomingFlow a <> outcomingFlow b - } - --- | Aggregate one more message stats in the /specified/ direction. -addStats :: ChannelSide -> ByteStats -> ConnectionStats -> ConnectionStats -addStats ThisPeer x s = s { outcomingFlow = (FlowStats 1 x) <> (outcomingFlow s) } -addStats RemotePeer x s = s { incomingFlow = (FlowStats 1 x) <> (incomingFlow s) } - --- | Sum of overhead and control bytes in both directions. -wastedBytes :: ConnectionStats -> Int -wastedBytes ConnectionStats {..} = overhead + control - where - FlowStats _ ByteStats {..} = incomingFlow <> outcomingFlow - --- | Sum of payload bytes in both directions. -payloadBytes :: ConnectionStats -> Int -payloadBytes ConnectionStats {..} = - payload (messageBytes (incomingFlow <> outcomingFlow)) - --- | Sum of any bytes in both directions. -transmittedBytes :: ConnectionStats -> Int -transmittedBytes ConnectionStats {..} = - byteLength (messageBytes (incomingFlow <> outcomingFlow)) - -{----------------------------------------------------------------------- --- Flood protection ------------------------------------------------------------------------} - -defaultFloodFactor :: Int -defaultFloodFactor = 1 - --- | This is a very permissive value, connection setup usually takes --- around 10-100KB, including both directions. -defaultFloodThreshold :: Int -defaultFloodThreshold = 2 * 1024 * 1024 - --- | A flood detection function. -type Detector stats = Int -- ^ Factor; - -> Int -- ^ Threshold; - -> stats -- ^ Stats to analyse; - -> Bool -- ^ Is this a flooded connection? - -defaultDetector :: Detector ConnectionStats -defaultDetector factor threshold s = - transmittedBytes s > threshold && - factor * wastedBytes s > payloadBytes s - --- | Flood detection is used to protect /this/ peer against a /remote/ --- malicious peer sending meaningless control messages. -data FloodDetector = FloodDetector - { -- | Max ratio of payload bytes to control bytes. - floodFactor :: {-# UNPACK #-} !Int - - -- | Max count of bytes connection /setup/ can take including - -- 'Handshake', 'ExtendedHandshake', 'Bitfield', 'Have' and 'Port' - -- messages. This value is used to avoid false positives at the - -- connection initialization. - , floodThreshold :: {-# UNPACK #-} !Int - - -- | Flood predicate on the /current/ 'ConnectionStats'. - , floodPredicate :: Detector ConnectionStats - } deriving Show - -instance Eq FloodDetector where - a == b = floodFactor a == floodFactor b - && floodThreshold a == floodThreshold b - --- | Flood detector with very permissive options. -instance Default FloodDetector where - def = FloodDetector - { floodFactor = defaultFloodFactor - , floodThreshold = defaultFloodThreshold - , floodPredicate = defaultDetector - } - --- | This peer might drop connection if the detector gives positive answer. -runDetector :: FloodDetector -> ConnectionStats -> Bool -runDetector FloodDetector {..} = floodPredicate floodFactor floodThreshold - -{----------------------------------------------------------------------- --- Options ------------------------------------------------------------------------} - --- | Various connection settings and limits. -data Options = Options - { -- | How often /this/ peer should send 'KeepAlive' messages. - keepaliveInterval :: {-# UNPACK #-} !Int - - -- | /This/ peer will drop connection if a /remote/ peer did not - -- send any message for this period of time. - , keepaliveTimeout :: {-# UNPACK #-} !Int - - , requestQueueLength :: {-# UNPACK #-} !Int - - -- | Used to protect against flood attacks. - , floodDetector :: FloodDetector - - -- | Used to protect against flood attacks in /metadata - -- exchange/. Normally, a requesting peer should request each - -- 'InfoDict' piece only one time, but a malicious peer can - -- saturate wire with 'MetadataRequest' messages thus flooding - -- responding peer. - -- - -- This value set upper bound for number of 'MetadataRequests' - -- for each piece. - -- - , metadataFactor :: {-# UNPACK #-} !Int - - -- | Used to protect against out-of-memory attacks: malicious peer - -- can claim that 'totalSize' is, say, 100TB and send some random - -- data instead of infodict pieces. Since requesting peer unable - -- to check not completed infodict via the infohash, the - -- accumulated pieces will allocate the all available memory. - -- - -- This limit set upper bound for 'InfoDict' size. See - -- 'ExtendedMetadata' for more info. - -- - , maxInfoDictSize :: {-# UNPACK #-} !Int - } deriving (Show, Eq) - --- | Permissive default parameters, most likely you don't need to --- change them. -instance Default Options where - def = Options - { keepaliveInterval = defaultKeepAliveInterval - , keepaliveTimeout = defaultKeepAliveTimeout - , requestQueueLength = defaultRequestQueueLength - , floodDetector = def - , metadataFactor = defaultMetadataFactor - , maxInfoDictSize = defaultMaxInfoDictSize - } - -{----------------------------------------------------------------------- --- Peer status ------------------------------------------------------------------------} - --- | Connections contain two bits of state on either end: choked or --- not, and interested or not. -data PeerStatus = PeerStatus - { -- | Choking is a notification that no data will be sent until - -- unchoking happens. - _choking :: !Bool - - -- | - , _interested :: !Bool - } deriving (Show, Eq, Ord) - -$(makeLenses ''PeerStatus) - -instance Pretty PeerStatus where - pPrint PeerStatus {..} = - pPrint (Choking _choking) <+> "and" <+> pPrint (Interested _interested) - --- | Connections start out choked and not interested. -instance Default PeerStatus where - def = PeerStatus True False - -instance Monoid PeerStatus where - mempty = def - mappend a b = PeerStatus - { _choking = _choking a && _choking b - , _interested = _interested a || _interested b - } - --- | Can be used to update remote peer status using incoming 'Status' --- message. -updateStatus :: StatusUpdate -> PeerStatus -> PeerStatus -updateStatus (Choking b) = choking .~ b -updateStatus (Interested b) = interested .~ b - --- | Can be used to generate outcoming messages. -statusUpdates :: PeerStatus -> PeerStatus -> [StatusUpdate] -statusUpdates a b = M.catMaybes $ - [ if _choking a == _choking b then Nothing - else Just $ Choking $ _choking b - , if _interested a == _interested b then Nothing - else Just $ Interested $ _interested b - ] - -{----------------------------------------------------------------------- --- Connection status ------------------------------------------------------------------------} - --- | Status of the both endpoints. -data ConnectionStatus = ConnectionStatus - { _clientStatus :: !PeerStatus - , _remoteStatus :: !PeerStatus - } deriving (Show, Eq) - -$(makeLenses ''ConnectionStatus) - -instance Pretty ConnectionStatus where - pPrint ConnectionStatus {..} = - "this " PP.<+> pPrint _clientStatus PP.$$ - "remote" PP.<+> pPrint _remoteStatus - --- | Connections start out choked and not interested. -instance Default ConnectionStatus where - def = ConnectionStatus def def - --- | Can the client transfer to the remote peer? -canUpload :: ConnectionStatus -> Bool -canUpload ConnectionStatus {..} - = _interested _remoteStatus && not (_choking _clientStatus) - --- | Can the client transfer from the remote peer? -canDownload :: ConnectionStatus -> Bool -canDownload ConnectionStatus {..} - = _interested _clientStatus && not (_choking _remoteStatus) - --- | Indicates how many peers are allowed to download from the client --- by default. -defaultUnchokeSlots :: Int -defaultUnchokeSlots = 4 - --- | -defaultRechokeInterval :: Int -defaultRechokeInterval = 10 * 1000 * 1000 - -{----------------------------------------------------------------------- --- Connection ------------------------------------------------------------------------} - -data ConnectionState = ConnectionState { - -- | If @not (allowed ExtExtended connCaps)@ then this set is always - -- empty. Otherwise it has the BEP10 extension protocol mandated mapping of - -- 'MessageId' to the message type for the remote peer. - -- - -- Note that this value can change in current session if either - -- this or remote peer will initiate rehandshaking. - -- - _connExtCaps :: !ExtendedCaps - - -- | Current extended handshake information from the remote peer - , _connRemoteEhs :: !ExtendedHandshake - - -- | Various stats about messages sent and received. Stats can be - -- used to protect /this/ peer against flood attacks. - -- - -- Note that this value will change with the next sent or received - -- message. - , _connStats :: !ConnectionStats - - , _connStatus :: !ConnectionStatus - - -- | Bitfield of remote endpoint. - , _connBitfield :: !Bitfield - } - -makeLenses ''ConnectionState - -instance Default ConnectionState where - def = ConnectionState - { _connExtCaps = def - , _connRemoteEhs = def - , _connStats = def - , _connStatus = def - , _connBitfield = BF.haveNone 0 - } - --- | Connection keep various info about both peers. -data Connection s = Connection - { connInitiatedBy :: !ChannelSide - - , connRemoteAddr :: !(PeerAddr IP) - - -- | /Both/ peers handshaked with this protocol string. The only - -- value is \"Bittorrent Protocol\" but this can be changed in - -- future. - , connProtocol :: !ProtocolName - - -- | Set of enabled core extensions, i.e. the pre BEP10 extension - -- mechanism. This value is used to check if a message is allowed - -- to be sent or received. - , connCaps :: !Caps - - -- | /Both/ peers handshaked with this infohash. A connection can - -- handle only one topic, use 'reconnect' to change the current - -- topic. - , connTopic :: !InfoHash - - -- | Typically extracted from handshake. - , connRemotePeerId :: !PeerId - - -- | Typically extracted from handshake. - , connThisPeerId :: !PeerId - - -- | - , connOptions :: !Options - - -- | Mutable connection state, see 'ConnectionState' - , connState :: !(IORef ConnectionState) - --- -- | Max request queue length. --- , connMaxQueueLen :: !Int - - -- | Environment data. - , connSession :: !s - - , connChan :: !(Chan Message) - } - -instance Pretty (Connection s) where - pPrint Connection {..} = "Connection" - -instance ToLogStr (Connection s) where - toLogStr Connection {..} = mconcat - [ toLogStr (show connRemoteAddr) - , toLogStr (show connProtocol) - , toLogStr (show connCaps) - , toLogStr (show connTopic) - , toLogStr (show connRemotePeerId) - , toLogStr (show connThisPeerId) - , toLogStr (show connOptions) - ] - --- TODO check extended messages too -isAllowed :: Connection s -> Message -> Bool -isAllowed Connection {..} msg - | Just ext <- requires msg = ext `allowed` connCaps - | otherwise = True - -{----------------------------------------------------------------------- --- Hanshaking ------------------------------------------------------------------------} - -sendHandshake :: Socket -> Handshake -> IO () -sendHandshake sock hs = sendAll sock (S.encode hs) - -recvHandshake :: Socket -> IO Handshake -recvHandshake sock = do - header <- BS.recv sock 1 - unless (BS.length header == 1) $ - throw $ userError "Unable to receive handshake header." - - let protocolLen = BS.head header - let restLen = handshakeSize protocolLen - 1 - - body <- BS.recv sock restLen - let resp = BS.cons protocolLen body - either (throwIO . userError) return $ S.decode resp - --- | Handshaking with a peer specified by the second argument. --- --- It's important to send handshake first because /accepting/ peer --- do not know handshake topic and will wait until /connecting/ peer --- will send handshake. --- -initiateHandshake :: Socket -> Handshake -> IO Handshake -initiateHandshake sock hs = do - sendHandshake sock hs - recvHandshake sock - -data HandshakePair = HandshakePair - { handshakeSent :: !Handshake - , handshakeRecv :: !Handshake - } deriving (Show, Eq) - -validatePair :: HandshakePair -> PeerAddr IP -> IO () -validatePair (HandshakePair hs hs') addr = Prelude.mapM_ checkProp - [ (def == hsProtocol hs', InvalidProtocol $ hsProtocol hs') - , (hsProtocol hs == hsProtocol hs', UnexpectedProtocol $ hsProtocol hs') - , (hsInfoHash hs == hsInfoHash hs', UnexpectedTopic $ hsInfoHash hs') - , (hsPeerId hs' == fromMaybe (hsPeerId hs') (peerId addr) - , UnexpectedPeerId $ hsPeerId hs') - ] - where - checkProp (t, e) = unless t $ throwIO $ ProtocolError e - --- | Connection state /right/ after handshaking. -establishedStats :: HandshakePair -> ConnectionStats -establishedStats HandshakePair {..} = ConnectionStats - { outcomingFlow = FlowStats 1 $ handshakeStats handshakeSent - , incomingFlow = FlowStats 1 $ handshakeStats handshakeRecv - } - -{----------------------------------------------------------------------- --- Wire ------------------------------------------------------------------------} - --- | do not expose this so we can change it without breaking api -newtype Connected s a = Connected { runConnected :: (ReaderT (Connection s) IO a) } - deriving (Functor, Applicative, Monad - , MonadIO, MonadReader (Connection s), MonadThrow - ) - -instance MonadState ConnectionState (Connected s) where - get = Connected (asks connState) >>= liftIO . readIORef - put x = Connected (asks connState) >>= liftIO . flip writeIORef x - --- | A duplex channel connected to a remote peer which keep tracks --- connection parameters. -type Wire s a = ConduitM Message Message (Connected s) a - -{----------------------------------------------------------------------- --- Wrapper ------------------------------------------------------------------------} - -putStats :: ChannelSide -> Message -> Connected s () -putStats side msg = connStats %= addStats side (stats msg) - -validate :: ChannelSide -> Message -> Connected s () -validate side msg = do - caps <- asks connCaps - case requires msg of - Nothing -> return () - Just ext - | ext `allowed` caps -> return () - | otherwise -> protocolError $ DisallowedMessage side ext - -trackFlow :: ChannelSide -> Wire s () -trackFlow side = iterM $ do - validate side - putStats side - -{----------------------------------------------------------------------- --- Setup ------------------------------------------------------------------------} - --- System.Timeout.timeout multiplier -seconds :: Int -seconds = 1000000 - -sinkChan :: MonadIO m => Chan Message -> Sink Message m () -sinkChan chan = await >>= maybe (return ()) (liftIO . writeChan chan) - -sourceChan :: MonadIO m => Int -> Chan Message -> Source m Message -sourceChan interval chan = do - mmsg <- liftIO $ timeout (interval * seconds) $ readChan chan - yield $ fromMaybe Msg.KeepAlive mmsg - --- | Normally you should use 'connectWire' or 'acceptWire'. -runWire :: Wire s () -> Socket -> Chan Message -> Connection s -> IO () -runWire action sock chan conn = flip runReaderT conn $ runConnected $ - sourceSocket sock $= - conduitGet S.get $= - trackFlow RemotePeer $= - action $= - trackFlow ThisPeer C.$$ - sinkChan chan - --- | This function will block until a peer send new message. You can --- also use 'await'. -recvMessage :: Wire s Message -recvMessage = await >>= maybe (monadThrow PeerDisconnected) return - --- | You can also use 'yield'. -sendMessage :: PeerMessage msg => msg -> Wire s () -sendMessage msg = do - ecaps <- use connExtCaps - yield $ envelop ecaps msg - -getMaxQueueLength :: Connected s Int -getMaxQueueLength = do - advertisedLen <- ehsQueueLength <$> use connRemoteEhs - defaultLen <- asks (requestQueueLength . connOptions) - return $ fromMaybe defaultLen advertisedLen - --- | Filter pending messages from send buffer. -filterQueue :: (Message -> Bool) -> Wire s () -filterQueue p = lift $ do - chan <- asks connChan - liftIO $ getChanContents chan >>= writeList2Chan chan . L.filter p - --- | Forcefully terminate wire session and close socket. -disconnectPeer :: Wire s a -disconnectPeer = monadThrow DisconnectPeer - -extendedHandshake :: ExtendedCaps -> Wire s () -extendedHandshake caps = do - -- TODO add other params to the handshake - sendMessage $ nullExtendedHandshake caps - msg <- recvMessage - case msg of - Extended (EHandshake remoteEhs@(ExtendedHandshake {..})) -> do - connExtCaps .= (ehsCaps <> caps) - connRemoteEhs .= remoteEhs - _ -> protocolError HandshakeRefused - -rehandshake :: ExtendedCaps -> Wire s () -rehandshake caps = error "rehandshake" - -reconnect :: Wire s () -reconnect = error "reconnect" - -data ConnectionId = ConnectionId - { topic :: !InfoHash - , remoteAddr :: !(PeerAddr IP) - , thisAddr :: !(PeerAddr (Maybe IP)) -- ^ foreign address of this node. - } - --- | /Preffered/ settings of wire. To get the real use 'ask'. -data ConnectionPrefs = ConnectionPrefs - { prefOptions :: !Options - , prefProtocol :: !ProtocolName - , prefCaps :: !Caps - , prefExtCaps :: !ExtendedCaps - } deriving (Show, Eq) - -instance Default ConnectionPrefs where - def = ConnectionPrefs - { prefOptions = def - , prefProtocol = def - , prefCaps = def - , prefExtCaps = def - } - -normalize :: ConnectionPrefs -> ConnectionPrefs -normalize = error "normalize" - --- | Bridge between 'Connection' and 'Network.BitTorrent.Exchange.Session'. -data SessionLink s = SessionLink - { linkTopic :: !(InfoHash) - , linkPeerId :: !(PeerId) - , linkMetadataSize :: !(Maybe Int) - , linkOutputChan :: !(Maybe (Chan Message)) - , linkSession :: !(s) - } - -data ConnectionConfig s = ConnectionConfig - { cfgPrefs :: !(ConnectionPrefs) - , cfgSession :: !(SessionLink s) - , cfgWire :: !(Wire s ()) - } - -configHandshake :: ConnectionConfig s -> Handshake -configHandshake ConnectionConfig {..} = Handshake - { hsProtocol = prefProtocol cfgPrefs - , hsReserved = prefCaps cfgPrefs - , hsInfoHash = linkTopic cfgSession - , hsPeerId = linkPeerId cfgSession - } - -{----------------------------------------------------------------------- --- Pending connections ------------------------------------------------------------------------} - --- | Connection in half opened state. A normal usage scenario: --- --- * Opened using 'newPendingConnection', usually in the listener --- loop; --- --- * Closed using 'closePending' if 'pendingPeer' is banned, --- 'pendingCaps' is prohibited or pendingTopic is unknown; --- --- * Accepted using 'acceptWire' otherwise. --- -data PendingConnection = PendingConnection - { pendingSock :: Socket - , pendingPeer :: PeerAddr IP -- ^ 'peerId' is always non empty; - , pendingCaps :: Caps -- ^ advertised by the peer; - , pendingTopic :: InfoHash -- ^ possible non-existent topic. - } - --- | Reconstruct handshake sent by the remote peer. -pendingHandshake :: PendingConnection -> Handshake -pendingHandshake PendingConnection {..} = Handshake - { hsProtocol = def - , hsReserved = pendingCaps - , hsInfoHash = pendingTopic - , hsPeerId = fromMaybe (error "pendingHandshake: impossible") - (peerId pendingPeer) - } - --- | --- --- This function can throw 'WireFailure' exception. --- -newPendingConnection :: Socket -> PeerAddr IP -> IO PendingConnection -newPendingConnection sock addr = do - Handshake {..} <- recvHandshake sock - unless (hsProtocol == def) $ do - throwIO $ ProtocolError $ InvalidProtocol hsProtocol - return PendingConnection - { pendingSock = sock - , pendingPeer = addr { peerId = Just hsPeerId } - , pendingCaps = hsReserved - , pendingTopic = hsInfoHash - } - --- | Release all resources associated with the given connection. Note --- that you /must not/ 'closePending' if you 'acceptWire'. -closePending :: PendingConnection -> IO () -closePending PendingConnection {..} = do - close pendingSock - -{----------------------------------------------------------------------- --- Connection setup ------------------------------------------------------------------------} - -chanToSock :: Int -> Chan Message -> Socket -> IO () -chanToSock ka chan sock = - sourceChan ka chan $= conduitPut S.put C.$$ sinkSocket sock - -afterHandshaking :: ChannelSide -> PeerAddr IP -> Socket -> HandshakePair - -> ConnectionConfig s -> IO () -afterHandshaking initiator addr sock - hpair @ (HandshakePair hs hs') - (ConnectionConfig - { cfgPrefs = ConnectionPrefs {..} - , cfgSession = SessionLink {..} - , cfgWire = wire - }) = do - let caps = hsReserved hs <> hsReserved hs' - cstate <- newIORef def { _connStats = establishedStats hpair } - chan <- maybe newChan return linkOutputChan - let conn = Connection { - connInitiatedBy = initiator - , connRemoteAddr = addr - , connProtocol = hsProtocol hs - , connCaps = caps - , connTopic = hsInfoHash hs - , connRemotePeerId = hsPeerId hs' - , connThisPeerId = hsPeerId hs - , connOptions = def - , connState = cstate - , connSession = linkSession - , connChan = chan - } - - -- TODO make KA interval configurable - let kaInterval = defaultKeepAliveInterval - wire' = if ExtExtended `allowed` caps - then extendedHandshake prefExtCaps >> wire - else wire - - bracket (forkIO (chanToSock kaInterval chan sock)) - (killThread) - (\ _ -> runWire wire' sock chan conn) - --- | Initiate 'Wire' connection and handshake with a peer. This function will --- also do the BEP10 extension protocol handshake if 'ExtExtended' is enabled on --- both sides. --- --- This function can throw 'WireFailure' exception. --- -connectWire :: PeerAddr IP -> ConnectionConfig s -> IO () -connectWire addr cfg = do - let catchRefusal m = try m >>= either (throwIO . ConnectionRefused) return - bracket (catchRefusal (peerSocket Stream addr)) close $ \ sock -> do - let hs = configHandshake cfg - hs' <- initiateHandshake sock hs - let hpair = HandshakePair hs hs' - validatePair hpair addr - afterHandshaking ThisPeer addr sock hpair cfg - --- | Accept 'Wire' connection using already 'Network.Socket.accept'ed --- socket. For peer listener loop the 'acceptSafe' should be --- prefered against 'accept'. The socket will be closed at exit. --- --- This function can throw 'WireFailure' exception. --- -acceptWire :: PendingConnection -> ConnectionConfig s -> IO () -acceptWire pc @ PendingConnection {..} cfg = do - bracket (return pendingSock) close $ \ _ -> do - unless (linkTopic (cfgSession cfg) == pendingTopic) $ do - throwIO (ProtocolError (UnexpectedTopic pendingTopic)) - - let hs = configHandshake cfg - sendHandshake pendingSock hs - let hpair = HandshakePair hs (pendingHandshake pc) - - afterHandshaking RemotePeer pendingPeer pendingSock hpair cfg - --- | Used when size of bitfield becomes known. -resizeBitfield :: Int -> Connected s () -resizeBitfield n = connBitfield %= adjustSize n diff --git a/bittorrent/src/Network/BitTorrent/Exchange/Download.hs b/bittorrent/src/Network/BitTorrent/Exchange/Download.hs deleted file mode 100644 index 981db2fb..00000000 --- a/bittorrent/src/Network/BitTorrent/Exchange/Download.hs +++ /dev/null @@ -1,296 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- --- -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TemplateHaskell #-} -module Network.BitTorrent.Exchange.Download - ( -- * Downloading - Download (..) - , Updates - , runDownloadUpdates - - -- ** Metadata - -- $metadata-download - , MetadataDownload - , metadataDownload - - -- ** Content - -- $content-download - , ContentDownload - , contentDownload - ) where - -import Control.Applicative -import Control.Concurrent -import Control.Lens -import Control.Monad.State -import Data.BEncode as BE -import Data.ByteString as BS -import Data.ByteString.Lazy as BL -import Data.Default -import Data.List as L -import Data.Maybe -import Data.Map as M -import Data.Tuple - -import Data.Torrent as Torrent -import Network.Address -import Network.BitTorrent.Exchange.Bitfield as BF -import Network.BitTorrent.Exchange.Block as Block -import Network.BitTorrent.Exchange.Message as Msg -import System.Torrent.Storage (Storage, writePiece) - - -{----------------------------------------------------------------------- --- Class ------------------------------------------------------------------------} - -type Updates s a = StateT s IO a - -runDownloadUpdates :: MVar s -> Updates s a -> IO a -runDownloadUpdates var m = modifyMVar var (fmap swap . runStateT m) - -class Download s chunk | s -> chunk where - scheduleBlocks :: Int -> PeerAddr IP -> Bitfield -> Updates s [BlockIx] - - -- | - scheduleBlock :: PeerAddr IP -> Bitfield -> Updates s (Maybe BlockIx) - scheduleBlock addr bf = listToMaybe <$> scheduleBlocks 1 addr bf - - -- | Get number of sent requests to this peer. - getRequestQueueLength :: PeerAddr IP -> Updates s Int - - -- | Remove all pending block requests to the remote peer. May be used - -- when: - -- - -- * a peer closes connection; - -- - -- * remote peer choked this peer; - -- - -- * timeout expired. - -- - resetPending :: PeerAddr IP -> Updates s () - - -- | MAY write to storage, if a new piece have been completed. - -- - -- You should check if a returned by peer block is actually have - -- been requested and in-flight. This is needed to avoid "I send - -- random corrupted block" attacks. - pushBlock :: PeerAddr IP -> chunk -> Updates s (Maybe Bool) - -{----------------------------------------------------------------------- --- Metadata download ------------------------------------------------------------------------} --- $metadata-download --- TODO - -data MetadataDownload = MetadataDownload - { _pendingPieces :: [(PeerAddr IP, PieceIx)] - , _bucket :: Bucket - , _topic :: InfoHash - } - -makeLenses ''MetadataDownload - --- | Create a new scheduler for infodict of the given size. -metadataDownload :: Int -> InfoHash -> MetadataDownload -metadataDownload ps = MetadataDownload [] (Block.empty ps) - -instance Default MetadataDownload where - def = error "instance Default MetadataDownload" - ---cancelPending :: PieceIx -> Updates () -cancelPending pix = pendingPieces %= L.filter ((pix ==) . snd) - -instance Download MetadataDownload (Piece BS.ByteString) where - scheduleBlock addr bf = do - bkt <- use bucket - case spans metadataPieceSize bkt of - [] -> return Nothing - ((off, _ ) : _) -> do - let pix = off `div` metadataPieceSize - pendingPieces %= ((addr, pix) :) - return (Just (BlockIx pix 0 metadataPieceSize)) - - resetPending addr = pendingPieces %= L.filter ((addr ==) . fst) - - pushBlock addr Torrent.Piece {..} = do - p <- use pendingPieces - when ((addr, pieceIndex) `L.notElem` p) $ - error "not requested" - cancelPending pieceIndex - - bucket %= Block.insert (metadataPieceSize * pieceIndex) pieceData - b <- use bucket - case toPiece b of - Nothing -> return Nothing - Just chunks -> do - t <- use topic - case parseInfoDict (BL.toStrict chunks) t of - Right x -> do - pendingPieces .= [] - return undefined -- (Just x) - Left e -> do - pendingPieces .= [] - bucket .= Block.empty (Block.size b) - return undefined -- Nothing - where - -- todo use incremental parsing to avoid BS.concat call - parseInfoDict :: BS.ByteString -> InfoHash -> Result InfoDict - parseInfoDict chunk topic = - case BE.decode chunk of - Right (infodict @ InfoDict {..}) - | topic == idInfoHash -> return infodict - | otherwise -> Left "broken infodict" - Left err -> Left $ "unable to parse infodict " ++ err - -{----------------------------------------------------------------------- --- Content download ------------------------------------------------------------------------} --- $content-download --- --- A block can have one of the following status: --- --- 1) /not allowed/: Piece is not in download set. --- --- 2) /waiting/: (allowed?) Block have been allowed to download, --- but /this/ peer did not send any 'Request' message for this --- block. To allow some piece use --- 'Network.BitTorrent.Exchange.Selector' and then 'allowedSet' --- and 'allowPiece'. --- --- 3) /inflight/: (pending?) Block have been requested but --- /remote/ peer did not send any 'Piece' message for this block. --- Related functions 'markInflight' --- --- 4) /pending/: (stalled?) Block have have been downloaded --- Related functions 'insertBlock'. --- --- Piece status: --- --- 1) /assembled/: (downloaded?) All blocks in piece have been --- downloaded but the piece did not verified yet. --- --- * Valid: go to completed; --- --- * Invalid: go to waiting. --- --- 2) /corrupted/: --- --- 3) /downloaded/: (verified?) A piece have been successfully --- verified via the hash. Usually the piece should be stored to --- the 'System.Torrent.Storage' and /this/ peer should send 'Have' --- messages to the /remote/ peers. --- - -data PieceEntry = PieceEntry - { pending :: [(PeerAddr IP, BlockIx)] - , stalled :: Bucket - } - -pieceEntry :: PieceSize -> PieceEntry -pieceEntry s = PieceEntry [] (Block.empty s) - -isEmpty :: PieceEntry -> Bool -isEmpty PieceEntry {..} = L.null pending && Block.null stalled - -_holes :: PieceIx -> PieceEntry -> [BlockIx] -_holes pix PieceEntry {..} = fmap mkBlockIx (spans defaultTransferSize stalled) - where - mkBlockIx (off, sz) = BlockIx pix off sz - -data ContentDownload = ContentDownload - { inprogress :: !(Map PieceIx PieceEntry) - , bitfield :: !Bitfield - , pieceSize :: !PieceSize - , contentStorage :: Storage - } - -contentDownload :: Bitfield -> PieceSize -> Storage -> ContentDownload -contentDownload = ContentDownload M.empty - ---modifyEntry :: PieceIx -> (PieceEntry -> PieceEntry) -> DownloadUpdates () -modifyEntry pix f = modify $ \ s @ ContentDownload {..} -> s - { inprogress = alter (g pieceSize) pix inprogress } - where - g s = h . f . fromMaybe (pieceEntry s) - h e - | isEmpty e = Nothing - | otherwise = Just e - -instance Download ContentDownload (Block BL.ByteString) where - scheduleBlocks n addr maskBF = do - ContentDownload {..} <- get - let wantPieces = maskBF `BF.difference` bitfield - let wantBlocks = L.concat $ M.elems $ M.mapWithKey _holes $ - M.filterWithKey (\ pix _ -> pix `BF.member` wantPieces) - inprogress - - bixs <- if L.null wantBlocks - then do - mpix <- choosePiece wantPieces - case mpix of -- TODO return 'n' blocks - Nothing -> return [] - Just pix -> return [leadingBlock pix defaultTransferSize] - else chooseBlocks wantBlocks n - - forM_ bixs $ \ bix -> do - modifyEntry (ixPiece bix) $ \ e @ PieceEntry {..} -> e - { pending = (addr, bix) : pending } - - return bixs - where - -- TODO choose block nearest to pending or stalled sets to reduce disk - -- seeks on remote machines - --chooseBlocks :: [BlockIx] -> Int -> DownloadUpdates [BlockIx] - chooseBlocks xs n = return (L.take n xs) - - -- TODO use selection strategies from Exchange.Selector - --choosePiece :: Bitfield -> DownloadUpdates (Maybe PieceIx) - choosePiece bf - | BF.null bf = return $ Nothing - | otherwise = return $ Just $ BF.findMin bf - - getRequestQueueLength addr = do - m <- gets (M.map (L.filter ((==) addr . fst) . pending) . inprogress) - return $ L.sum $ L.map L.length $ M.elems m - - resetPending addr = modify $ \ s -> s { inprogress = reset (inprogress s) } - where - reset = fmap $ \ e -> e - { pending = L.filter (not . (==) addr . fst) (pending e) } - - pushBlock addr blk @ Block {..} = do - mpe <- gets (M.lookup blkPiece . inprogress) - case mpe of - Nothing -> return Nothing - Just (pe @ PieceEntry {..}) - | blockIx blk `L.notElem` fmap snd pending -> return Nothing - | otherwise -> do - let bkt' = Block.insertLazy blkOffset blkData stalled - case toPiece bkt' of - Nothing -> do - modifyEntry blkPiece $ \ e @ PieceEntry {..} -> e - { pending = L.filter ((==) (blockIx blk) . snd) pending - , stalled = bkt' - } - return (Just False) - - Just pieceData -> do - -- TODO verify - storage <- gets contentStorage - liftIO $ writePiece (Torrent.Piece blkPiece pieceData) storage - modify $ \ s @ ContentDownload {..} -> s - { inprogress = M.delete blkPiece inprogress - , bitfield = BF.insert blkPiece bitfield - } - return (Just True) diff --git a/bittorrent/src/Network/BitTorrent/Exchange/Manager.hs b/bittorrent/src/Network/BitTorrent/Exchange/Manager.hs deleted file mode 100644 index 30a6a607..00000000 --- a/bittorrent/src/Network/BitTorrent/Exchange/Manager.hs +++ /dev/null @@ -1,62 +0,0 @@ -module Network.BitTorrent.Exchange.Manager - ( Options (..) - , Manager - , Handler - , newManager - , closeManager - ) where - -import Control.Concurrent -import Control.Exception hiding (Handler) -import Control.Monad -import Data.Default -import Network.Socket - -import Data.Torrent -import Network.Address -import Network.BitTorrent.Exchange.Connection hiding (Options) -import Network.BitTorrent.Exchange.Session - - -data Options = Options - { optBacklog :: Int - , optPeerAddr :: PeerAddr IP - } deriving (Show, Eq) - -instance Default Options where - def = Options - { optBacklog = maxListenQueue - , optPeerAddr = def - } - -data Manager = Manager - { listener :: !ThreadId - } - -type Handler = InfoHash -> IO Session - -handleNewConn :: Socket -> PeerAddr IP -> Handler -> IO () -handleNewConn sock addr handler = do - conn <- newPendingConnection sock addr - ses <- handler (pendingTopic conn) `onException` closePending conn - establish conn ses - -listenIncoming :: Options -> Handler -> IO () -listenIncoming Options {..} handler = do - bracket (socket AF_INET Stream defaultProtocol) close $ \ sock -> do - bind sock (toSockAddr optPeerAddr) - listen sock optBacklog - forever $ do - (conn, sockAddr) <- accept sock - case fromSockAddr sockAddr of - Nothing -> return () - Just addr -> void $ forkIO $ handleNewConn sock addr handler - -newManager :: Options -> Handler -> IO Manager -newManager opts handler = do - tid <- forkIO $ listenIncoming opts handler - return (Manager tid) - -closeManager :: Manager -> IO () -closeManager Manager {..} = do - killThread listener \ No newline at end of file diff --git a/bittorrent/src/Network/BitTorrent/Exchange/Message.hs b/bittorrent/src/Network/BitTorrent/Exchange/Message.hs deleted file mode 100644 index 5c096523..00000000 --- a/bittorrent/src/Network/BitTorrent/Exchange/Message.hs +++ /dev/null @@ -1,1237 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- Normally peer to peer communication consisting of the following --- steps: --- --- * In order to establish the connection between peers we should --- send 'Handshake' message. The 'Handshake' is a required message --- and must be the first message transmitted by the peer to the --- another peer. Another peer should reply with a handshake as well. --- --- * Next peer might sent bitfield message, but might not. In the --- former case we should update bitfield peer have. Again, if we --- have some pieces we should send bitfield. Normally bitfield --- message should sent after the handshake message. --- --- * Regular exchange messages. TODO docs --- --- For more high level API see "Network.BitTorrent.Exchange" module. --- --- For more infomation see: --- --- -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} -{-# OPTIONS -fno-warn-orphans #-} -module Network.BitTorrent.Exchange.Message - ( -- * Capabilities - Capabilities (..) - , Extension (..) - , Caps - - -- * Handshake - , ProtocolName - , Handshake(..) - , defaultHandshake - , handshakeSize - , handshakeMaxSize - , handshakeStats - - -- * Stats - , ByteCount - , ByteStats (..) - , byteLength - - -- * Messages - , Message (..) - , defaultKeepAliveTimeout - , defaultKeepAliveInterval - , PeerMessage (..) - - -- ** Core messages - , StatusUpdate (..) - , Available (..) - , Transfer (..) - , defaultRequestQueueLength - - -- ** Fast extension - , FastMessage (..) - - -- ** Extension protocol - , ExtendedMessage (..) - - -- *** Capabilities - , ExtendedExtension (..) - , ExtendedCaps (..) - - -- *** Handshake - , ExtendedHandshake (..) - , defaultQueueLength - , nullExtendedHandshake - - -- *** Metadata - , ExtendedMetadata (..) - , metadataPieceSize - , defaultMetadataFactor - , defaultMaxInfoDictSize - , isLastPiece - , isValidPiece - ) where - -import Control.Applicative -import Control.Arrow ((&&&), (***)) -import Control.Monad (when) -import Data.Attoparsec.ByteString.Char8 as BS -import Data.BEncode as BE -import Data.BEncode.BDict as BE -import Data.BEncode.Internal as BE (ppBEncode, parser) -import Data.BEncode.Types (BDict) -import Data.Bits -import Data.ByteString as BS -import Data.ByteString.Char8 as BC -import Data.ByteString.Lazy as BL -import Data.Default -import Data.List as L -import Data.Map.Strict as M -import Data.Maybe -import Data.Monoid -import Data.Ord -import Data.Serialize as S -import Data.String -import Data.Text as T -import Data.Typeable -import Data.Word -#if MIN_VERSION_iproute(1,7,4) -import Data.IP hiding (fromSockAddr) -#else -import Data.IP -#endif -import Network -import Network.Socket hiding (KeepAlive) -import Text.PrettyPrint as PP hiding ((<>)) -import Text.PrettyPrint.HughesPJClass hiding ((<>),($$)) - -import Data.Torrent hiding (Piece (..)) -import qualified Data.Torrent as P (Piece (..)) -import Network.Address -import Network.BitTorrent.Exchange.Bitfield -import Network.BitTorrent.Exchange.Block - -{----------------------------------------------------------------------- --- Capabilities ------------------------------------------------------------------------} - --- | -class Capabilities caps where - type Ext caps :: * - - -- | Pack extensions to caps. - toCaps :: [Ext caps] -> caps - - -- | Unpack extensions from caps. - fromCaps :: caps -> [Ext caps] - - -- | Check if an extension is a member of the specified set. - allowed :: Ext caps -> caps -> Bool - -ppCaps :: Capabilities caps => Pretty (Ext caps) => caps -> Doc -ppCaps = hcat . punctuate ", " . L.map pPrint . fromCaps - -{----------------------------------------------------------------------- --- Extensions ------------------------------------------------------------------------} - --- | Enumeration of message extension protocols. --- --- For more info see: --- -data Extension - = ExtDHT -- ^ BEP 5: allow to send PORT messages. - | ExtFast -- ^ BEP 6: allow to send FAST messages. - | ExtExtended -- ^ BEP 10: allow to send the extension protocol messages. - deriving (Show, Eq, Ord, Enum, Bounded) - --- | Full extension names, suitable for logging. -instance Pretty Extension where - pPrint ExtDHT = "Distributed Hash Table Protocol" - pPrint ExtFast = "Fast Extension" - pPrint ExtExtended = "Extension Protocol" - --- | Extension bitmask as specified by BEP 4. -extMask :: Extension -> Word64 -extMask ExtDHT = 0x01 -extMask ExtFast = 0x04 -extMask ExtExtended = 0x100000 - -{----------------------------------------------------------------------- --- Capabilities ------------------------------------------------------------------------} - --- | Capabilities is a set of 'Extension's usually sent in 'Handshake' --- messages. -newtype Caps = Caps Word64 - deriving (Show, Eq) - --- | Render set of extensions as comma separated list. -instance Pretty Caps where - pPrint = ppCaps - {-# INLINE pPrint #-} - --- | The empty set. -instance Default Caps where - def = Caps 0 - {-# INLINE def #-} - --- | Monoid under intersection. 'mempty' includes all known extensions. -instance Monoid Caps where - mempty = toCaps [minBound .. maxBound] - {-# INLINE mempty #-} - - mappend (Caps a) (Caps b) = Caps (a .&. b) - {-# INLINE mappend #-} - --- | 'Handshake' compatible encoding. -instance Serialize Caps where - put (Caps caps) = S.putWord64be caps - {-# INLINE put #-} - - get = Caps <$> S.getWord64be - {-# INLINE get #-} - -instance Capabilities Caps where - type Ext Caps = Extension - - allowed e (Caps caps) = (extMask e .&. caps) /= 0 - {-# INLINE allowed #-} - - toCaps = Caps . L.foldr (.|.) 0 . L.map extMask - fromCaps caps = L.filter (`allowed` caps) [minBound..maxBound] - -{----------------------------------------------------------------------- - Handshake ------------------------------------------------------------------------} - -maxProtocolNameSize :: Word8 -maxProtocolNameSize = maxBound - --- | The protocol name is used to identify to the local peer which --- version of BTP the remote peer uses. -newtype ProtocolName = ProtocolName BS.ByteString - deriving (Eq, Ord, Typeable) - --- | In BTP/1.0 the name is 'BitTorrent protocol'. If this string is --- different from the local peers own protocol name, then the --- connection is to be dropped. -instance Default ProtocolName where - def = ProtocolName "BitTorrent protocol" - -instance Show ProtocolName where - show (ProtocolName bs) = show bs - -instance Pretty ProtocolName where - pPrint (ProtocolName bs) = PP.text $ BC.unpack bs - -instance IsString ProtocolName where - fromString str - | L.length str <= fromIntegral maxProtocolNameSize - = ProtocolName (fromString str) - | otherwise = error $ "fromString: ProtocolName too long: " ++ str - -instance Serialize ProtocolName where - put (ProtocolName bs) = do - putWord8 $ fromIntegral $ BS.length bs - putByteString bs - - get = do - len <- getWord8 - bs <- getByteString $ fromIntegral len - return (ProtocolName bs) - --- | Handshake message is used to exchange all information necessary --- to establish connection between peers. --- -data Handshake = Handshake { - -- | Identifier of the protocol. This is usually equal to 'def'. - hsProtocol :: ProtocolName - - -- | Reserved bytes used to specify supported BEP's. - , hsReserved :: Caps - - -- | Info hash of the info part of the metainfo file. that is - -- transmitted in tracker requests. Info hash of the initiator - -- handshake and response handshake should match, otherwise - -- initiator should break the connection. - -- - , hsInfoHash :: InfoHash - - -- | Peer id of the initiator. This is usually the same peer id - -- that is transmitted in tracker requests. - -- - , hsPeerId :: PeerId - - } deriving (Show, Eq) - -instance Serialize Handshake where - put Handshake {..} = do - put hsProtocol - put hsReserved - put hsInfoHash - put hsPeerId - get = Handshake <$> get <*> get <*> get <*> get - --- | Show handshake protocol string, caps and fingerprint. -instance Pretty Handshake where - pPrint Handshake {..} - = pPrint hsProtocol $$ - pPrint hsReserved $$ - pPrint (fingerprint hsPeerId) - --- | Get handshake message size in bytes from the length of protocol --- string. -handshakeSize :: Word8 -> Int -handshakeSize n = 1 + fromIntegral n + 8 + 20 + 20 - --- | Maximum size of handshake message in bytes. -handshakeMaxSize :: Int -handshakeMaxSize = handshakeSize maxProtocolNameSize - --- | Handshake with default protocol string and reserved bitmask. -defaultHandshake :: InfoHash -> PeerId -> Handshake -defaultHandshake = Handshake def def - -handshakeStats :: Handshake -> ByteStats -handshakeStats (Handshake (ProtocolName bs) _ _ _) - = ByteStats 1 (BS.length bs + 8 + 20 + 20) 0 - -{----------------------------------------------------------------------- --- Stats ------------------------------------------------------------------------} - --- | Number of bytes. -type ByteCount = Int - --- | Summary of encoded message byte layout can be used to collect --- stats about message flow in both directions. This data can be --- retrieved using 'stats' function. -data ByteStats = ByteStats - { -- | Number of bytes used to help encode 'control' and 'payload' - -- bytes: message size, message ID's, etc - overhead :: {-# UNPACK #-} !ByteCount - - -- | Number of bytes used to exchange peers state\/options: piece - -- and block indexes, infohash, port numbers, peer ID\/IP, etc. - , control :: {-# UNPACK #-} !ByteCount - - -- | Number of payload bytes: torrent data blocks and infodict - -- metadata. - , payload :: {-# UNPACK #-} !ByteCount - } deriving Show - -instance Pretty ByteStats where - pPrint s @ ByteStats {..} = fsep - [ PP.int overhead, "overhead" - , PP.int control, "control" - , PP.int payload, "payload" - , "bytes" - ] $+$ fsep - [ PP.int (byteLength s), "total bytes" - ] - --- | Empty byte sequences. -instance Default ByteStats where - def = ByteStats 0 0 0 - --- | Monoid under addition. -instance Monoid ByteStats where - mempty = def - mappend a b = ByteStats - { overhead = overhead a + overhead b - , control = control a + control b - , payload = payload a + payload b - } - --- | Sum of the all byte sequences. -byteLength :: ByteStats -> Int -byteLength ByteStats {..} = overhead + control + payload - -{----------------------------------------------------------------------- --- Regular messages ------------------------------------------------------------------------} - --- | Messages which can be sent after handshaking. Minimal complete --- definition: 'envelop'. -class PeerMessage a where - -- | Construct a message to be /sent/. Note that if 'ExtendedCaps' - -- do not contain mapping for this message the default - -- 'ExtendedMessageId' is used. - envelop :: ExtendedCaps -- ^ The /receiver/ extended capabilities; - -> a -- ^ An regular message; - -> Message -- ^ Enveloped message to sent. - - -- | Find out the extension this message belong to. Can be used to - -- check if this message is allowed to send\/recv in current - -- session. - requires :: a -> Maybe Extension - requires _ = Nothing - - -- | Get sizes of overhead\/control\/payload byte sequences of - -- binary message representation without encoding message to binary - -- bytestring. - -- - -- This function should obey one law: - -- - -- * 'byteLength' ('stats' msg) == 'BL.length' ('encode' msg) - -- - stats :: a -> ByteStats - stats _ = ByteStats 4 0 0 - -{----------------------------------------------------------------------- --- Status messages ------------------------------------------------------------------------} - --- | Notification that the sender have updated its --- 'Network.BitTorrent.Exchange.Status.PeerStatus'. -data StatusUpdate - -- | Notification that the sender will not upload data to the - -- receiver until unchoking happen. - = Choking !Bool - - -- | Notification that the sender is interested (or not interested) - -- in any of the receiver's data pieces. - | Interested !Bool - deriving (Show, Eq, Ord, Typeable) - -instance Pretty StatusUpdate where - pPrint (Choking False) = "not choking" - pPrint (Choking True ) = "choking" - pPrint (Interested False) = "not interested" - pPrint (Interested True ) = "interested" - -instance PeerMessage StatusUpdate where - envelop _ = Status - {-# INLINE envelop #-} - - stats _ = ByteStats 4 1 0 - {-# INLINE stats #-} - -{----------------------------------------------------------------------- --- Available messages ------------------------------------------------------------------------} - --- | Messages used to inform receiver which pieces of the torrent --- sender have. -data Available = - -- | Zero-based index of a piece that has just been successfully - -- downloaded and verified via the hash. - Have ! PieceIx - - -- | The bitfield message may only be sent immediately after the - -- handshaking sequence is complete, and before any other message - -- are sent. If client have no pieces then bitfield need not to be - -- sent. - | Bitfield !Bitfield - deriving (Show, Eq) - -instance Pretty Available where - pPrint (Have ix ) = "Have" <+> int ix - pPrint (Bitfield _ ) = "Bitfield" - -instance PeerMessage Available where - envelop _ = Available - {-# INLINE envelop #-} - - stats (Have _) = ByteStats (4 + 1) 4 0 - stats (Bitfield bf) = ByteStats (4 + 1) (q + trailing) 0 - where - trailing = if r == 0 then 0 else 1 - (q, r) = quotRem (totalCount bf) 8 - -{----------------------------------------------------------------------- --- Transfer messages ------------------------------------------------------------------------} - --- | Messages used to transfer 'Block's. -data Transfer - -- | Request for a particular block. If a client is requested a - -- block that another peer do not have the peer might not answer - -- at all. - = Request ! BlockIx - - -- | Response to a request for a block. - | Piece !(Block BL.ByteString) - - -- | Used to cancel block requests. It is typically used during - -- "End Game". - | Cancel !BlockIx - deriving (Show, Eq) - -instance Pretty Transfer where - pPrint (Request ix ) = "Request" <+> pPrint ix - pPrint (Piece blk) = "Piece" <+> pPrint blk - pPrint (Cancel i ) = "Cancel" <+> pPrint i - -instance PeerMessage Transfer where - envelop _ = Transfer - {-# INLINE envelop #-} - - stats (Request _ ) = ByteStats (4 + 1) (3 * 4) 0 - stats (Piece p ) = ByteStats (4 + 1) (4 + 4 + blockSize p) 0 - stats (Cancel _ ) = ByteStats (4 + 1) (3 * 4) 0 - --- TODO increase --- | Max number of pending 'Request's inflight. -defaultRequestQueueLength :: Int -defaultRequestQueueLength = 1 - -{----------------------------------------------------------------------- --- Fast messages ------------------------------------------------------------------------} - --- | BEP6 messages. -data FastMessage = - -- | If a peer have all pieces it might send the 'HaveAll' message - -- instead of 'Bitfield' message. Used to save bandwidth. - HaveAll - - -- | If a peer have no pieces it might send 'HaveNone' message - -- intead of 'Bitfield' message. Used to save bandwidth. - | HaveNone - - -- | This is an advisory message meaning "you might like to - -- download this piece." Used to avoid excessive disk seeks and - -- amount of IO. - | SuggestPiece !PieceIx - - -- | Notifies a requesting peer that its request will not be - -- satisfied. - | RejectRequest !BlockIx - - -- | This is an advisory messsage meaning \"if you ask for this - -- piece, I'll give it to you even if you're choked.\" Used to - -- shorten starting phase. - | AllowedFast !PieceIx - deriving (Show, Eq) - -instance Pretty FastMessage where - pPrint (HaveAll ) = "Have all" - pPrint (HaveNone ) = "Have none" - pPrint (SuggestPiece pix) = "Suggest" <+> int pix - pPrint (RejectRequest bix) = "Reject" <+> pPrint bix - pPrint (AllowedFast pix) = "Allowed fast" <+> int pix - -instance PeerMessage FastMessage where - envelop _ = Fast - {-# INLINE envelop #-} - - requires _ = Just ExtFast - {-# INLINE requires #-} - - stats HaveAll = ByteStats 4 1 0 - stats HaveNone = ByteStats 4 1 0 - stats (SuggestPiece _) = ByteStats 5 4 0 - stats (RejectRequest _) = ByteStats 5 12 0 - stats (AllowedFast _) = ByteStats 5 4 0 - -{----------------------------------------------------------------------- --- Extension protocol ------------------------------------------------------------------------} - -{----------------------------------------------------------------------- --- Extended capabilities ------------------------------------------------------------------------} - -data ExtendedExtension - = ExtMetadata -- ^ BEP 9: Extension for Peers to Send Metadata Files - deriving (Show, Eq, Ord, Enum, Bounded, Typeable) - -instance IsString ExtendedExtension where - fromString = fromMaybe (error msg) . fromKey . fromString - where - msg = "fromString: could not parse ExtendedExtension" - -instance Pretty ExtendedExtension where - pPrint ExtMetadata = "Extension for Peers to Send Metadata Files" - -fromKey :: BKey -> Maybe ExtendedExtension -fromKey "ut_metadata" = Just ExtMetadata -fromKey _ = Nothing -{-# INLINE fromKey #-} - -toKey :: ExtendedExtension -> BKey -toKey ExtMetadata = "ut_metadata" -{-# INLINE toKey #-} - -type ExtendedMessageId = Word8 - -extId :: ExtendedExtension -> ExtendedMessageId -extId ExtMetadata = 1 -{-# INLINE extId #-} - -type ExtendedMap = Map ExtendedExtension ExtendedMessageId - --- | The extension IDs must be stored for every peer, because every --- peer may have different IDs for the same extension. --- -newtype ExtendedCaps = ExtendedCaps { extendedCaps :: ExtendedMap } - deriving (Show, Eq) - -instance Pretty ExtendedCaps where - pPrint = ppCaps - {-# INLINE pPrint #-} - --- | The empty set. -instance Default ExtendedCaps where - def = ExtendedCaps M.empty - --- | Monoid under intersection: --- --- * The 'mempty' caps includes all known extensions; --- --- * the 'mappend' operation is NOT commutative: it return message --- id from the first caps for the extensions existing in both caps. --- -instance Monoid ExtendedCaps where - mempty = toCaps [minBound..maxBound] - mappend (ExtendedCaps a) (ExtendedCaps b) = - ExtendedCaps (M.intersection a b) - -appendBDict :: BDict -> ExtendedMap -> ExtendedMap -appendBDict (Cons key val xs) caps - | Just ext <- fromKey key - , Right eid <- fromBEncode val = M.insert ext eid (appendBDict xs caps) - | otherwise = appendBDict xs caps -appendBDict Nil caps = caps - --- | Handshake compatible encoding. -instance BEncode ExtendedCaps where - toBEncode = BDict . BE.fromAscList . L.sortBy (comparing fst) - . L.map (toKey *** toBEncode) . M.toList . extendedCaps - - fromBEncode (BDict bd) = pure $ ExtendedCaps $ appendBDict bd M.empty - fromBEncode _ = decodingError "ExtendedCaps" - -instance Capabilities ExtendedCaps where - type Ext ExtendedCaps = ExtendedExtension - - toCaps = ExtendedCaps . M.fromList . L.map (id &&& extId) - - fromCaps = M.keys . extendedCaps - {-# INLINE fromCaps #-} - - allowed e (ExtendedCaps caps) = M.member e caps - {-# INLINE allowed #-} - -remoteMessageId :: ExtendedExtension -> ExtendedCaps -> ExtendedMessageId -remoteMessageId ext = fromMaybe (extId ext) . M.lookup ext . extendedCaps - -{----------------------------------------------------------------------- --- Extended handshake ------------------------------------------------------------------------} - --- | This message should be sent immediately after the standard --- bittorrent handshake to any peer that supports this extension --- protocol. Extended handshakes can be sent more than once, however --- an implementation may choose to ignore subsequent handshake --- messages. --- -data ExtendedHandshake = ExtendedHandshake - { -- | If this peer has an IPv4 interface, this is the compact - -- representation of that address. - ehsIPv4 :: Maybe HostAddress - - -- | If this peer has an IPv6 interface, this is the compact - -- representation of that address. - , ehsIPv6 :: Maybe HostAddress6 - - -- | Dictionary of supported extension messages which maps names - -- of extensions to an extended message ID for each extension - -- message. - , ehsCaps :: ExtendedCaps - - -- | Size of 'Data.Torrent.InfoDict' in bytes. This field should - -- be added if 'ExtMetadata' is enabled in current session /and/ - -- peer have the torrent file. - , ehsMetadataSize :: Maybe Int - - -- | Local TCP /listen/ port. Allows each side to learn about the - -- TCP port number of the other side. - , ehsPort :: Maybe PortNumber - - -- | Request queue the number of outstanding 'Request' messages - -- this client supports without dropping any. - , ehsQueueLength :: Maybe Int - - -- | Client name and version. - , ehsVersion :: Maybe Text - - -- | IP of the remote end - , ehsYourIp :: Maybe IP - } deriving (Show, Eq, Typeable) - -extHandshakeId :: ExtendedMessageId -extHandshakeId = 0 - --- | Default 'Request' queue size. -defaultQueueLength :: Int -defaultQueueLength = 1 - --- | All fields are empty. -instance Default ExtendedHandshake where - def = ExtendedHandshake def def def def def def def def - -instance Monoid ExtendedHandshake where - mempty = def { ehsCaps = mempty } - mappend old new = ExtendedHandshake { - ehsCaps = ehsCaps old <> ehsCaps new, - ehsIPv4 = ehsIPv4 old `mergeOld` ehsIPv4 new, - ehsIPv6 = ehsIPv6 old `mergeOld` ehsIPv6 new, - ehsMetadataSize = ehsMetadataSize old `mergeNew` ehsMetadataSize new, - ehsPort = ehsPort old `mergeOld` ehsPort new, - ehsQueueLength = ehsQueueLength old `mergeNew` ehsQueueLength new, - ehsVersion = ehsVersion old `mergeOld` ehsVersion new, - ehsYourIp = ehsYourIp old `mergeOld` ehsYourIp new - } - where - mergeOld mold mnew = mold <|> mnew - mergeNew mold mnew = mnew <|> mold - - -instance BEncode ExtendedHandshake where - toBEncode ExtendedHandshake {..} = toDict $ - "ipv4" .=? (S.encode <$> ehsIPv4) - .: "ipv6" .=? (S.encode <$> ehsIPv6) - .: "m" .=! ehsCaps - .: "metadata_size" .=? ehsMetadataSize - .: "p" .=? ehsPort - .: "reqq" .=? ehsQueueLength - .: "v" .=? ehsVersion - .: "yourip" .=? (runPut <$> either put put <$> toEither <$> ehsYourIp) - .: endDict - where - toEither (IPv4 v4) = Left v4 - toEither (IPv6 v6) = Right v6 - - fromBEncode = fromDict $ ExtendedHandshake - <$>? "ipv4" - <*>? "ipv6" - <*>! "m" - <*>? "metadata_size" - <*>? "p" - <*>? "reqq" - <*>? "v" - <*> (opt "yourip" >>= getYourIp) - -getYourIp :: Maybe BValue -> BE.Get (Maybe IP) -getYourIp f = - return $ do - BString ip <- f - either (const Nothing) Just $ - case BS.length ip of - 4 -> IPv4 <$> S.decode ip - 16 -> IPv6 <$> S.decode ip - _ -> fail "" - -instance Pretty ExtendedHandshake where - pPrint = PP.text . show - --- | NOTE: Approximated 'stats'. -instance PeerMessage ExtendedHandshake where - envelop c = envelop c . EHandshake - {-# INLINE envelop #-} - - requires _ = Just ExtExtended - {-# INLINE requires #-} - - stats _ = ByteStats (4 + 1 + 1) 100 {- is it ok? -} 0 -- FIXME - {-# INLINE stats #-} - --- | Set default values and the specified 'ExtendedCaps'. -nullExtendedHandshake :: ExtendedCaps -> ExtendedHandshake -nullExtendedHandshake caps = ExtendedHandshake - { ehsIPv4 = Nothing - , ehsIPv6 = Nothing - , ehsCaps = caps - , ehsMetadataSize = Nothing - , ehsPort = Nothing - , ehsQueueLength = Just defaultQueueLength - , ehsVersion = Just $ T.pack $ render $ pPrint libFingerprint - , ehsYourIp = Nothing - } - -{----------------------------------------------------------------------- --- Metadata exchange extension ------------------------------------------------------------------------} - --- | A peer MUST verify that any piece it sends passes the info-hash --- verification. i.e. until the peer has the entire metadata, it --- cannot run SHA-1 to verify that it yields the same hash as the --- info-hash. --- -data ExtendedMetadata - -- | This message requests the a specified metadata piece. The - -- response to this message, from a peer supporting the extension, - -- is either a 'MetadataReject' or a 'MetadataData' message. - = MetadataRequest PieceIx - - -- | If sender requested a valid 'PieceIx' and receiver have the - -- corresponding piece then receiver should respond with this - -- message. - | MetadataData - { -- | A piece of 'Data.Torrent.InfoDict'. - piece :: P.Piece BS.ByteString - - -- | This key has the same semantics as the 'ehsMetadataSize' in - -- the 'ExtendedHandshake' — it is size of the torrent info - -- dict. - , totalSize :: Int - } - - -- | Peers that do not have the entire metadata MUST respond with - -- a reject message to any metadata request. - -- - -- Clients MAY implement flood protection by rejecting request - -- messages after a certain number of them have been - -- served. Typically the number of pieces of metadata times a - -- factor. - | MetadataReject PieceIx - - -- | Reserved. By specification we should ignore unknown metadata - -- messages. - | MetadataUnknown BValue - deriving (Show, Eq, Typeable) - --- | Extended metadata message id used in 'msg_type_key'. -type MetadataId = Int - -msg_type_key, piece_key, total_size_key :: BKey -msg_type_key = "msg_type" -piece_key = "piece" -total_size_key = "total_size" - --- | BEP9 compatible encoding. -instance BEncode ExtendedMetadata where - toBEncode (MetadataRequest pix) = toDict $ - msg_type_key .=! (0 :: MetadataId) - .: piece_key .=! pix - .: endDict - toBEncode (MetadataData (P.Piece pix _) totalSize) = toDict $ - msg_type_key .=! (1 :: MetadataId) - .: piece_key .=! pix - .: total_size_key .=! totalSize - .: endDict - toBEncode (MetadataReject pix) = toDict $ - msg_type_key .=! (2 :: MetadataId) - .: piece_key .=! pix - .: endDict - toBEncode (MetadataUnknown bval) = bval - - fromBEncode bval = (`fromDict` bval) $ do - mid <- field $ req msg_type_key - case mid :: MetadataId of - 0 -> MetadataRequest <$>! piece_key - 1 -> metadataData <$>! piece_key <*>! total_size_key - 2 -> MetadataReject <$>! piece_key - _ -> pure (MetadataUnknown bval) - where - metadataData pix s = MetadataData (P.Piece pix BS.empty) s - --- | Piece data bytes are omitted. -instance Pretty ExtendedMetadata where - pPrint (MetadataRequest pix ) = "Request" <+> PP.int pix - pPrint (MetadataData p t) = "Data" <+> pPrint p <+> PP.int t - pPrint (MetadataReject pix ) = "Reject" <+> PP.int pix - pPrint (MetadataUnknown bval ) = "Unknown" <+> ppBEncode bval - --- | NOTE: Approximated 'stats'. -instance PeerMessage ExtendedMetadata where - envelop c = envelop c . EMetadata (remoteMessageId ExtMetadata c) - {-# INLINE envelop #-} - - requires _ = Just ExtExtended - {-# INLINE requires #-} - - stats (MetadataRequest _) = ByteStats (4 + 1 + 1) {- ~ -} 25 0 - stats (MetadataData p _) = ByteStats (4 + 1 + 1) {- ~ -} 41 $ - BS.length (P.pieceData p) - stats (MetadataReject _) = ByteStats (4 + 1 + 1) {- ~ -} 25 0 - stats (MetadataUnknown _) = ByteStats (4 + 1 + 1) {- ? -} 0 0 - --- | All 'Piece's in 'MetadataData' messages MUST have size equal to --- this value. The last trailing piece can be shorter. -metadataPieceSize :: PieceSize -metadataPieceSize = 16 * 1024 - -isLastPiece :: P.Piece a -> Int -> Bool -isLastPiece P.Piece {..} total = succ pieceIndex == pcnt - where - pcnt = q + if r > 0 then 1 else 0 - (q, r) = quotRem total metadataPieceSize - --- TODO we can check if the piece payload bytestring have appropriate --- length; otherwise serialization MUST fail. -isValidPiece :: P.Piece BL.ByteString -> Int -> Bool -isValidPiece p @ P.Piece {..} total - | isLastPiece p total = pieceSize p <= metadataPieceSize - | otherwise = pieceSize p == metadataPieceSize - -setMetadataPayload :: BS.ByteString -> ExtendedMetadata -> ExtendedMetadata -setMetadataPayload bs (MetadataData (P.Piece pix _) t) = - MetadataData (P.Piece pix bs) t -setMetadataPayload _ msg = msg - -getMetadataPayload :: ExtendedMetadata -> Maybe BS.ByteString -getMetadataPayload (MetadataData (P.Piece _ bs) _) = Just bs -getMetadataPayload _ = Nothing - --- | Metadata BDict usually contain only 'msg_type_key', 'piece_key' --- and 'total_size_key' fields so it normally should take less than --- 100 bytes. This limit is two order of magnitude larger to be --- permissive to 'MetadataUnknown' messages. --- --- See 'maxMessageSize' for further explanation. --- -maxMetadataBDictSize :: Int -maxMetadataBDictSize = 16 * 1024 - -maxMetadataSize :: Int -maxMetadataSize = maxMetadataBDictSize + metadataPieceSize - --- to make MetadataData constructor fields a little bit prettier we --- cheat here: first we read empty 'pieceData' from bdict, but then we --- fill that field with the actual piece data — trailing bytes of --- the message -getMetadata :: Int -> S.Get ExtendedMetadata -getMetadata len - | len > maxMetadataSize = fail $ parseError "size exceeded limit" - | otherwise = do - bs <- getByteString len - parseRes $ BS.parse BE.parser bs - where - parseError reason = "unable to parse metadata message: " ++ reason - - parseRes (BS.Fail _ _ m) = fail $ parseError $ "bdict: " ++ m - parseRes (BS.Partial _) = fail $ parseError "bdict: not enough bytes" - parseRes (BS.Done piece bvalueBS) - | BS.length piece > metadataPieceSize - = fail "infodict piece: size exceeded limit" - | otherwise = do - metadata <- either (fail . parseError) pure $ fromBEncode bvalueBS - return $ setMetadataPayload piece metadata - -putMetadata :: ExtendedMetadata -> BL.ByteString -putMetadata msg - | Just bs <- getMetadataPayload msg = BE.encode msg <> BL.fromStrict bs - | otherwise = BE.encode msg - --- | Allows a requesting peer to send 2 'MetadataRequest's for the --- each piece. --- --- See 'Network.BitTorrent.Wire.Options.metadataFactor' for --- explanation why do we need this limit. -defaultMetadataFactor :: Int -defaultMetadataFactor = 2 - --- | Usually torrent size do not exceed 1MB. This value limit torrent --- /content/ size to about 8TB. --- --- See 'Network.BitTorrent.Wire.Options.maxInfoDictSize' for --- explanation why do we need this limit. -defaultMaxInfoDictSize :: Int -defaultMaxInfoDictSize = 10 * 1024 * 1024 - -{----------------------------------------------------------------------- --- Extension protocol messages ------------------------------------------------------------------------} - --- | For more info see -data ExtendedMessage - = EHandshake ExtendedHandshake - | EMetadata ExtendedMessageId ExtendedMetadata - | EUnknown ExtendedMessageId BS.ByteString - deriving (Show, Eq, Typeable) - -instance Pretty ExtendedMessage where - pPrint (EHandshake ehs) = pPrint ehs - pPrint (EMetadata _ msg) = "Metadata" <+> pPrint msg - pPrint (EUnknown mid _ ) = "Unknown" <+> PP.text (show mid) - -instance PeerMessage ExtendedMessage where - envelop _ = Extended - {-# INLINE envelop #-} - - requires _ = Just ExtExtended - {-# INLINE requires #-} - - stats (EHandshake hs) = stats hs - stats (EMetadata _ msg) = stats msg - stats (EUnknown _ msg) = ByteStats (4 + 1 + 1) (BS.length msg) 0 - -{----------------------------------------------------------------------- --- The message datatype ------------------------------------------------------------------------} - -type MessageId = Word8 - --- | Messages used in communication between peers. --- --- Note: If some extensions are disabled (not present in extension --- mask) and client receive message used by the disabled --- extension then the client MUST close the connection. --- -data Message - -- | Peers may close the TCP connection if they have not received - -- any messages for a given period of time, generally 2 - -- minutes. Thus, the KeepAlive message is sent to keep the - -- connection between two peers alive, if no /other/ message has - -- been sent in a given period of time. - = KeepAlive - | Status !StatusUpdate -- ^ Messages used to update peer status. - | Available !Available -- ^ Messages used to inform availability. - | Transfer !Transfer -- ^ Messages used to transfer 'Block's. - - -- | Peer receiving a handshake indicating the remote peer - -- supports the 'ExtDHT' should send a 'Port' message. Peers that - -- receive this message should attempt to ping the node on the - -- received port and IP address of the remote peer. - | Port !PortNumber - | Fast !FastMessage - | Extended !ExtendedMessage - deriving (Show, Eq) - -instance Default Message where - def = KeepAlive - {-# INLINE def #-} - --- | Payload bytes are omitted. -instance Pretty Message where - pPrint (KeepAlive ) = "Keep alive" - pPrint (Status m) = "Status" <+> pPrint m - pPrint (Available m) = pPrint m - pPrint (Transfer m) = pPrint m - pPrint (Port p) = "Port" <+> int (fromEnum p) - pPrint (Fast m) = pPrint m - pPrint (Extended m) = pPrint m - -instance PeerMessage Message where - envelop _ = id - {-# INLINE envelop #-} - - requires KeepAlive = Nothing - requires (Status _) = Nothing - requires (Available _) = Nothing - requires (Transfer _) = Nothing - requires (Port _) = Just ExtDHT - requires (Fast _) = Just ExtFast - requires (Extended _) = Just ExtExtended - - stats KeepAlive = ByteStats 4 0 0 - stats (Status m) = stats m - stats (Available m) = stats m - stats (Transfer m) = stats m - stats (Port _) = ByteStats 5 2 0 - stats (Fast m) = stats m - stats (Extended m) = stats m - --- | PORT message. -instance PeerMessage PortNumber where - envelop _ = Port - {-# INLINE envelop #-} - - requires _ = Just ExtDHT - {-# INLINE requires #-} - --- | How long /this/ peer should wait before dropping connection, in --- seconds. -defaultKeepAliveTimeout :: Int -defaultKeepAliveTimeout = 2 * 60 - --- | How often /this/ peer should send 'KeepAlive' messages, in --- seconds. -defaultKeepAliveInterval :: Int -defaultKeepAliveInterval = 60 - -getInt :: S.Get Int -getInt = fromIntegral <$> S.getWord32be -{-# INLINE getInt #-} - -putInt :: S.Putter Int -putInt = S.putWord32be . fromIntegral -{-# INLINE putInt #-} - --- | This limit should protect against "out-of-memory" attacks: if a --- malicious peer have sent a long varlength message then receiver can --- accumulate too long bytestring in the 'Get'. --- --- Normal messages should never exceed this limits. --- --- See also 'maxBitfieldSize', 'maxBlockSize' limits. --- -maxMessageSize :: Int -maxMessageSize = 20 + 1024 * 1024 - --- | This also limit max torrent size to: --- --- max_bitfield_size * piece_ix_per_byte * max_piece_size = --- 2 ^ 20 * 8 * 1MB = --- 8TB --- -maxBitfieldSize :: Int -maxBitfieldSize = 1024 * 1024 - -getBitfield :: Int -> S.Get Bitfield -getBitfield len - | len > maxBitfieldSize = fail "BITFIELD message size exceeded limit" - | otherwise = fromBitmap <$> getByteString len - -maxBlockSize :: Int -maxBlockSize = 4 * defaultTransferSize - -getBlock :: Int -> S.Get (Block BL.ByteString) -getBlock len - | len > maxBlockSize = fail "BLOCK message size exceeded limit" - | otherwise = Block <$> getInt <*> getInt - <*> getLazyByteString (fromIntegral len) -{-# INLINE getBlock #-} - -instance Serialize Message where - get = do - len <- getInt - - when (len > maxMessageSize) $ do - fail "message body size exceeded the limit" - - if len == 0 then return KeepAlive - else do - mid <- S.getWord8 - case mid of - 0x00 -> return $ Status (Choking True) - 0x01 -> return $ Status (Choking False) - 0x02 -> return $ Status (Interested True) - 0x03 -> return $ Status (Interested False) - 0x04 -> (Available . Have) <$> getInt - 0x05 -> (Available . Bitfield) <$> getBitfield (pred len) - 0x06 -> (Transfer . Request) <$> S.get - 0x07 -> (Transfer . Piece) <$> getBlock (len - 9) - 0x08 -> (Transfer . Cancel) <$> S.get - 0x09 -> Port <$> S.get - 0x0D -> (Fast . SuggestPiece) <$> getInt - 0x0E -> return $ Fast HaveAll - 0x0F -> return $ Fast HaveNone - 0x10 -> (Fast . RejectRequest) <$> S.get - 0x11 -> (Fast . AllowedFast) <$> getInt - 0x14 -> Extended <$> getExtendedMessage (pred len) - _ -> do - rm <- S.remaining >>= S.getBytes - fail $ "unknown message ID: " ++ show mid ++ "\n" - ++ "remaining available bytes: " ++ show rm - - put KeepAlive = putInt 0 - put (Status msg) = putStatus msg - put (Available msg) = putAvailable msg - put (Transfer msg) = putTransfer msg - put (Port p ) = putPort p - put (Fast msg) = putFast msg - put (Extended m ) = putExtendedMessage m - -statusUpdateId :: StatusUpdate -> MessageId -statusUpdateId (Choking choking) = fromIntegral (0 + fromEnum choking) -statusUpdateId (Interested choking) = fromIntegral (2 + fromEnum choking) - -putStatus :: Putter StatusUpdate -putStatus su = do - putInt 1 - putWord8 (statusUpdateId su) - -putAvailable :: Putter Available -putAvailable (Have i) = do - putInt 5 - putWord8 0x04 - putInt i -putAvailable (Bitfield (toBitmap -> bs)) = do - putInt $ 1 + fromIntegral (BL.length bs) - putWord8 0x05 - putLazyByteString bs - -putBlock :: Putter (Block BL.ByteString) -putBlock Block {..} = do - putInt blkPiece - putInt blkOffset - putLazyByteString blkData - -putTransfer :: Putter Transfer -putTransfer (Request blk) = putInt 13 >> S.putWord8 0x06 >> S.put blk -putTransfer (Piece blk) = do - putInt (9 + blockSize blk) - putWord8 0x07 - putBlock blk -putTransfer (Cancel blk) = putInt 13 >> S.putWord8 0x08 >> S.put blk - -putPort :: Putter PortNumber -putPort p = do - putInt 3 - putWord8 0x09 - put p - -putFast :: Putter FastMessage -putFast HaveAll = putInt 1 >> putWord8 0x0E -putFast HaveNone = putInt 1 >> putWord8 0x0F -putFast (SuggestPiece pix) = putInt 5 >> putWord8 0x0D >> putInt pix -putFast (RejectRequest i ) = putInt 13 >> putWord8 0x10 >> put i -putFast (AllowedFast i ) = putInt 5 >> putWord8 0x11 >> putInt i - -maxEHandshakeSize :: Int -maxEHandshakeSize = 16 * 1024 - -getExtendedHandshake :: Int -> S.Get ExtendedHandshake -getExtendedHandshake messageSize - | messageSize > maxEHandshakeSize - = fail "extended handshake size exceeded limit" - | otherwise = do - bs <- getByteString messageSize - either fail pure $ BE.decode bs - -maxEUnknownSize :: Int -maxEUnknownSize = 64 * 1024 - -getExtendedUnknown :: Int -> S.Get BS.ByteString -getExtendedUnknown len - | len > maxEUnknownSize = fail "unknown extended message size exceeded limit" - | otherwise = getByteString len - -getExtendedMessage :: Int -> S.Get ExtendedMessage -getExtendedMessage messageSize = do - msgId <- getWord8 - let msgBodySize = messageSize - 1 - case msgId of - 0 -> EHandshake <$> getExtendedHandshake msgBodySize - 1 -> EMetadata msgId <$> getMetadata msgBodySize - _ -> EUnknown msgId <$> getExtendedUnknown msgBodySize - --- | By spec. -extendedMessageId :: MessageId -extendedMessageId = 20 - -putExt :: ExtendedMessageId -> BL.ByteString -> Put -putExt mid lbs = do - putWord32be $ fromIntegral (1 + 1 + BL.length lbs) - putWord8 extendedMessageId - putWord8 mid - putLazyByteString lbs - --- NOTE: in contrast to getExtendedMessage this function put length --- and message id too! -putExtendedMessage :: Putter ExtendedMessage -putExtendedMessage (EHandshake hs) = putExt extHandshakeId $ BE.encode hs -putExtendedMessage (EMetadata mid msg) = putExt mid $ putMetadata msg -putExtendedMessage (EUnknown mid bs) = putExt mid $ BL.fromStrict bs diff --git a/bittorrent/src/Network/BitTorrent/Exchange/Session.hs b/bittorrent/src/Network/BitTorrent/Exchange/Session.hs deleted file mode 100644 index 38a3c3a6..00000000 --- a/bittorrent/src/Network/BitTorrent/Exchange/Session.hs +++ /dev/null @@ -1,586 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -module Network.BitTorrent.Exchange.Session - ( -- * Session - Session - , Event (..) - , LogFun - , sessionLogger - - -- * Construction - , newSession - , closeSession - , withSession - - -- * Connection Set - , connect - , connectSink - , establish - - -- * Query - , waitMetadata - , takeMetadata - ) where - -import Control.Applicative -import Control.Concurrent -import Control.Concurrent.Chan.Split as CS -import Control.Concurrent.STM -import Control.Exception hiding (Handler) -import Control.Lens -import Control.Monad as M -import Control.Monad.Logger -import Control.Monad.Reader -import Data.ByteString as BS -import Data.ByteString.Lazy as BL -import Data.Conduit as C (Sink, awaitForever, (=$=), ($=)) -import qualified Data.Conduit as C -import Data.Conduit.List as C -import Data.Map as M -import Data.Monoid -import Data.Set as S -import Data.Text as T -import Data.Typeable -import Text.PrettyPrint hiding ((<>)) -import Text.PrettyPrint.HughesPJClass hiding ((<>),($$)) -import System.Log.FastLogger (LogStr, ToLogStr (..)) - -import Data.BEncode as BE -import Data.Torrent as Torrent -import Network.BitTorrent.Internal.Types -import Network.Address -import Network.BitTorrent.Exchange.Bitfield as BF -import Network.BitTorrent.Exchange.Block as Block -import Network.BitTorrent.Exchange.Connection -import Network.BitTorrent.Exchange.Download as D -import Network.BitTorrent.Exchange.Message as Message -import System.Torrent.Storage - -#if !MIN_VERSION_iproute(1,2,12) -deriving instance Ord IP -#endif - -{----------------------------------------------------------------------- --- Exceptions ------------------------------------------------------------------------} - -data ExchangeError - = InvalidRequest BlockIx StorageFailure - | CorruptedPiece PieceIx - deriving (Show, Typeable) - -instance Exception ExchangeError - -packException :: Exception e => (e -> ExchangeError) -> IO a -> IO a -packException f m = try m >>= either (throwIO . f) return - -{----------------------------------------------------------------------- --- Session state ------------------------------------------------------------------------} --- TODO unmap storage on zero connections - -data Cached a = Cached - { cachedValue :: !a - , cachedData :: BL.ByteString -- keep lazy - } - -cache :: BEncode a => a -> Cached a -cache s = Cached s (BE.encode s) - --- | Logger function. -type LogFun = Loc -> LogSource -> LogLevel -> LogStr -> IO () - ---data SessionStatus = Seeder | Leecher - -data SessionState - = WaitingMetadata - { metadataDownload :: MVar MetadataDownload - , metadataCompleted :: MVar InfoDict -- ^ used to unblock waiters - , contentRootPath :: FilePath - } - | HavingMetadata - { metadataCache :: Cached InfoDict - , contentDownload :: MVar ContentDownload - , contentStorage :: Storage - } - -newSessionState :: FilePath -> Either InfoHash InfoDict -> IO SessionState -newSessionState rootPath (Left ih ) = do - WaitingMetadata <$> newMVar def <*> newEmptyMVar <*> pure rootPath -newSessionState rootPath (Right dict) = do - storage <- openInfoDict ReadWriteEx rootPath dict - download <- newMVar $ D.contentDownload (BF.haveNone (totalPieces storage)) - (piPieceLength (idPieceInfo dict)) - storage - return $ HavingMetadata (cache dict) download storage - -closeSessionState :: SessionState -> IO () -closeSessionState WaitingMetadata {..} = return () -closeSessionState HavingMetadata {..} = close contentStorage - -haveMetadata :: InfoDict -> SessionState -> IO SessionState -haveMetadata dict WaitingMetadata {..} = do - storage <- openInfoDict ReadWriteEx contentRootPath dict - download <- newMVar $ D.contentDownload (BF.haveNone (totalPieces storage)) - (piPieceLength (idPieceInfo dict)) - storage - return HavingMetadata - { metadataCache = cache dict - , contentDownload = download - , contentStorage = storage - } -haveMetadata _ s = return s - -{----------------------------------------------------------------------- --- Session ------------------------------------------------------------------------} - -data Session = Session - { sessionPeerId :: !(PeerId) - , sessionTopic :: !(InfoHash) - , sessionLogger :: !(LogFun) - , sessionEvents :: !(SendPort (Event Session)) - - , sessionState :: !(MVar SessionState) - ------------------------------------------------------------------------- - , connectionsPrefs :: !ConnectionPrefs - - -- | Connections either waiting for TCP/uTP 'connect' or waiting - -- for BT handshake. - , connectionsPending :: !(TVar (Set (PeerAddr IP))) - - -- | Connections successfully handshaked and data transfer can - -- take place. - , connectionsEstablished :: !(TVar (Map (PeerAddr IP) (Connection Session))) - - -- | TODO implement choking mechanism - , connectionsUnchoked :: [PeerAddr IP] - - -- | Messages written to this channel will be sent to the all - -- connections, including pending connections (but right after - -- handshake). - , connectionsBroadcast :: !(Chan Message) - } - -instance EventSource Session where - data Event Session - = ConnectingTo (PeerAddr IP) - | ConnectionEstablished (PeerAddr IP) - | ConnectionAborted - | ConnectionClosed (PeerAddr IP) - | SessionClosed - deriving Show - - listen Session {..} = CS.listen sessionEvents - -newSession :: LogFun - -> PeerAddr (Maybe IP) -- ^ /external/ address of this peer; - -> FilePath -- ^ root directory for content files; - -> Either InfoHash InfoDict -- ^ torrent info dictionary; - -> IO Session -newSession logFun addr rootPath source = do - let ih = either id idInfoHash source - pid <- maybe genPeerId return (peerId addr) - eventStream <- newSendPort - sState <- newSessionState rootPath source - sStateVar <- newMVar sState - pSetVar <- newTVarIO S.empty - eSetVar <- newTVarIO M.empty - chan <- newChan - return Session - { sessionPeerId = pid - , sessionTopic = ih - , sessionLogger = logFun - , sessionEvents = eventStream - , sessionState = sStateVar - , connectionsPrefs = def - , connectionsPending = pSetVar - , connectionsEstablished = eSetVar - , connectionsUnchoked = [] - , connectionsBroadcast = chan - } - -closeSession :: Session -> IO () -closeSession Session {..} = do - s <- readMVar sessionState - closeSessionState s -{- - hSet <- atomically $ do - pSet <- swapTVar connectionsPending S.empty - eSet <- swapTVar connectionsEstablished S.empty - return pSet - mapM_ kill hSet --} - -withSession :: () -withSession = error "withSession" - -{----------------------------------------------------------------------- --- Logging ------------------------------------------------------------------------} - -instance MonadLogger (Connected Session) where - monadLoggerLog loc src lvl msg = do - conn <- ask - ses <- asks connSession - addr <- asks connRemoteAddr - let addrSrc = src <> " @ " <> T.pack (render (pPrint addr)) - liftIO $ sessionLogger ses loc addrSrc lvl (toLogStr msg) - -logMessage :: MonadLogger m => Message -> m () -logMessage msg = logDebugN $ T.pack (render (pPrint msg)) - -logEvent :: MonadLogger m => Text -> m () -logEvent = logInfoN - -{----------------------------------------------------------------------- --- Connection set ------------------------------------------------------------------------} ---- Connection status transition: ---- ---- pending -> established -> finished -> closed ---- | \|/ /|\ ---- \-------------------------------------| ---- ---- Purpose of slots: ---- 1) to avoid duplicates ---- 2) connect concurrently ---- - --- | Add connection to the pending set. -pendingConnection :: PeerAddr IP -> Session -> STM Bool -pendingConnection addr Session {..} = do - pSet <- readTVar connectionsPending - eSet <- readTVar connectionsEstablished - if (addr `S.member` pSet) || (addr `M.member` eSet) - then return False - else do - modifyTVar' connectionsPending (S.insert addr) - return True - --- | Pending connection successfully established, add it to the --- established set. -establishedConnection :: Connected Session () -establishedConnection = do - conn <- ask - addr <- asks connRemoteAddr - Session {..} <- asks connSession - liftIO $ atomically $ do - modifyTVar connectionsPending (S.delete addr) - modifyTVar connectionsEstablished (M.insert addr conn) - --- | Either this or remote peer decided to finish conversation --- (conversation is alread /established/ connection), remote it from --- the established set. -finishedConnection :: Connected Session () -finishedConnection = do - Session {..} <- asks connSession - addr <- asks connRemoteAddr - liftIO $ atomically $ do - modifyTVar connectionsEstablished $ M.delete addr - --- | There are no state for this connection, remove it from the all --- sets. -closedConnection :: PeerAddr IP -> Session -> STM () -closedConnection addr Session {..} = do - modifyTVar connectionsPending $ S.delete addr - modifyTVar connectionsEstablished $ M.delete addr - -getConnectionConfig :: Session -> IO (ConnectionConfig Session) -getConnectionConfig s @ Session {..} = do - chan <- dupChan connectionsBroadcast - let sessionLink = SessionLink { - linkTopic = sessionTopic - , linkPeerId = sessionPeerId - , linkMetadataSize = Nothing - , linkOutputChan = Just chan - , linkSession = s - } - return ConnectionConfig - { cfgPrefs = connectionsPrefs - , cfgSession = sessionLink - , cfgWire = mainWire - } - -type Finalizer = IO () -type Runner = (ConnectionConfig Session -> IO ()) - -runConnection :: Runner -> Finalizer -> PeerAddr IP -> Session -> IO () -runConnection runner finalize addr set @ Session {..} = do - _ <- forkIO (action `finally` cleanup) - return () - where - action = do - notExist <- atomically $ pendingConnection addr set - when notExist $ do - cfg <- getConnectionConfig set - runner cfg - - cleanup = do - finalize --- runStatusUpdates status (SS.resetPending addr) - -- TODO Metata.resetPending addr - atomically $ closedConnection addr set - --- | Establish connection from scratch. If this endpoint is already --- connected, no new connections is created. This function do not block. -connect :: PeerAddr IP -> Session -> IO () -connect addr = runConnection (connectWire addr) (return ()) addr - --- | Establish connection with already pre-connected endpoint. If this --- endpoint is already connected, no new connections is created. This --- function do not block. --- --- 'PendingConnection' will be closed automatically, you do not need --- to call 'closePending'. -establish :: PendingConnection -> Session -> IO () -establish conn = runConnection (acceptWire conn) (closePending conn) - (pendingPeer conn) - --- | Conduit version of 'connect'. -connectSink :: MonadIO m => Session -> Sink [PeerAddr IPv4] m () -connectSink s = C.mapM_ (liftIO . connectBatch) - where - connectBatch = M.mapM_ (\ addr -> connect (IPv4 <$> addr) s) - --- | Why do we need this message? -type BroadcastMessage = ExtendedCaps -> Message - -broadcast :: BroadcastMessage -> Session -> IO () -broadcast = error "broadcast" - -{----------------------------------------------------------------------- --- Helpers ------------------------------------------------------------------------} - -waitMVar :: MVar a -> IO () -waitMVar m = withMVar m (const (return ())) - --- This function appear in new GHC "out of box". (moreover it is atomic) -tryReadMVar :: MVar a -> IO (Maybe a) -tryReadMVar m = do - ma <- tryTakeMVar m - maybe (return ()) (putMVar m) ma - return ma - -readBlock :: BlockIx -> Storage -> IO (Block BL.ByteString) -readBlock bix @ BlockIx {..} s = do - p <- packException (InvalidRequest bix) $ do readPiece ixPiece s - let chunk = BL.take (fromIntegral ixLength) $ - BL.drop (fromIntegral ixOffset) (pieceData p) - if BL.length chunk == fromIntegral ixLength - then return $ Block ixPiece ixOffset chunk - else throwIO $ InvalidRequest bix (InvalidSize ixLength) - --- | -tryReadMetadataBlock :: PieceIx - -> Connected Session (Maybe (Torrent.Piece BS.ByteString, Int)) -tryReadMetadataBlock pix = do - Session {..} <- asks connSession - s <- liftIO (readMVar sessionState) - case s of - WaitingMetadata {..} -> error "tryReadMetadataBlock" - HavingMetadata {..} -> error "tryReadMetadataBlock" - -sendBroadcast :: PeerMessage msg => msg -> Wire Session () -sendBroadcast msg = do - Session {..} <- asks connSession - error "sendBroadcast" --- liftIO $ msg `broadcast` sessionConnections - -waitMetadata :: Session -> IO InfoDict -waitMetadata Session {..} = do - s <- readMVar sessionState - case s of - WaitingMetadata {..} -> readMVar metadataCompleted - HavingMetadata {..} -> return (cachedValue metadataCache) - -takeMetadata :: Session -> IO (Maybe InfoDict) -takeMetadata Session {..} = do - s <- readMVar sessionState - case s of - WaitingMetadata {..} -> return Nothing - HavingMetadata {..} -> return (Just (cachedValue metadataCache)) - -{----------------------------------------------------------------------- --- Triggers ------------------------------------------------------------------------} - --- | Trigger is the reaction of a handler at some event. -type Trigger = Wire Session () - -interesting :: Trigger -interesting = do - addr <- asks connRemoteAddr - sendMessage (Interested True) - sendMessage (Choking False) - tryFillRequestQueue - -fillRequestQueue :: Trigger -fillRequestQueue = do - maxN <- lift getMaxQueueLength - rbf <- use connBitfield - addr <- asks connRemoteAddr --- blks <- withStatusUpdates $ do --- n <- getRequestQueueLength addr --- scheduleBlocks addr rbf (maxN - n) --- mapM_ (sendMessage . Request) blks - return () - -tryFillRequestQueue :: Trigger -tryFillRequestQueue = do - allowed <- canDownload <$> use connStatus - when allowed $ do - fillRequestQueue - -{----------------------------------------------------------------------- --- Incoming message handling ------------------------------------------------------------------------} - -type Handler msg = msg -> Wire Session () - -handleStatus :: Handler StatusUpdate -handleStatus s = do - connStatus %= over remoteStatus (updateStatus s) - case s of - Interested _ -> return () - Choking True -> do - addr <- asks connRemoteAddr --- withStatusUpdates (SS.resetPending addr) - return () - Choking False -> tryFillRequestQueue - -handleAvailable :: Handler Available -handleAvailable msg = do - connBitfield %= case msg of - Have ix -> BF.insert ix - Bitfield bf -> const bf - - --thisBf <- getThisBitfield - thisBf <- undefined - case msg of - Have ix - | ix `BF.member` thisBf -> return () - | otherwise -> interesting - Bitfield bf - | bf `BF.isSubsetOf` thisBf -> return () - | otherwise -> interesting - -handleTransfer :: Handler Transfer -handleTransfer (Request bix) = do - Session {..} <- asks connSession - s <- liftIO $ readMVar sessionState - case s of - WaitingMetadata {..} -> return () - HavingMetadata {..} -> do - bitfield <- undefined -- getThisBitfield - upload <- canUpload <$> use connStatus - when (upload && ixPiece bix `BF.member` bitfield) $ do - blk <- liftIO $ readBlock bix contentStorage - sendMessage (Message.Piece blk) - -handleTransfer (Message.Piece blk) = do - Session {..} <- asks connSession - s <- liftIO $ readMVar sessionState - case s of - WaitingMetadata {..} -> return () -- TODO (?) break connection - HavingMetadata {..} -> do - isSuccess <- undefined -- withStatusUpdates (SS.pushBlock blk storage) - case isSuccess of - Nothing -> liftIO $ throwIO $ userError "block is not requested" - Just isCompleted -> do - when isCompleted $ do - sendBroadcast (Have (blkPiece blk)) --- maybe send not interested - tryFillRequestQueue - -handleTransfer (Cancel bix) = filterQueue (not . (transferResponse bix)) - where - transferResponse bix (Transfer (Message.Piece blk)) = blockIx blk == bix - transferResponse _ _ = False - -{----------------------------------------------------------------------- --- Metadata exchange ------------------------------------------------------------------------} --- TODO introduce new metadata exchange specific exceptions - -waitForMetadata :: Trigger -waitForMetadata = do - Session {..} <- asks connSession - needFetch <- undefined --liftIO (isEmptyMVar infodict) - when needFetch $ do - canFetch <- allowed ExtMetadata <$> use connExtCaps - if canFetch - then tryRequestMetadataBlock - else undefined -- liftIO (waitMVar infodict) - -tryRequestMetadataBlock :: Trigger -tryRequestMetadataBlock = do - mpix <- lift $ undefined --withMetadataUpdates Metadata.scheduleBlock - case mpix of - Nothing -> error "tryRequestMetadataBlock" - Just pix -> sendMessage (MetadataRequest pix) - -handleMetadata :: Handler ExtendedMetadata -handleMetadata (MetadataRequest pix) = - lift (tryReadMetadataBlock pix) >>= sendMessage . mkResponse - where - mkResponse Nothing = MetadataReject pix - mkResponse (Just (piece, total)) = MetadataData piece total - -handleMetadata (MetadataData {..}) = do - ih <- asks connTopic - mdict <- lift $ undefined --withMetadataUpdates (Metadata.pushBlock piece ih) - case mdict of - Nothing -> tryRequestMetadataBlock -- not completed, need all blocks - Just dict -> do -- complete, wake up payload fetch - Session {..} <- asks connSession - liftIO $ modifyMVar_ sessionState (haveMetadata dict) - -handleMetadata (MetadataReject pix) = do - lift $ undefined -- withMetadataUpdates (Metadata.cancelPending pix) - -handleMetadata (MetadataUnknown _ ) = do - logInfoN "Unknown metadata message" - -{----------------------------------------------------------------------- --- Main entry point ------------------------------------------------------------------------} - -acceptRehandshake :: ExtendedHandshake -> Trigger -acceptRehandshake ehs = error "acceptRehandshake" - -handleExtended :: Handler ExtendedMessage -handleExtended (EHandshake ehs) = acceptRehandshake ehs -handleExtended (EMetadata _ msg) = handleMetadata msg -handleExtended (EUnknown _ _ ) = logWarnN "Unknown extension message" - -handleMessage :: Handler Message -handleMessage KeepAlive = return () -handleMessage (Status s) = handleStatus s -handleMessage (Available msg) = handleAvailable msg -handleMessage (Transfer msg) = handleTransfer msg -handleMessage (Port n) = error "handleMessage" -handleMessage (Fast _) = error "handleMessage" -handleMessage (Extended msg) = handleExtended msg - -exchange :: Wire Session () -exchange = do - waitForMetadata - bf <- undefined --getThisBitfield - sendMessage (Bitfield bf) - awaitForever handleMessage - -mainWire :: Wire Session () -mainWire = do - lift establishedConnection - Session {..} <- asks connSession --- lift $ resizeBitfield (totalPieces storage) - logEvent "Connection established" - iterM logMessage =$= exchange =$= iterM logMessage - lift finishedConnection diff --git a/bittorrent/src/Network/BitTorrent/Internal/Cache.hs b/bittorrent/src/Network/BitTorrent/Internal/Cache.hs deleted file mode 100644 index 8c74467a..00000000 --- a/bittorrent/src/Network/BitTorrent/Internal/Cache.hs +++ /dev/null @@ -1,169 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2014 --- License : BSD --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- Cached data for tracker responses. --- -module Network.BitTorrent.Internal.Cache - ( -- * Cache - Cached - , lastUpdated - , updateInterval - , minUpdateInterval - - -- * Construction - , newCached - , newCached_ - - -- * Query - , isAlive - , isStalled - , isExpired - , canUpdate - , shouldUpdate - - -- * Cached data - , tryTakeData - , unsafeTryTakeData - , takeData - ) where - -import Control.Applicative -import Data.Monoid -import Data.Default -import Data.Time -import Data.Time.Clock.POSIX -import System.IO.Unsafe - - -data Cached a = Cached - { -- | Time of resource creation. - lastUpdated :: !POSIXTime - - -- | Minimum invalidation timeout. - , minUpdateInterval :: !NominalDiffTime - - -- | Resource lifetime. - , updateInterval :: !NominalDiffTime - - -- | Resource data. - , cachedData :: a - } deriving (Show, Eq) - --- INVARIANT: minUpdateInterval <= updateInterval - -instance Default (Cached a) where - def = mempty - -instance Functor Cached where - fmap f (Cached t i m a) = Cached t i m (f a) - -posixEpoch :: NominalDiffTime -posixEpoch = 1000000000000000000000000000000000000000000000000000000 - -instance Applicative Cached where - pure = Cached 0 posixEpoch posixEpoch - f <*> c = Cached - { lastUpdated = undefined - , minUpdateInterval = undefined - , updateInterval = undefined - , cachedData = cachedData f (cachedData c) - } - -instance Alternative Cached where - empty = mempty - (<|>) = error "cached alternative instance: not implemented" - -instance Monad Cached where - return = pure - Cached {..} >>= f = Cached - { lastUpdated = undefined - , updateInterval = undefined - , minUpdateInterval = undefined - , cachedData = undefined - } - -instance Monoid (Cached a) where - mempty = Cached - { lastUpdated = 0 - , minUpdateInterval = 0 - , updateInterval = 0 - , cachedData = error "cached mempty: impossible happen" - } - - mappend a b - | expirationTime a > expirationTime b = a - | otherwise = b - -normalize :: NominalDiffTime -> NominalDiffTime - -> (NominalDiffTime, NominalDiffTime) -normalize a b - | a < b = (a, b) - | otherwise = (b, a) -{-# INLINE normalize #-} - -newCached :: NominalDiffTime -> NominalDiffTime -> a -> IO (Cached a) -newCached minInterval interval x = do - t <- getPOSIXTime - let (mui, ui) = normalize minInterval interval - return Cached - { lastUpdated = t - , minUpdateInterval = mui - , updateInterval = ui - , cachedData = x - } - -newCached_ :: NominalDiffTime -> a -> IO (Cached a) -newCached_ interval x = newCached interval interval x -{-# INLINE newCached_ #-} - -expirationTime :: Cached a -> POSIXTime -expirationTime Cached {..} = undefined - -isAlive :: Cached a -> IO Bool -isAlive Cached {..} = do - currentTime <- getPOSIXTime - return $ lastUpdated + updateInterval > currentTime - -isExpired :: Cached a -> IO Bool -isExpired Cached {..} = undefined - -isStalled :: Cached a -> IO Bool -isStalled Cached {..} = undefined - -canUpdate :: Cached a -> IO (Maybe NominalDiffTime) -canUpdate = undefined --isStaled - -shouldUpdate :: Cached a -> IO (Maybe NominalDiffTime) -shouldUpdate = undefined -- isExpired - -tryTakeData :: Cached a -> IO (Maybe a) -tryTakeData c = do - alive <- isAlive c - return $ if alive then Just (cachedData c) else Nothing - -unsafeTryTakeData :: Cached a -> Maybe a -unsafeTryTakeData = unsafePerformIO . tryTakeData - -invalidateData :: Cached a -> IO a -> IO (Cached a) -invalidateData Cached {..} action = do - t <- getPOSIXTime - x <- action - return Cached - { lastUpdated = t - , updateInterval = updateInterval - , minUpdateInterval = minUpdateInterval - , cachedData = x - } - -takeData :: Cached a -> IO a -> IO a -takeData c action = do - mdata <- tryTakeData c - case mdata of - Just a -> return a - Nothing -> do - c' <- invalidateData c action - takeData c' action diff --git a/bittorrent/src/Network/BitTorrent/Internal/Progress.hs b/bittorrent/src/Network/BitTorrent/Internal/Progress.hs deleted file mode 100644 index 6ac889e2..00000000 --- a/bittorrent/src/Network/BitTorrent/Internal/Progress.hs +++ /dev/null @@ -1,154 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- 'Progress' used to track amount downloaded\/left\/upload bytes --- either on per client or per torrent basis. This value is used to --- notify the tracker and usually shown to the user. To aggregate --- total progress you can use the Monoid instance. --- -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS -fno-warn-orphans #-} -module Network.BitTorrent.Internal.Progress - ( -- * Progress - Progress (..) - - -- * Lens - , left - , uploaded - , downloaded - - -- * Construction - , startProgress - , downloadedProgress - , enqueuedProgress - , uploadedProgress - , dequeuedProgress - - -- * Query - , canDownload - , canUpload - ) where - -import Control.Applicative -import Control.Lens hiding ((%=)) -import Data.ByteString.Lazy.Builder as BS -import Data.ByteString.Lazy.Builder.ASCII as BS -import Data.Default -import Data.Monoid -import Data.Serialize as S -import Data.Ratio -import Data.Word -import Network.HTTP.Types.QueryLike -import Text.PrettyPrint as PP -import Text.PrettyPrint.HughesPJClass hiding ((<>),($$)) - - --- | Progress data is considered as dynamic within one client --- session. This data also should be shared across client application --- sessions (e.g. files), otherwise use 'startProgress' to get initial --- 'Progress' value. --- -data Progress = Progress - { _downloaded :: {-# UNPACK #-} !Word64 -- ^ Total amount of bytes downloaded; - , _left :: {-# UNPACK #-} !Word64 -- ^ Total amount of bytes left; - , _uploaded :: {-# UNPACK #-} !Word64 -- ^ Total amount of bytes uploaded. - } deriving (Show, Read, Eq) - -$(makeLenses ''Progress) - --- | UDP tracker compatible encoding. -instance Serialize Progress where - put Progress {..} = do - putWord64be $ fromIntegral _downloaded - putWord64be $ fromIntegral _left - putWord64be $ fromIntegral _uploaded - - get = Progress - <$> (fromIntegral <$> getWord64be) - <*> (fromIntegral <$> getWord64be) - <*> (fromIntegral <$> getWord64be) - -instance Default Progress where - def = Progress 0 0 0 - {-# INLINE def #-} - --- | Can be used to aggregate total progress. -instance Monoid Progress where - mempty = def - {-# INLINE mempty #-} - - mappend (Progress da la ua) (Progress db lb ub) = Progress - { _downloaded = da + db - , _left = la + lb - , _uploaded = ua + ub - } - {-# INLINE mappend #-} - -instance QueryValueLike Builder where - toQueryValue = toQueryValue . BS.toLazyByteString - -instance QueryValueLike Word64 where - toQueryValue = toQueryValue . BS.word64Dec - --- | HTTP Tracker protocol compatible encoding. -instance QueryLike Progress where - toQuery Progress {..} = - [ ("uploaded" , toQueryValue _uploaded) - , ("left" , toQueryValue _left) - , ("downloaded", toQueryValue _downloaded) - ] - -instance Pretty Progress where - pPrint Progress {..} = - "/\\" <+> PP.text (show _uploaded) $$ - "\\/" <+> PP.text (show _downloaded) $$ - "left" <+> PP.text (show _left) - --- | Initial progress is used when there are no session before. --- --- Please note that tracker might penalize client some way if the do --- not accumulate progress. If possible and save 'Progress' between --- client sessions to avoid that. --- -startProgress :: Integer -> Progress -startProgress = Progress 0 0 . fromIntegral -{-# INLINE startProgress #-} - --- | Used when the client download some data from /any/ peer. -downloadedProgress :: Int -> Progress -> Progress -downloadedProgress (fromIntegral -> amount) - = (left -~ amount) - . (downloaded +~ amount) -{-# INLINE downloadedProgress #-} - --- | Used when the client upload some data to /any/ peer. -uploadedProgress :: Int -> Progress -> Progress -uploadedProgress (fromIntegral -> amount) = uploaded +~ amount -{-# INLINE uploadedProgress #-} - --- | Used when leecher join client session. -enqueuedProgress :: Integer -> Progress -> Progress -enqueuedProgress amount = left +~ fromIntegral amount -{-# INLINE enqueuedProgress #-} - --- | Used when leecher leave client session. --- (e.g. user deletes not completed torrent) -dequeuedProgress :: Integer -> Progress -> Progress -dequeuedProgress amount = left -~ fromIntegral amount -{-# INLINE dequeuedProgress #-} - -ri2rw64 :: Ratio Int -> Ratio Word64 -ri2rw64 x = fromIntegral (numerator x) % fromIntegral (denominator x) - --- | Check global /download/ limit by uploaded \/ downloaded ratio. -canDownload :: Ratio Int -> Progress -> Bool -canDownload limit Progress {..} = _uploaded % _downloaded > ri2rw64 limit - --- | Check global /upload/ limit by downloaded \/ uploaded ratio. -canUpload :: Ratio Int -> Progress -> Bool -canUpload limit Progress {..} = _downloaded % _uploaded > ri2rw64 limit diff --git a/bittorrent/src/Network/BitTorrent/Internal/Types.hs b/bittorrent/src/Network/BitTorrent/Internal/Types.hs deleted file mode 100644 index d157db3e..00000000 --- a/bittorrent/src/Network/BitTorrent/Internal/Types.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Network.BitTorrent.Internal.Types - ( EventSource (..) - ) where - -import Control.Concurrent.Chan.Split - -class EventSource source where - data Event source - listen :: source -> IO (ReceivePort (Event source)) diff --git a/bittorrent/src/Network/BitTorrent/Readme.md b/bittorrent/src/Network/BitTorrent/Readme.md deleted file mode 100644 index ebf9545e..00000000 --- a/bittorrent/src/Network/BitTorrent/Readme.md +++ /dev/null @@ -1,10 +0,0 @@ -Layout -====== - -| module group | can import | main purpose | -|:-------------|:------------:|:--------------------------------------:| -| Core | | common datatypes | -| DHT | Core | centralized peer discovery | -| Tracker | Core | decentralized peer discovery | -| Exchange | Core | torrent content exchange | -| Client | any other | core of bittorrent client application | diff --git a/bittorrent/src/Network/BitTorrent/Tracker.hs b/bittorrent/src/Network/BitTorrent/Tracker.hs deleted file mode 100644 index 1191f921..00000000 --- a/bittorrent/src/Network/BitTorrent/Tracker.hs +++ /dev/null @@ -1,51 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : non-portable --- --- This module provides high level API for peer -> tracker --- communication. Tracker is used to discover other peers in the --- network using torrent info hash. --- -{-# LANGUAGE TemplateHaskell #-} -module Network.BitTorrent.Tracker - ( -- * RPC Manager - PeerInfo (..) - , Options - , Manager - , newManager - , closeManager - , withManager - - -- * Multitracker session - , trackerList - , Session - , Event (..) - , trackers - , newSession - , closeSession - , withSession - - -- ** Events - , AnnounceEvent (..) - , notify - , askPeers - - -- ** Session state - , TrackerSession - , trackerPeers - , trackerScrape - - , tryTakeData - , unsafeTryTakeData - - , getSessionState - ) where - -import Network.BitTorrent.Internal.Cache (tryTakeData, unsafeTryTakeData) -import Network.BitTorrent.Tracker.Message -import Network.BitTorrent.Tracker.List -import Network.BitTorrent.Tracker.RPC -import Network.BitTorrent.Tracker.Session diff --git a/bittorrent/src/Network/BitTorrent/Tracker/List.hs b/bittorrent/src/Network/BitTorrent/Tracker/List.hs deleted file mode 100644 index 1507b4be..00000000 --- a/bittorrent/src/Network/BitTorrent/Tracker/List.hs +++ /dev/null @@ -1,197 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2014 --- License : BSD --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- Multitracker Metadata Extension support. --- --- For more info see: --- -{-# LANGUAGE FlexibleInstances #-} -module Network.BitTorrent.Tracker.List - ( -- * Tracker list - TierEntry - , TrackerList - - -- * Construction - , trackers - , trackerList - , shuffleTiers - , mapWithURI - , Network.BitTorrent.Tracker.List.toList - - -- * Traversals - , traverseAll - , traverseTiers - ) where - -import Prelude hiding (mapM, foldr) -import Control.Arrow -import Control.Applicative -import Control.Exception -import Data.Default -import Data.List as L (map, elem, any, filter, null) -import Data.Maybe -import Data.Foldable -import Data.Traversable -import Network.URI -import System.Random.Shuffle - -import Data.Torrent -import Network.BitTorrent.Tracker.RPC as RPC - -{----------------------------------------------------------------------- --- Tracker list datatype ------------------------------------------------------------------------} - -type TierEntry a = (URI, a) -type Tier a = [TierEntry a] - --- | Tracker list is either a single tracker or list of tiers. All --- trackers in each tier must be checked before the client goes on to --- the next tier. -data TrackerList a - = Announce (TierEntry a) -- ^ torrent file 'announce' field only - | TierList [Tier a] -- ^ torrent file 'announce-list' field only - deriving (Show, Eq) - --- | Empty tracker list. Can be used for trackerless torrents. -instance Default (TrackerList a) where - def = TierList [] - -instance Functor TrackerList where - fmap f (Announce (uri, a)) = Announce (uri, f a) - fmap f (TierList a) = TierList (fmap (fmap (second f)) a) - -instance Foldable TrackerList where - foldr f z (Announce e ) = f (snd e) z - foldr f z (TierList xs) = foldr (flip (foldr (f . snd))) z xs - -_traverseEntry f (uri, a) = (,) uri <$> f a - -instance Traversable TrackerList where - traverse f (Announce e ) = Announce <$> _traverseEntry f e - traverse f (TierList xs) = - TierList <$> traverse (traverse (_traverseEntry f)) xs - -traverseWithURI :: Applicative f - => (TierEntry a -> f b) -> TrackerList a -> f (TrackerList b) -traverseWithURI f (Announce (uri, a)) = (Announce . (,) uri) <$> f (uri, a) -traverseWithURI f (TierList xxs ) = - TierList <$> traverse (traverse (traverseEntry f)) xxs - where - traverseEntry f (uri, a) = (,) uri <$> f (uri, a) - -{----------------------------------------------------------------------- --- List extraction ------------------------------------------------------------------------} --- BEP12 do not expose any restrictions for the content of --- 'announce-list' key - there are some /bad/ cases can happen with --- poorly designed or even malicious torrent creation software. --- --- Bad case #1: announce-list is present, but empty. --- --- { tAnnounce = Just "http://a.com" --- , tAnnounceList = Just [[]] --- } --- --- Bad case #2: announce uri do not present in announce list. --- --- { tAnnounce = Just "http://a.com" --- , tAnnounceList = Just [["udp://a.com"]] --- } --- --- The addBackup function solves both problems by adding announce uri --- as backup tier. --- -addBackup :: [[URI]] -> URI -> [[URI]] -addBackup tiers bkp - | L.any (L.elem bkp) tiers = tiers - | otherwise = tiers ++ [[bkp]] - -fixList :: Maybe [[URI]] -> Maybe URI -> Maybe [[URI]] -fixList mxss mx = do - xss <- mxss - let xss' = L.filter (not . L.null) xss - return $ maybe xss' (addBackup xss') mx - -trackers :: [URI] -> TrackerList () -trackers uris = TierList $ map (\uri -> [(uri,())]) uris - --- | Extract set of trackers from torrent file. The 'tAnnounce' key is --- only ignored if the 'tAnnounceList' key is present. -trackerList :: Torrent -> TrackerList () -trackerList Torrent {..} = fromMaybe (TierList []) $ do - (TierList . tierList) <$> (tAnnounceList `fixList` tAnnounce) - <|> (Announce . nullEntry) <$> tAnnounce - where - nullEntry uri = (uri, ()) - tierList = L.map (L.map nullEntry) - --- | Shuffle /order of trackers/ in each tier, preserving original --- /order of tiers/. This can help to balance the load between the --- trackers. -shuffleTiers :: TrackerList a -> IO (TrackerList a) -shuffleTiers (Announce a ) = return (Announce a) -shuffleTiers (TierList xs) = TierList <$> mapM shuffleM xs - -mapWithURI :: (URI -> a -> b) -> TrackerList a -> TrackerList b -mapWithURI f (Announce (uri, a)) = Announce (uri, f uri a) -mapWithURI f (TierList xs ) = TierList (L.map (L.map mapEntry) xs) - where - mapEntry (uri, a) = (uri, f uri a) - -toList :: TrackerList a -> [[TierEntry a]] -toList (Announce e) = [[e]] -toList (TierList xxs) = xxs - -{----------------------------------------------------------------------- --- Special traversals (suppressed RPC exceptions) ------------------------------------------------------------------------} - -catchRPC :: IO a -> IO a -> IO a -catchRPC a b = catch a (f b) - where - f :: a -> RpcException -> a - f = const - -throwRPC :: String -> IO a -throwRPC = throwIO . GenericException - --- | Like 'traverse' but ignores 'RpcExceptions'. -traverseAll :: (TierEntry a -> IO a) -> TrackerList a -> IO (TrackerList a) -traverseAll action = traverseWithURI (action $?) - where - f $? x = catchRPC (f x) (return (snd x)) - --- | Like 'traverse' but put working trackers to the head of tiers. --- This can help to avoid exceessive requests to not available --- trackers at each reannounce. If no one action succeed then original --- list is returned. -traverseTiers :: (TierEntry a -> IO a) -> TrackerList a -> IO (TrackerList a) -traverseTiers action ts = catchRPC (goList ts) (return ts) - where - goList tl @ (Announce _ ) = traverseWithURI action tl - goList (TierList tiers) = TierList <$> goTiers (goTier []) tiers - - goTiers _ [] = throwRPC "traverseTiers: no tiers" - goTiers f (x : xs) = catchRPC shortcut failback - where - shortcut = do - x' <- f x - return (x' : xs) - - failback = do - xs' <- goTiers f xs - return (x : xs') - - goTier _ [] = throwRPC "traverseTiers: no trackers in tier" - goTier failed ((uri, a) : as) = catchRPC shortcut failback - where - shortcut = do - a' <- action (uri, a) - return ((uri, a') : as ++ failed) -- failed trackers at the end - - failback = goTier ((uri, a) : failed) as diff --git a/bittorrent/src/Network/BitTorrent/Tracker/Message.hs b/bittorrent/src/Network/BitTorrent/Tracker/Message.hs deleted file mode 100644 index ab492275..00000000 --- a/bittorrent/src/Network/BitTorrent/Tracker/Message.hs +++ /dev/null @@ -1,925 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- (c) Daniel Gröber 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- Every tracker should support announce query. This query is used --- to discover peers within a swarm and have two-fold effect: --- --- * peer doing announce discover other peers using peer list from --- the response to the announce query. --- --- * tracker store peer information and use it in the succeeding --- requests made by other peers, until the peer info expires. --- --- By convention most trackers support another form of request — --- scrape query — which queries the state of a given torrent (or --- a list of torrents) that the tracker is managing. --- -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} -{-# OPTIONS -fno-warn-orphans #-} -module Network.BitTorrent.Tracker.Message - ( -- * Announce - -- ** Query - AnnounceEvent (..) - , AnnounceQuery (..) - , renderAnnounceQuery - , ParamParseFailure - , parseAnnounceQuery - - -- ** Info - , PeerList (..) - , getPeerList - , AnnounceInfo(..) - , defaultNumWant - , defaultMaxNumWant - , defaultReannounceInterval - - -- * Scrape - -- ** Query - , ScrapeQuery - , renderScrapeQuery - , parseScrapeQuery - - -- ** Info - , ScrapeEntry (..) - , ScrapeInfo - - -- * HTTP specific - -- ** Routes - , PathPiece - , defaultAnnouncePath - , defaultScrapePath - - -- ** Preferences - , AnnouncePrefs (..) - , renderAnnouncePrefs - , parseAnnouncePrefs - - -- ** Request - , AnnounceRequest (..) - , parseAnnounceRequest - , renderAnnounceRequest - - -- ** Response - , announceType - , scrapeType - , parseFailureStatus - - -- ** Extra - , queryToSimpleQuery - - -- * UDP specific - -- ** Connection - , ConnectionId - , initialConnectionId - - -- ** Messages - , Request (..) - , Response (..) - , responseName - - -- ** Transaction - , genTransactionId - , TransactionId - , Transaction (..) - ) - where - -import Control.Applicative -import Control.Monad -import Data.BEncode as BE hiding (Result) -import Data.BEncode.BDict as BE -import Data.ByteString as BS -import Data.ByteString.Char8 as BC -import Data.Char as Char -import Data.Convertible -import Data.Default -import Data.Either -import Data.List as L -import Data.Maybe -import Data.Monoid -import Data.Serialize as S hiding (Result) -import Data.String -import Data.Text (Text) -import Data.Text.Encoding -import Data.Typeable -import Data.Word -#if MIN_VERSION_iproute(1,7,4) -import Data.IP hiding (fromSockAddr) -#else -import Data.IP -#endif -import Network -import Network.HTTP.Types.QueryLike -import Network.HTTP.Types.URI hiding (urlEncode) -import Network.HTTP.Types.Status -import Network.Socket hiding (Connected) -import Numeric -import System.Entropy -import Text.Read (readMaybe) - -import Data.Torrent -import Network.Address -import Network.BitTorrent.Internal.Progress - -{----------------------------------------------------------------------- --- Events ------------------------------------------------------------------------} - --- | Events are used to specify which kind of announce query is performed. -data AnnounceEvent - -- | For the first request: when download first begins. - = Started - - -- | This peer stopped downloading /and/ uploading the torrent or - -- just shutting down. - | Stopped - - -- | This peer completed downloading the torrent. This only happen - -- right after last piece have been verified. No 'Completed' is - -- sent if the file was completed when 'Started'. - | Completed - deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable) - --- | HTTP tracker protocol compatible encoding. -instance QueryValueLike AnnounceEvent where - toQueryValue e = toQueryValue (Char.toLower x : xs) - where - (x : xs) = show e -- INVARIANT: this is always nonempty list - -type EventId = Word32 - --- | UDP tracker encoding event codes. -eventId :: AnnounceEvent -> EventId -eventId Completed = 1 -eventId Started = 2 -eventId Stopped = 3 - --- TODO add Regular event -putEvent :: Putter (Maybe AnnounceEvent) -putEvent Nothing = putWord32be 0 -putEvent (Just e) = putWord32be (eventId e) - -getEvent :: S.Get (Maybe AnnounceEvent) -getEvent = do - eid <- getWord32be - case eid of - 0 -> return Nothing - 1 -> return $ Just Completed - 2 -> return $ Just Started - 3 -> return $ Just Stopped - _ -> fail "unknown event id" - -{----------------------------------------------------------------------- - Announce query ------------------------------------------------------------------------} --- TODO add &ipv6= and &ipv4= params to AnnounceQuery --- http://www.bittorrent.org/beps/bep_0007.html#announce-parameter - --- | A tracker request is HTTP GET request; used to include metrics --- from clients that help the tracker keep overall statistics about --- the torrent. The most important, requests are used by the tracker --- to keep track lists of active peer for a particular torrent. --- -data AnnounceQuery = AnnounceQuery - { - -- | Hash of info part of the torrent usually obtained from - -- 'Torrent' or 'Magnet'. - reqInfoHash :: !InfoHash - - -- | ID of the peer doing request. - , reqPeerId :: !PeerId - - -- | Port to listen to for connections from other - -- peers. Tracker should respond with this port when - -- some /other/ peer request the tracker with the same info hash. - -- Normally, this port is choosed from 'defaultPorts'. - , reqPort :: !PortNumber - - -- | Current progress of peer doing request. - , reqProgress :: !Progress - - -- | The peer IP. Needed only when client communicated with - -- tracker throught a proxy. - , reqIP :: Maybe HostAddress - - -- | Number of peers that the peers wants to receive from. It is - -- optional for trackers to honor this limit. See note for - -- 'defaultNumWant'. - , reqNumWant :: Maybe Int - - -- | If not specified, the request is regular periodic - -- request. Regular request should be sent - , reqEvent :: Maybe AnnounceEvent - } deriving (Show, Eq, Typeable) - --- | UDP tracker protocol compatible encoding. -instance Serialize AnnounceQuery where - put AnnounceQuery {..} = do - put reqInfoHash - put reqPeerId - put reqProgress - putEvent reqEvent - putWord32host $ fromMaybe 0 reqIP - putWord32be $ 0 -- TODO what the fuck is "key"? - putWord32be $ fromIntegral $ fromMaybe (-1) reqNumWant - - put reqPort - - get = do - ih <- get - pid <- get - - progress <- get - - ev <- getEvent - ip <- getWord32be --- key <- getWord32be -- TODO - want <- getWord32be - - port <- get - - return $ AnnounceQuery { - reqInfoHash = ih - , reqPeerId = pid - , reqPort = port - , reqProgress = progress - , reqIP = if ip == 0 then Nothing else Just ip - , reqNumWant = if want == -1 then Nothing - else Just (fromIntegral want) - , reqEvent = ev - } - -instance QueryValueLike PortNumber where - toQueryValue = toQueryValue . show . fromEnum - -instance QueryValueLike Word32 where - toQueryValue = toQueryValue . show - -instance QueryValueLike Int where - toQueryValue = toQueryValue . show - --- | HTTP tracker protocol compatible encoding. -instance QueryLike AnnounceQuery where - toQuery AnnounceQuery {..} = - toQuery reqProgress ++ - [ ("info_hash", toQueryValue reqInfoHash) -- TODO use 'paramName' - , ("peer_id" , toQueryValue reqPeerId) - , ("port" , toQueryValue reqPort) - , ("ip" , toQueryValue reqIP) - , ("numwant" , toQueryValue reqNumWant) - , ("event" , toQueryValue reqEvent) - ] - --- | Filter @param=value@ pairs with the unset value. -queryToSimpleQuery :: Query -> SimpleQuery -queryToSimpleQuery = catMaybes . L.map f - where - f (_, Nothing) = Nothing - f (a, Just b ) = Just (a, b) - --- | Encode announce query to query string. -renderAnnounceQuery :: AnnounceQuery -> SimpleQuery -renderAnnounceQuery = queryToSimpleQuery . toQuery - -data QueryParam - -- announce query - = ParamInfoHash - | ParamPeerId - | ParamPort - | ParamUploaded - | ParamLeft - | ParamDownloaded - | ParamIP - | ParamNumWant - | ParamEvent - -- announce query ext - | ParamCompact - | ParamNoPeerId - deriving (Show, Eq, Ord, Enum) - -paramName :: QueryParam -> BS.ByteString -paramName ParamInfoHash = "info_hash" -paramName ParamPeerId = "peer_id" -paramName ParamPort = "port" -paramName ParamUploaded = "uploaded" -paramName ParamLeft = "left" -paramName ParamDownloaded = "downloaded" -paramName ParamIP = "ip" -paramName ParamNumWant = "numwant" -paramName ParamEvent = "event" -paramName ParamCompact = "compact" -paramName ParamNoPeerId = "no_peer_id" -{-# INLINE paramName #-} - -class FromParam a where - fromParam :: BS.ByteString -> Maybe a - -instance FromParam Bool where - fromParam "0" = Just False - fromParam "1" = Just True - fromParam _ = Nothing - -instance FromParam InfoHash where - fromParam = either (const Nothing) pure . safeConvert - -instance FromParam PeerId where - fromParam = either (const Nothing) pure . safeConvert - -instance FromParam Word32 where - fromParam = readMaybe . BC.unpack - -instance FromParam Word64 where - fromParam = readMaybe . BC.unpack - -instance FromParam Int where - fromParam = readMaybe . BC.unpack - -instance FromParam PortNumber where - fromParam bs = fromIntegral <$> (fromParam bs :: Maybe Word32) - -instance FromParam AnnounceEvent where - fromParam bs = do - (x, xs) <- BC.uncons bs - readMaybe $ BC.unpack $ BC.cons (Char.toUpper x) xs - --- | 'ParamParseFailure' represent errors can occur while parsing HTTP --- tracker requests. In case of failure, this can be used to provide --- more informative 'statusCode' and 'statusMessage' in tracker --- responses. --- -data ParamParseFailure - = Missing QueryParam -- ^ param not found in query string; - | Invalid QueryParam BS.ByteString -- ^ param present but not valid. - deriving (Show, Eq) - -type ParseResult = Either ParamParseFailure - -withError :: ParamParseFailure -> Maybe a -> ParseResult a -withError e = maybe (Left e) Right - -reqParam :: FromParam a => QueryParam -> SimpleQuery -> ParseResult a -reqParam param xs = do - val <- withError (Missing param) $ L.lookup (paramName param) xs - withError (Invalid param val) (fromParam val) - -optParam :: FromParam a => QueryParam -> SimpleQuery -> ParseResult (Maybe a) -optParam param ps - | Just x <- L.lookup (paramName param) ps - = pure <$> withError (Invalid param x) (fromParam x) - | otherwise = pure Nothing - -parseProgress :: SimpleQuery -> ParseResult Progress -parseProgress params = Progress - <$> reqParam ParamDownloaded params - <*> reqParam ParamLeft params - <*> reqParam ParamUploaded params - --- | Parse announce request from a query string. -parseAnnounceQuery :: SimpleQuery -> ParseResult AnnounceQuery -parseAnnounceQuery params = AnnounceQuery - <$> reqParam ParamInfoHash params - <*> reqParam ParamPeerId params - <*> reqParam ParamPort params - <*> parseProgress params - <*> optParam ParamIP params - <*> optParam ParamNumWant params - <*> optParam ParamEvent params - -{----------------------------------------------------------------------- --- Announce Info ------------------------------------------------------------------------} --- TODO check if announceinterval/complete/incomplete is positive ints - --- | Tracker can return peer list in either compact(BEP23) or not --- compact form. --- --- For more info see: --- -data PeerList ip - = PeerList [PeerAddr] - | CompactPeerList [PeerAddr] - deriving (Show, Eq, Typeable, Functor) - --- | The empty non-compact peer list. -instance Default (PeerList IP) where - def = PeerList [] - {-# INLINE def #-} - -getPeerList :: PeerList IP -> [PeerAddr] -getPeerList (PeerList xs) = xs -getPeerList (CompactPeerList xs) = xs - -instance BEncode (PeerList a) where - toBEncode (PeerList xs) = toBEncode xs - toBEncode (CompactPeerList xs) = toBEncode $ runPut (mapM_ put xs) - - fromBEncode (BList l ) = PeerList <$> fromBEncode (BList l) - fromBEncode (BString s ) = CompactPeerList <$> runGet (many get) s - fromBEncode _ = decodingError "PeerList: should be a BString or BList" - --- | The tracker response includes a peer list that helps the client --- participate in the torrent. The most important is 'respPeer' list --- used to join the swarm. --- -data AnnounceInfo = - Failure !Text -- ^ Failure reason in human readable form. - | AnnounceInfo { - -- | Number of peers completed the torrent. (seeders) - respComplete :: !(Maybe Int) - - -- | Number of peers downloading the torrent. (leechers) - , respIncomplete :: !(Maybe Int) - - -- | Recommended interval to wait between requests, in seconds. - , respInterval :: !Int - - -- | Minimal amount of time between requests, in seconds. A - -- peer /should/ make timeout with at least 'respMinInterval' - -- value, otherwise tracker might not respond. If not specified - -- the same applies to 'respInterval'. - , respMinInterval :: !(Maybe Int) - - -- | Peers that must be contacted. - , respPeers :: !(PeerList IP) - - -- | Human readable warning. - , respWarning :: !(Maybe Text) - } deriving (Show, Eq, Typeable) - --- | Empty peer list with default reannounce interval. -instance Default AnnounceInfo where - def = AnnounceInfo - { respComplete = Nothing - , respIncomplete = Nothing - , respInterval = defaultReannounceInterval - , respMinInterval = Nothing - , respPeers = def - , respWarning = Nothing - } - --- | HTTP tracker protocol compatible encoding. -instance BEncode AnnounceInfo where - toBEncode (Failure t) = toDict $ - "failure reason" .=! t - .: endDict - - toBEncode AnnounceInfo {..} = toDict $ - "complete" .=? respComplete - .: "incomplete" .=? respIncomplete - .: "interval" .=! respInterval - .: "min interval" .=? respMinInterval - .: "peers" .=! peers - .: "peers6" .=? peers6 - .: "warning message" .=? respWarning - .: endDict - where - (peers, peers6) = prttn respPeers - - prttn :: PeerList IP -> (PeerList IPv4, Maybe (PeerList IPv6)) - prttn (PeerList xs) = (PeerList xs, Nothing) - prttn (CompactPeerList xs) = mk $ partitionEithers $ toEither <$> xs - where - mk (v4s, v6s) - | L.null v6s = (CompactPeerList v4s, Nothing) - | otherwise = (CompactPeerList v4s, Just (CompactPeerList v6s)) - - toEither :: PeerAddr -> Either PeerAddr PeerAddr - toEither PeerAddr {..} = case peerHost of - ipv4@IPv4{} -> Left $ PeerAddr peerId ipv4 peerPort - ipv6@IPv6{} -> Right $ PeerAddr peerId ipv6 peerPort - - fromBEncode (BDict d) - | Just t <- BE.lookup "failure reason" d = Failure <$> fromBEncode t - | otherwise = (`fromDict` (BDict d)) $ - AnnounceInfo - <$>? "complete" - <*>? "incomplete" - <*>! "interval" - <*>? "min interval" - <*> (uncurry merge =<< (,) <$>! "peers" <*>? "peers6") - <*>? "warning message" - where - merge :: PeerList IPv4 -> Maybe (PeerList IPv6) -> BE.Get (PeerList IP) - merge (PeerList ips) Nothing = pure (PeerList ips) - merge (PeerList _ ) (Just _) - = fail "PeerList: non-compact peer list provided, \ - \but the `peers6' field present" - - merge (CompactPeerList ipv4s) Nothing - = pure $ CompactPeerList ipv4s - - merge (CompactPeerList _ ) (Just (PeerList _)) - = fail "PeerList: the `peers6' field value \ - \should contain *compact* peer list" - - merge (CompactPeerList ipv4s) (Just (CompactPeerList ipv6s)) - = pure $ CompactPeerList $ - ipv4s <> ipv6s - - fromBEncode _ = decodingError "Announce info" - --- | UDP tracker protocol compatible encoding. -instance Serialize AnnounceInfo where - put (Failure msg) = put $ encodeUtf8 msg - put AnnounceInfo {..} = do - putWord32be $ fromIntegral respInterval - putWord32be $ fromIntegral $ fromMaybe 0 respIncomplete - putWord32be $ fromIntegral $ fromMaybe 0 respComplete - forM_ (getPeerList respPeers) put - - get = do - interval <- getWord32be - leechers <- getWord32be - seeders <- getWord32be - peers <- many $ isolate 6 get -- isolated to specify IPv4. - - return $ AnnounceInfo { - respWarning = Nothing - , respInterval = fromIntegral interval - , respMinInterval = Nothing - , respIncomplete = Just $ fromIntegral leechers - , respComplete = Just $ fromIntegral seeders - , respPeers = PeerList peers - } - --- | Decodes announce response from bencoded string, for debugging only. -instance IsString AnnounceInfo where - fromString str = either (error . format) id $ BE.decode (fromString str) - where - format msg = "fromString: unable to decode AnnounceInfo: " ++ msg - --- | Above 25, new peers are highly unlikely to increase download --- speed. Even 30 peers is /plenty/, the official client version 3 --- in fact only actively forms new connections if it has less than --- 30 peers and will refuse connections if it has 55. --- --- --- -defaultNumWant :: Int -defaultNumWant = 50 - --- | Reasonable upper bound of numwant parameter. -defaultMaxNumWant :: Int -defaultMaxNumWant = 200 - --- | Widely used reannounce interval. Note: tracker clients should not --- use this value! -defaultReannounceInterval :: Int -defaultReannounceInterval = 30 * 60 - -{----------------------------------------------------------------------- - Scrape message ------------------------------------------------------------------------} - --- | Scrape query used to specify a set of torrent to scrape. --- If list is empty then tracker should return scrape info about each --- torrent. -type ScrapeQuery = [InfoHash] - --- TODO --- data ScrapeQuery --- = ScrapeAll --- | ScrapeSingle InfoHash --- | ScrapeMulti (HashSet InfoHash) --- deriving (Show) --- --- data ScrapeInfo --- = ScrapeAll (HashMap InfoHash ScrapeEntry) --- | ScrapeSingle InfoHash ScrapeEntry --- | ScrapeMulti (HashMap InfoHash ScrapeEntry) --- - -scrapeParam :: BS.ByteString -scrapeParam = "info_hash" - -isScrapeParam :: BS.ByteString -> Bool -isScrapeParam = (==) scrapeParam - --- | Parse scrape query to query string. -parseScrapeQuery :: SimpleQuery -> ScrapeQuery -parseScrapeQuery - = catMaybes . L.map (fromParam . snd) . L.filter (isScrapeParam . fst) - --- | Render scrape query to query string. -renderScrapeQuery :: ScrapeQuery -> SimpleQuery -renderScrapeQuery = queryToSimpleQuery . L.map mkPair - where - mkPair ih = (scrapeParam, toQueryValue ih) - --- | Overall information about particular torrent. -data ScrapeEntry = ScrapeEntry { - -- | Number of seeders - peers with the entire file. - siComplete :: {-# UNPACK #-} !Int - - -- | Total number of times the tracker has registered a completion. - , siDownloaded :: {-# UNPACK #-} !Int - - -- | Number of leechers. - , siIncomplete :: {-# UNPACK #-} !Int - - -- | Name of the torrent file, as specified by the "name" - -- file in the info section of the .torrent file. - , siName :: !(Maybe Text) - } deriving (Show, Eq, Typeable) - --- | HTTP tracker protocol compatible encoding. -instance BEncode ScrapeEntry where - toBEncode ScrapeEntry {..} = toDict $ - "complete" .=! siComplete - .: "downloaded" .=! siDownloaded - .: "incomplete" .=! siIncomplete - .: "name" .=? siName - .: endDict - - fromBEncode = fromDict $ ScrapeEntry - <$>! "complete" - <*>! "downloaded" - <*>! "incomplete" - <*>? "name" - --- | UDP tracker protocol compatible encoding. -instance Serialize ScrapeEntry where - put ScrapeEntry {..} = do - putWord32be $ fromIntegral siComplete - putWord32be $ fromIntegral siDownloaded - putWord32be $ fromIntegral siIncomplete - - get = ScrapeEntry - <$> (fromIntegral <$> getWord32be) - <*> (fromIntegral <$> getWord32be) - <*> (fromIntegral <$> getWord32be) - <*> pure Nothing - --- | Scrape info about a set of torrents. -type ScrapeInfo = [(InfoHash, ScrapeEntry)] - -{----------------------------------------------------------------------- --- HTTP specific ------------------------------------------------------------------------} - --- | Some HTTP trackers allow to choose prefered representation of the --- 'AnnounceInfo'. It's optional for trackers to honor any of this --- options. -data AnnouncePrefs = AnnouncePrefs - { -- | If specified, "compact" parameter is used to advise the - -- tracker to send peer id list as: - -- - -- * bencoded list (extCompact = Just False); - -- * or more compact binary string (extCompact = Just True). - -- - -- The later is prefered since compact peer list will reduce the - -- size of tracker responses. Hovewer, if tracker do not support - -- this extension then it can return peer list in either form. - -- - -- For more info see: - -- - extCompact :: !(Maybe Bool) - - -- | If specified, "no_peer_id" parameter is used advise tracker - -- to either send or not to send peer id in tracker response. - -- Tracker may not support this extension as well. - -- - -- For more info see: - -- - -- - , extNoPeerId :: !(Maybe Bool) - } deriving (Show, Eq, Typeable) - -instance Default AnnouncePrefs where - def = AnnouncePrefs Nothing Nothing - -instance QueryLike AnnouncePrefs where - toQuery AnnouncePrefs {..} = - [ ("compact", toQueryFlag <$> extCompact) -- TODO use 'paramName' - , ("no_peer_id", toQueryFlag <$> extNoPeerId) - ] - where - toQueryFlag False = "0" - toQueryFlag True = "1" - --- | Parse announce query extended part from query string. -parseAnnouncePrefs :: SimpleQuery -> AnnouncePrefs -parseAnnouncePrefs params = either (const def) id $ - AnnouncePrefs - <$> optParam ParamCompact params - <*> optParam ParamNoPeerId params - --- | Render announce preferences to query string. -renderAnnouncePrefs :: AnnouncePrefs -> SimpleQuery -renderAnnouncePrefs = queryToSimpleQuery . toQuery - --- | HTTP tracker request with preferences. -data AnnounceRequest = AnnounceRequest - { announceQuery :: AnnounceQuery -- ^ Request query params. - , announcePrefs :: AnnouncePrefs -- ^ Optional advises to the tracker. - } deriving (Show, Eq, Typeable) - -instance QueryLike AnnounceRequest where - toQuery AnnounceRequest{..} = - toQuery announcePrefs <> - toQuery announceQuery - --- | Parse announce request from query string. -parseAnnounceRequest :: SimpleQuery -> ParseResult AnnounceRequest -parseAnnounceRequest params = AnnounceRequest - <$> parseAnnounceQuery params - <*> pure (parseAnnouncePrefs params) - --- | Render announce request to query string. -renderAnnounceRequest :: AnnounceRequest -> SimpleQuery -renderAnnounceRequest = queryToSimpleQuery . toQuery - -type PathPiece = BS.ByteString - -defaultAnnouncePath :: PathPiece -defaultAnnouncePath = "announce" - -defaultScrapePath :: PathPiece -defaultScrapePath = "scrape" - -missingOffset :: Int -missingOffset = 101 - -invalidOffset :: Int -invalidOffset = 150 - -parseFailureCode :: ParamParseFailure -> Int -parseFailureCode (Missing param ) = missingOffset + fromEnum param -parseFailureCode (Invalid param _) = invalidOffset + fromEnum param - -parseFailureMessage :: ParamParseFailure -> BS.ByteString -parseFailureMessage e = BS.concat $ case e of - Missing p -> ["Missing parameter: ", paramName p] - Invalid p v -> ["Invalid parameter: ", paramName p, " = ", v] - --- | HTTP response /content type/ for announce info. -announceType :: ByteString -announceType = "text/plain" - --- | HTTP response /content type/ for scrape info. -scrapeType :: ByteString -scrapeType = "text/plain" - --- | Get HTTP response status from a announce params parse failure. --- --- For more info see: --- --- -parseFailureStatus :: ParamParseFailure -> Status -parseFailureStatus = mkStatus <$> parseFailureCode <*> parseFailureMessage - -{----------------------------------------------------------------------- --- UDP specific message types ------------------------------------------------------------------------} - -genToken :: IO Word64 -genToken = do - bs <- getEntropy 8 - either err return $ runGet getWord64be bs - where - err = error "genToken: impossible happen" - --- | Connection Id is used for entire tracker session. -newtype ConnectionId = ConnectionId Word64 - deriving (Eq, Serialize) - -instance Show ConnectionId where - showsPrec _ (ConnectionId cid) = showString "0x" <> showHex cid - -initialConnectionId :: ConnectionId -initialConnectionId = ConnectionId 0x41727101980 - --- | Transaction Id is used within a UDP RPC. -newtype TransactionId = TransactionId Word32 - deriving (Eq, Ord, Enum, Bounded, Serialize) - -instance Show TransactionId where - showsPrec _ (TransactionId tid) = showString "0x" <> showHex tid - -genTransactionId :: IO TransactionId -genTransactionId = (TransactionId . fromIntegral) <$> genToken - -data Request - = Connect - | Announce AnnounceQuery - | Scrape ScrapeQuery - deriving Show - -data Response - = Connected ConnectionId - | Announced AnnounceInfo - | Scraped [ScrapeEntry] - | Failed Text - deriving Show - -responseName :: Response -> String -responseName (Connected _) = "connected" -responseName (Announced _) = "announced" -responseName (Scraped _) = "scraped" -responseName (Failed _) = "failed" - -data family Transaction a -data instance Transaction Request = TransactionQ - { connIdQ :: {-# UNPACK #-} !ConnectionId - , transIdQ :: {-# UNPACK #-} !TransactionId - , request :: !Request - } deriving Show -data instance Transaction Response = TransactionR - { transIdR :: {-# UNPACK #-} !TransactionId - , response :: !Response - } deriving Show - --- TODO newtype -newtype MessageId = MessageId Word32 - deriving (Show, Eq, Num, Serialize) - -connectId, announceId, scrapeId, errorId :: MessageId -connectId = 0 -announceId = 1 -scrapeId = 2 -errorId = 3 - -instance Serialize (Transaction Request) where - put TransactionQ {..} = do - case request of - Connect -> do - put initialConnectionId - put connectId - put transIdQ - - Announce ann -> do - put connIdQ - put announceId - put transIdQ - put ann - - Scrape hashes -> do - put connIdQ - put scrapeId - put transIdQ - forM_ hashes put - - get = do - cid <- get - mid <- get - TransactionQ cid <$> S.get <*> getBody mid - where - getBody :: MessageId -> S.Get Request - getBody msgId - | msgId == connectId = pure Connect - | msgId == announceId = Announce <$> get - | msgId == scrapeId = Scrape <$> many get - | otherwise = fail errMsg - where - errMsg = "unknown request: " ++ show msgId - -instance Serialize (Transaction Response) where - put TransactionR {..} = do - case response of - Connected conn -> do - put connectId - put transIdR - put conn - - Announced info -> do - put announceId - put transIdR - put info - - Scraped infos -> do - put scrapeId - put transIdR - forM_ infos put - - Failed info -> do - put errorId - put transIdR - put (encodeUtf8 info) - - - get = do - mid <- get - TransactionR <$> get <*> getBody mid - where - getBody :: MessageId -> S.Get Response - getBody msgId - | msgId == connectId = Connected <$> get - | msgId == announceId = Announced <$> get - | msgId == scrapeId = Scraped <$> many get - | msgId == errorId = (Failed . decodeUtf8) <$> get - | otherwise = fail msg - where - msg = "unknown response: " ++ show msgId diff --git a/bittorrent/src/Network/BitTorrent/Tracker/RPC.hs b/bittorrent/src/Network/BitTorrent/Tracker/RPC.hs deleted file mode 100644 index 45fef05e..00000000 --- a/bittorrent/src/Network/BitTorrent/Tracker/RPC.hs +++ /dev/null @@ -1,175 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- This module provides unified RPC interface to BitTorrent --- trackers. The tracker is an UDP/HTTP/HTTPS service used to --- discovery peers for a particular existing torrent and keep --- statistics about the swarm. This module also provides a way to --- request scrape info for a particular torrent list. --- -{-# LANGUAGE DeriveDataTypeable #-} -module Network.BitTorrent.Tracker.RPC - ( PeerInfo (..) - - -- * Manager - , Options (..) - , Manager - , newManager - , closeManager - , withManager - - -- * RPC - , SAnnounceQuery (..) - , RpcException (..) - , Network.BitTorrent.Tracker.RPC.announce - , scrape - ) where - -import Control.Exception -import Data.Default -import Data.Typeable -import Network -import Network.URI -import Network.Socket (HostAddress) - -import Data.Torrent -import Network.Address -import Network.BitTorrent.Internal.Progress -import Network.BitTorrent.Tracker.Message -import qualified Network.BitTorrent.Tracker.RPC.HTTP as HTTP -import qualified Network.BitTorrent.Tracker.RPC.UDP as UDP - - -{----------------------------------------------------------------------- --- Simplified announce ------------------------------------------------------------------------} - --- | Info to advertise to trackers. -data PeerInfo = PeerInfo - { peerId :: !PeerId - , peerIP :: !(Maybe HostAddress) - , peerPort :: !PortNumber - } deriving (Show, Eq) - -instance Default PeerInfo where - def = PeerInfo def Nothing 6881 - --- | Simplified announce query. -data SAnnounceQuery = SAnnounceQuery - { sInfoHash :: InfoHash - , sProgress :: Progress - , sNumWant :: Maybe Int - , sEvent :: Maybe AnnounceEvent - } - -fillAnnounceQuery :: PeerInfo -> SAnnounceQuery -> AnnounceQuery -fillAnnounceQuery PeerInfo{..} SAnnounceQuery {..} = AnnounceQuery - { reqInfoHash = sInfoHash - , reqPeerId = peerId - , reqPort = peerPort - , reqProgress = sProgress - , reqIP = peerIP - , reqNumWant = sNumWant - , reqEvent = sEvent - } - -{----------------------------------------------------------------------- --- RPC manager ------------------------------------------------------------------------} - --- | Tracker manager settings. -data Options = Options - { -- | HTTP tracker protocol specific options. - optHttpRPC :: !HTTP.Options - - -- | UDP tracker protocol specific options. - , optUdpRPC :: !UDP.Options - - -- | Whether to use multitracker extension. - , optMultitracker :: !Bool - } - -instance Default Options where - def = Options - { optHttpRPC = def - , optUdpRPC = def - , optMultitracker = True - } - --- | Tracker RPC Manager. -data Manager = Manager - { options :: !Options - , peerInfo :: !PeerInfo - , httpMgr :: !HTTP.Manager - , udpMgr :: !UDP.Manager - } - --- | Create a new 'Manager'. You /must/ manually 'closeManager' --- otherwise resource leakage is possible. Normally, a bittorrent --- client need a single RPC manager only. --- --- This function can throw 'IOException' on invalid 'Options'. --- -newManager :: Options -> PeerInfo -> IO Manager -newManager opts info = do - h <- HTTP.newManager (optHttpRPC opts) - u <- UDP.newManager (optUdpRPC opts) `onException` HTTP.closeManager h - return $ Manager opts info h u - --- | Close all pending RPCs. Behaviour of currently in-flight RPCs can --- differ depending on underlying protocol used. No rpc calls should --- be performed after manager becomes closed. -closeManager :: Manager -> IO () -closeManager Manager {..} = do - UDP.closeManager udpMgr `finally` HTTP.closeManager httpMgr - --- | Normally you need to use 'Control.Monad.Trans.Resource.allocate'. -withManager :: Options -> PeerInfo -> (Manager -> IO a) -> IO a -withManager opts info = bracket (newManager opts info) closeManager - -{----------------------------------------------------------------------- --- Exceptions ------------------------------------------------------------------------} --- TODO Catch IO exceptions on rpc calls (?) - -data RpcException - = UdpException UDP.RpcException -- ^ UDP RPC driver failure; - | HttpException HTTP.RpcException -- ^ HTTP RPC driver failure; - | UnrecognizedScheme String -- ^ unsupported scheme in announce URI; - | GenericException String -- ^ for furter extensibility. - deriving (Show, Typeable) - -instance Exception RpcException - -packException :: Exception e => (e -> RpcException) -> IO a -> IO a -packException f m = try m >>= either (throwIO . f) return -{-# INLINE packException #-} - -{----------------------------------------------------------------------- --- RPC calls ------------------------------------------------------------------------} - -dispatch :: URI -> IO a -> IO a -> IO a -dispatch URI {..} http udp - | uriScheme == "http:" || - uriScheme == "https:" = packException HttpException http - | uriScheme == "udp:" = packException UdpException udp - | otherwise = throwIO $ UnrecognizedScheme uriScheme - -announce :: Manager -> URI -> SAnnounceQuery -> IO AnnounceInfo -announce Manager {..} uri simpleQuery - = dispatch uri - (HTTP.announce httpMgr uri annQ) - ( UDP.announce udpMgr uri annQ) - where - annQ = fillAnnounceQuery peerInfo simpleQuery - -scrape :: Manager -> URI -> ScrapeQuery -> IO ScrapeInfo -scrape Manager {..} uri q - = dispatch uri - (HTTP.scrape httpMgr uri q) - ( UDP.scrape udpMgr uri q) diff --git a/bittorrent/src/Network/BitTorrent/Tracker/RPC/HTTP.hs b/bittorrent/src/Network/BitTorrent/Tracker/RPC/HTTP.hs deleted file mode 100644 index 6f7a53bf..00000000 --- a/bittorrent/src/Network/BitTorrent/Tracker/RPC/HTTP.hs +++ /dev/null @@ -1,191 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD --- Maintainer : pxqr.sta@gmail.com --- Stability : provisional --- Portability : portable --- --- This module implement HTTP tracker protocol. --- --- For more information see: --- --- -{-# LANGUAGE DeriveDataTypeable #-} -module Network.BitTorrent.Tracker.RPC.HTTP - ( -- * Manager - Options (..) - , Manager - , newManager - , closeManager - , withManager - - -- * RPC - , RpcException (..) - , announce - , scrape - , scrapeOne - ) where - -import Control.Applicative -import Control.Exception -import Control.Monad -import Control.Monad.Trans.Resource -import Data.BEncode as BE -import Data.ByteString as BS -import Data.ByteString.Char8 as BC -import Data.ByteString.Lazy as BL -import Data.Default -import Data.List as L -import Data.Monoid -import Data.Typeable hiding (Proxy) -import Network.URI -import Network.HTTP.Conduit hiding - (Manager, newManager, closeManager, withManager) -import Network.HTTP.Client (defaultManagerSettings) -import Network.HTTP.Client.Internal (setUri) -import qualified Network.HTTP.Conduit as HTTP -import Network.HTTP.Types.Header (hUserAgent) -import Network.HTTP.Types.URI (SimpleQuery, renderSimpleQuery) - -import Data.Torrent (InfoHash) -import Network.Address (libUserAgent) -import Network.BitTorrent.Tracker.Message hiding (Request, Response) - -{----------------------------------------------------------------------- --- Exceptions ------------------------------------------------------------------------} - -data RpcException - = RequestFailed HttpException -- ^ failed HTTP request. - | ParserFailure String -- ^ unable to decode tracker response; - | ScrapelessTracker -- ^ tracker do not support scraping; - | BadScrape -- ^ unable to find info hash in response dict; - deriving (Show, Typeable) - -instance Exception RpcException - -packHttpException :: IO a -> IO a -packHttpException m = try m >>= either (throwIO . RequestFailed) return - -{----------------------------------------------------------------------- --- Manager ------------------------------------------------------------------------} - --- | HTTP tracker specific RPC options. -data Options = Options - { -- | Global HTTP announce query preferences. - optAnnouncePrefs :: !AnnouncePrefs - - -- | Whether to use HTTP proxy for HTTP tracker requests. - , optHttpProxy :: !(Maybe Proxy) - - -- | Value to put in HTTP user agent header. - , optUserAgent :: !BS.ByteString - - -- | HTTP manager options. - , optHttpOptions :: !ManagerSettings - } - -instance Default Options where - def = Options - { optAnnouncePrefs = def - , optHttpProxy = Nothing - , optUserAgent = BC.pack libUserAgent - , optHttpOptions = defaultManagerSettings - } - --- | HTTP tracker manager. -data Manager = Manager - { options :: !Options - , httpMgr :: !HTTP.Manager - } - --- | -newManager :: Options -> IO Manager -newManager opts = Manager opts <$> HTTP.newManager (optHttpOptions opts) - --- | -closeManager :: Manager -> IO () -closeManager Manager {..} = HTTP.closeManager httpMgr - --- | Normally you need to use 'Control.Monad.Trans.Resource.allocate'. -withManager :: Options -> (Manager -> IO a) -> IO a -withManager opts = bracket (newManager opts) closeManager - -{----------------------------------------------------------------------- --- Queries ------------------------------------------------------------------------} - -fillRequest :: Options -> SimpleQuery -> Request -> Request -fillRequest Options {..} q r = r - { queryString = joinQuery (queryString r) (renderSimpleQuery False q) - , requestHeaders = (hUserAgent, optUserAgent) : requestHeaders r - , proxy = optHttpProxy - } - where - joinQuery a b - | BS.null a = b - | otherwise = a <> "&" <> b - -httpTracker :: BEncode a => Manager -> URI -> SimpleQuery -> IO a -httpTracker Manager {..} uri q = packHttpException $ do - request <- fillRequest options q <$> setUri defaultRequest uri - response <- runResourceT $ httpLbs request httpMgr - case BE.decode $ BL.toStrict $ responseBody response of - Left msg -> throwIO (ParserFailure msg) - Right info -> return info - -{----------------------------------------------------------------------- --- RPC ------------------------------------------------------------------------} - --- | Send request and receive response from the tracker specified in --- announce list. --- --- This function can throw 'RpcException'. --- -announce :: Manager -> URI -> AnnounceQuery -> IO AnnounceInfo -announce mgr uri q = httpTracker mgr uri (renderAnnounceRequest uriQ) - where - uriQ = AnnounceRequest - { announceQuery = q - , announcePrefs = optAnnouncePrefs (options mgr) - } - --- | Trying to convert /announce/ URL to /scrape/ URL. If 'scrapeURL' --- gives 'Nothing' then tracker do not support scraping. --- -scrapeURL :: URI -> Maybe URI -scrapeURL uri = do - newPath <- replace (BC.pack (uriPath uri)) - return uri { uriPath = BC.unpack newPath } - where - replace p = do - let ps = BC.splitWith (== '/') p - guard (not (L.null ps)) - guard ("announce" `BS.isPrefixOf` L.last ps) - let newSuff = "scrape" <> BS.drop (BS.length "announce") (L.last ps) - return (BS.intercalate "/" (L.init ps ++ [newSuff])) - --- | For each 'InfoHash' of torrents request scrape info from the tracker. --- However if the info hash list is 'null', the tracker should list --- all available torrents. --- --- This function can throw 'RpcException'. --- -scrape :: Manager -> URI -> ScrapeQuery -> IO ScrapeInfo -scrape m u q = do - case scrapeURL u of - Nothing -> throwIO ScrapelessTracker - Just uri -> httpTracker m uri (renderScrapeQuery q) - --- | More particular version of 'scrape', just for one torrent. --- --- This function can throw 'RpcException'. --- -scrapeOne :: Manager -> URI -> InfoHash -> IO ScrapeEntry -scrapeOne m uri ih = do - xs <- scrape m uri [ih] - case L.lookup ih xs of - Nothing -> throwIO BadScrape - Just a -> return a diff --git a/bittorrent/src/Network/BitTorrent/Tracker/RPC/UDP.hs b/bittorrent/src/Network/BitTorrent/Tracker/RPC/UDP.hs deleted file mode 100644 index 31b6b870..00000000 --- a/bittorrent/src/Network/BitTorrent/Tracker/RPC/UDP.hs +++ /dev/null @@ -1,454 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013-2014 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : provisional --- Portability : portable --- --- This module implement UDP tracker protocol. --- --- For protocol details and uri scheme see: --- , --- --- -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -module Network.BitTorrent.Tracker.RPC.UDP - ( -- * Manager - Options (..) - , Manager - , newManager - , closeManager - , withManager - - -- * RPC - , RpcException (..) - , announce - , scrape - ) where - -import Control.Applicative -import Control.Concurrent -import Control.Exception -import Control.Monad -import Data.Default -import Data.IORef -import Data.List as L -import Data.Map as M -import Data.Maybe -import Data.Serialize -import Data.Text as T -import Data.Time -import Data.Time.Clock.POSIX -import Data.Traversable -import Data.Typeable -import Text.Read (readMaybe) -import Network.Socket hiding (Connected, connect, listen) -import Network.Socket.ByteString as BS -import Network.URI -import System.Timeout - -import Network.BitTorrent.Tracker.Message - -{----------------------------------------------------------------------- --- Options ------------------------------------------------------------------------} - --- | 'System.Timeout.timeout' specific. -sec :: Int -sec = 1000000 - --- | See -defMinTimeout :: Int -defMinTimeout = 15 - --- | See -defMaxTimeout :: Int -defMaxTimeout = 15 * 2 ^ (8 :: Int) - --- | See: -defMultiplier :: Int -defMultiplier = 2 - --- TODO why 98? -defMaxPacketSize :: Int -defMaxPacketSize = 98 - --- | Manager configuration. -data Options = Options - { -- | Max size of a /response/ packet. - -- - -- 'optMaxPacketSize' /must/ be a positive value. - -- - optMaxPacketSize :: {-# UNPACK #-} !Int - - -- | Starting timeout interval in seconds. If a response is not - -- received after 'optMinTimeout' then 'Manager' repeat RPC with - -- timeout interval multiplied by 'optMultiplier' and so on until - -- timeout interval reach 'optMaxTimeout'. - -- - -- 'optMinTimeout' /must/ be a positive value. - -- - , optMinTimeout :: {-# UNPACK #-} !Int - - -- | Final timeout interval in seconds. After 'optMaxTimeout' - -- reached and tracker still not responding both 'announce' and - -- 'scrape' functions will throw 'TimeoutExpired' exception. - -- - -- 'optMaxTimeout' /must/ be greater than 'optMinTimeout'. - -- - , optMaxTimeout :: {-# UNPACK #-} !Int - - -- | 'optMultiplier' /must/ be a positive value. - , optMultiplier :: {-# UNPACK #-} !Int - } deriving (Show, Eq) - --- | Options suitable for bittorrent client. -instance Default Options where - def = Options - { optMaxPacketSize = defMaxPacketSize - , optMinTimeout = defMinTimeout - , optMaxTimeout = defMaxTimeout - , optMultiplier = defMultiplier - } - -checkOptions :: Options -> IO () -checkOptions Options {..} = do - unless (optMaxPacketSize > 0) $ do - throwIO $ userError "optMaxPacketSize must be positive" - - unless (optMinTimeout > 0) $ do - throwIO $ userError "optMinTimeout must be positive" - - unless (optMaxTimeout > 0) $ do - throwIO $ userError "optMaxTimeout must be positive" - - unless (optMultiplier > 0) $ do - throwIO $ userError "optMultiplier must be positive" - - unless (optMaxTimeout > optMinTimeout) $ do - throwIO $ userError "optMaxTimeout must be greater than optMinTimeout" - - -{----------------------------------------------------------------------- --- Manager state ------------------------------------------------------------------------} - -type ConnectionCache = Map SockAddr Connection - -type PendingResponse = MVar (Either RpcException Response) -type PendingTransactions = Map TransactionId PendingResponse -type PendingQueries = Map SockAddr PendingTransactions - --- | UDP tracker manager. -data Manager = Manager - { options :: !Options - , sock :: !Socket --- , dnsCache :: !(IORef (Map URI SockAddr)) - , connectionCache :: !(IORef ConnectionCache) - , pendingResps :: !(MVar PendingQueries) - , listenerThread :: !(MVar ThreadId) - } - -initManager :: Options -> IO Manager -initManager opts = Manager opts - <$> socket AF_INET Datagram defaultProtocol - <*> newIORef M.empty - <*> newMVar M.empty - <*> newEmptyMVar - -unblockAll :: PendingQueries -> IO () -unblockAll m = traverse (traverse unblockCall) m >> return () - where - unblockCall ares = putMVar ares (Left ManagerClosed) - -resetState :: Manager -> IO () -resetState Manager {..} = do - writeIORef connectionCache err - m <- swapMVar pendingResps err - unblockAll m - mtid <- tryTakeMVar listenerThread - case mtid of - Nothing -> return () -- thread killed by 'closeManager' - Just _ -> return () -- thread killed by exception from 'listen' - return () - where - err = error "UDP tracker manager closed" - --- | This function will throw 'IOException' on invalid 'Options'. -newManager :: Options -> IO Manager -newManager opts = do - checkOptions opts - mgr <- initManager opts - tid <- forkIO (listen mgr `finally` resetState mgr) - putMVar (listenerThread mgr) tid - return mgr - --- | Unblock all RPCs by throwing 'ManagerClosed' exception. No rpc --- calls should be performed after manager becomes closed. -closeManager :: Manager -> IO () -closeManager Manager {..} = do - close sock - mtid <- tryTakeMVar listenerThread - case mtid of - Nothing -> return () - Just tid -> killThread tid - --- | Normally you need to use 'Control.Monad.Trans.Resource.allocate'. -withManager :: Options -> (Manager -> IO a) -> IO a -withManager opts = bracket (newManager opts) closeManager - -{----------------------------------------------------------------------- --- Exceptions ------------------------------------------------------------------------} - -data RpcException - -- | Unable to lookup hostname; - = HostUnknown - - -- | Unable to lookup hostname; - | HostLookupFailed - - -- | Expecting 'udp:', but some other scheme provided. - | UnrecognizedScheme String - - -- | Tracker exists but not responding for specific number of seconds. - | TimeoutExpired Int - - -- | Tracker responded with unexpected message type. - | UnexpectedResponse - { expectedMsg :: String - , actualMsg :: String - } - - -- | RPC succeed, but tracker responded with error code. - | QueryFailed Text - - -- | RPC manager closed while waiting for response. - | ManagerClosed - deriving (Eq, Show, Typeable) - -instance Exception RpcException - -{----------------------------------------------------------------------- --- Host Addr resolution ------------------------------------------------------------------------} - -setPort :: PortNumber -> SockAddr -> SockAddr -setPort p (SockAddrInet _ h) = SockAddrInet p h -setPort p (SockAddrInet6 _ f h s) = SockAddrInet6 p f h s -setPort _ addr = addr - -resolveURI :: URI -> IO SockAddr -resolveURI URI { uriAuthority = Just (URIAuth {..}) } = do - infos <- getAddrInfo Nothing (Just uriRegName) Nothing - let port = fromMaybe 0 (readMaybe (L.drop 1 uriPort) :: Maybe Int) - case infos of - AddrInfo {..} : _ -> return $ setPort (fromIntegral port) addrAddress - _ -> throwIO HostLookupFailed -resolveURI _ = throwIO HostUnknown - --- TODO caching? -getTrackerAddr :: Manager -> URI -> IO SockAddr -getTrackerAddr _ uri - | uriScheme uri == "udp:" = resolveURI uri - | otherwise = throwIO (UnrecognizedScheme (uriScheme uri)) - -{----------------------------------------------------------------------- - Connection ------------------------------------------------------------------------} - -connectionLifetime :: NominalDiffTime -connectionLifetime = 60 - -data Connection = Connection - { connectionId :: ConnectionId - , connectionTimestamp :: UTCTime - } deriving Show - --- placeholder for the first 'connect' -initialConnection :: Connection -initialConnection = Connection initialConnectionId (posixSecondsToUTCTime 0) - -establishedConnection :: ConnectionId -> IO Connection -establishedConnection cid = Connection cid <$> getCurrentTime - -isExpired :: Connection -> IO Bool -isExpired Connection {..} = do - currentTime <- getCurrentTime - let timeDiff = diffUTCTime currentTime connectionTimestamp - return $ timeDiff > connectionLifetime - -{----------------------------------------------------------------------- --- Transactions ------------------------------------------------------------------------} - --- | Sometimes 'genTransactionId' may return already used transaction --- id. We use a good entropy source but the issue /still/ (with very --- small probabality) may happen. If the collision happen then this --- function tries to find nearest unused slot, otherwise pending --- transactions table is full. -firstUnused :: SockAddr -> TransactionId -> PendingQueries -> TransactionId -firstUnused addr rid m = do - case M.splitLookup rid <$> M.lookup addr m of - Nothing -> rid - Just (_ , Nothing, _ ) -> rid - Just (lt, Just _ , gt) -> - case backwardHole (keys lt) rid <|> forwardHole rid (keys gt) of - Nothing -> error "firstUnused: table is full" -- impossible - Just tid -> tid - where - forwardHole a [] - | a == maxBound = Nothing - | otherwise = Just (succ a) - forwardHole a (b : xs) - | succ a == b = forwardHole b xs - | otherwise = Just (succ a) - - backwardHole [] a - | a == minBound = Nothing - | otherwise = Just (pred a) - backwardHole (b : xs) a - | b == pred a = backwardHole xs b - | otherwise = Just (pred a) - -register :: SockAddr -> TransactionId -> PendingResponse - -> PendingQueries -> PendingQueries -register addr tid ares = M.alter insertId addr - where - insertId Nothing = Just (M.singleton tid ares) - insertId (Just m) = Just (M.insert tid ares m) - -unregister :: SockAddr -> TransactionId - -> PendingQueries -> PendingQueries -unregister addr tid = M.update deleteId addr - where - deleteId m - | M.null m' = Nothing - | otherwise = Just m' - where - m' = M.delete tid m - --- | Generate a new unused transaction id and register as pending. -allocTransaction :: Manager -> SockAddr -> PendingResponse -> IO TransactionId -allocTransaction Manager {..} addr ares = - modifyMVar pendingResps $ \ m -> do - rndId <- genTransactionId - let tid = firstUnused addr rndId m - return (register addr tid ares m, tid) - --- | Wake up blocked thread and return response back. -commitTransaction :: Manager -> SockAddr -> TransactionId -> Response -> IO () -commitTransaction Manager {..} addr tid resp = - modifyMVarMasked_ pendingResps $ \ m -> do - case M.lookup tid =<< M.lookup addr m of - Nothing -> return m -- tracker responded after 'cancelTransaction' fired - Just ares -> do - putMVar ares (Right resp) - return $ unregister addr tid m - --- | Abort transaction forcefully. -cancelTransaction :: Manager -> SockAddr -> TransactionId -> IO () -cancelTransaction Manager {..} addr tid = - modifyMVarMasked_ pendingResps $ \m -> - return $ unregister addr tid m - --- | Handle responses from trackers. -listen :: Manager -> IO () -listen mgr @ Manager {..} = do - forever $ do - (bs, addr) <- BS.recvFrom sock (optMaxPacketSize options) - case decode bs of - Left _ -> return () -- parser failed, ignoring - Right (TransactionR {..}) -> commitTransaction mgr addr transIdR response - --- | Perform RPC transaction. If the action interrupted transaction --- will be aborted. -transaction :: Manager -> SockAddr -> Connection -> Request -> IO Response -transaction mgr @ Manager {..} addr conn request = do - ares <- newEmptyMVar - tid <- allocTransaction mgr addr ares - performTransaction tid ares - `onException` cancelTransaction mgr addr tid - where - performTransaction tid ares = do - let trans = TransactionQ (connectionId conn) tid request - BS.sendAllTo sock (encode trans) addr - takeMVar ares >>= either throwIO return - -{----------------------------------------------------------------------- --- Connection cache ------------------------------------------------------------------------} - -connect :: Manager -> SockAddr -> Connection -> IO ConnectionId -connect m addr conn = do - resp <- transaction m addr conn Connect - case resp of - Connected cid -> return cid - Failed msg -> throwIO $ QueryFailed msg - _ -> throwIO $ UnexpectedResponse "connected" (responseName resp) - -newConnection :: Manager -> SockAddr -> IO Connection -newConnection m addr = do - connId <- connect m addr initialConnection - establishedConnection connId - -refreshConnection :: Manager -> SockAddr -> Connection -> IO Connection -refreshConnection mgr addr conn = do - expired <- isExpired conn - if expired - then do - connId <- connect mgr addr conn - establishedConnection connId - else do - return conn - -withCache :: Manager -> SockAddr - -> (Maybe Connection -> IO Connection) -> IO Connection -withCache mgr addr action = do - cache <- readIORef (connectionCache mgr) - conn <- action (M.lookup addr cache) - writeIORef (connectionCache mgr) (M.insert addr conn cache) - return conn - -getConnection :: Manager -> SockAddr -> IO Connection -getConnection mgr addr = withCache mgr addr $ - maybe (newConnection mgr addr) (refreshConnection mgr addr) - -{----------------------------------------------------------------------- --- RPC ------------------------------------------------------------------------} - -retransmission :: Options -> IO a -> IO a -retransmission Options {..} action = go optMinTimeout - where - go curTimeout - | curTimeout > optMaxTimeout = throwIO $ TimeoutExpired curTimeout - | otherwise = do - r <- timeout (curTimeout * sec) action - maybe (go (optMultiplier * curTimeout)) return r - -queryTracker :: Manager -> URI -> Request -> IO Response -queryTracker mgr uri req = do - addr <- getTrackerAddr mgr uri - retransmission (options mgr) $ do - conn <- getConnection mgr addr - transaction mgr addr conn req - --- | This function can throw 'RpcException'. -announce :: Manager -> URI -> AnnounceQuery -> IO AnnounceInfo -announce mgr uri q = do - resp <- queryTracker mgr uri (Announce q) - case resp of - Announced info -> return info - _ -> throwIO $ UnexpectedResponse "announce" (responseName resp) - --- | This function can throw 'RpcException'. -scrape :: Manager -> URI -> ScrapeQuery -> IO ScrapeInfo -scrape mgr uri ihs = do - resp <- queryTracker mgr uri (Scrape ihs) - case resp of - Scraped info -> return $ L.zip ihs info - _ -> throwIO $ UnexpectedResponse "scrape" (responseName resp) diff --git a/bittorrent/src/Network/BitTorrent/Tracker/Session.hs b/bittorrent/src/Network/BitTorrent/Tracker/Session.hs deleted file mode 100644 index db6ebaff..00000000 --- a/bittorrent/src/Network/BitTorrent/Tracker/Session.hs +++ /dev/null @@ -1,306 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2014 --- License : BSD --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- Multitracker sessions. --- -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TemplateHaskell #-} -module Network.BitTorrent.Tracker.Session - ( -- * Session - Session - , Event (..) - , newSession - , closeSession - , withSession - - -- * Client send notifications - , notify - , askPeers - - -- * Session state - -- ** Status - , Status (..) - , getStatus - - -- ** Single tracker sessions - , LastScrape (..) - , TrackerSession - , trackerPeers - , trackerScrape - , getSessionState - - -- * Tracker Exchange - -- | BEP28: - , addTracker - , removeTracker - , getTrustedTrackers - ) where - -import Control.Applicative -import Control.Exception -import Control.Concurrent -import Control.Concurrent.Chan.Split as CS -import Control.Monad -import Data.Default -import Data.Fixed -import Data.Foldable as F -import Data.IORef -import Data.List as L -import Data.Maybe -import Data.Time -import Data.Traversable -import Network.URI - -import Data.Torrent -import Network.Address -import Network.BitTorrent.Internal.Cache -import Network.BitTorrent.Internal.Types -import Network.BitTorrent.Tracker.List as TL -import Network.BitTorrent.Tracker.Message -import Network.BitTorrent.Tracker.RPC as RPC - -{----------------------------------------------------------------------- --- Single tracker session ------------------------------------------------------------------------} - --- | Status of this client. -data Status - = Running -- ^ This client is announced and listenning for incoming - -- connections. - | Paused -- ^ This client does not expecting incoming connections. - deriving (Show, Eq, Bounded, Enum) - --- | Client starting in the paused state. -instance Default Status where - def = Paused - --- | Tracker session starts with scrape unknown. -instance Default LastScrape where - def = LastScrape Nothing Nothing - -data LastScrape = LastScrape - { -- | Count of leechers the tracker aware of. - scrapeLeechers :: Maybe Int - - -- | Count of seeders the tracker aware of. - , scrapeSeeders :: Maybe Int - } deriving (Show, Eq) - --- | Single tracker session. -data TrackerSession = TrackerSession - { -- | Used to notify 'Stopped' and 'Completed' events. - statusSent :: !(Maybe Status) - - -- | Can be used to retrieve peer set. - , trackerPeers :: Cached [PeerAddr] - - -- | Can be used to show brief swarm stats in client GUI. - , trackerScrape :: Cached LastScrape - } - --- | Not contacted. -instance Default TrackerSession where - def = TrackerSession Nothing def def - --- | Do we need to notify this /specific/ tracker? -needNotify :: AnnounceEvent -> Maybe Status -> Maybe Bool -needNotify Started Nothing = Just True -needNotify Stopped Nothing = Just False -needNotify Completed Nothing = Just False -needNotify Started (Just Running) = Nothing -needNotify Stopped (Just Running) = Just True -needNotify Completed (Just Running) = Just True -needNotify Started (Just Paused ) = Just True -needNotify Stopped (Just Paused ) = Just False -needNotify Completed (Just Paused ) = Just True - --- | Client status after event announce succeed. -nextStatus :: AnnounceEvent -> Maybe Status -nextStatus Started = Just Running -nextStatus Stopped = Just Paused -nextStatus Completed = Nothing -- must keep previous status - -seconds :: Int -> NominalDiffTime -seconds n = realToFrac (toEnum n :: Uni) - -cachePeers :: AnnounceInfo -> IO (Cached [PeerAddr]) -cachePeers AnnounceInfo {..} = - newCached (seconds respInterval) - (seconds (fromMaybe respInterval respMinInterval)) - (getPeerList respPeers) - -cacheScrape :: AnnounceInfo -> IO (Cached LastScrape) -cacheScrape AnnounceInfo {..} = - newCached (seconds respInterval) - (seconds (fromMaybe respInterval respMinInterval)) - LastScrape - { scrapeSeeders = respComplete - , scrapeLeechers = respIncomplete - } - --- | Make announce request to specific tracker returning new state. -notifyTo :: Manager -> Session -> AnnounceEvent - -> TierEntry TrackerSession -> IO TrackerSession -notifyTo mgr s @ Session {..} event (uri, entry @ TrackerSession {..}) = do - let shouldNotify = needNotify event statusSent - mustNotify <- maybe (isExpired trackerPeers) return shouldNotify - if not mustNotify - then return entry - else do - let q = SAnnounceQuery sessionTopic def Nothing (Just event) - res <- RPC.announce mgr uri q - when (statusSent == Nothing) $ do - send sessionEvents (TrackerConfirmed uri) - send sessionEvents (AnnouncedTo uri) - let status' = nextStatus event <|> statusSent - TrackerSession status' <$> cachePeers res <*> cacheScrape res - -{----------------------------------------------------------------------- --- Multitracker Session ------------------------------------------------------------------------} - --- | Multitracker session. -data Session = Session - { -- | Infohash to announce at each 'announce' request. - sessionTopic :: !InfoHash - - -- | Current status of this client is used to filter duplicated - -- notifications, for e.g. we don't want to notify a tracker with - -- ['Stopped', 'Stopped'], the last should be ignored. - , sessionStatus :: !(IORef Status) - - -- | A set of single-tracker sessions. Any request to a tracker - -- must take a lock. - , sessionTrackers :: !(MVar (TrackerList TrackerSession)) - - , sessionEvents :: !(SendPort (Event Session)) - } - -instance EventSource Session where - data Event Session - = TrackerAdded URI - | TrackerConfirmed URI - | TrackerRemoved URI - | AnnouncedTo URI - | SessionClosed - - listen Session {..} = CS.listen sessionEvents - - --- | Create a new multitracker session in paused state. Tracker list --- must contant only /trusted/ tracker uris. To start announcing --- client presence use 'notify'. -newSession :: InfoHash -> TrackerList () -> IO Session -newSession ih origUris = do - urisList <- shuffleTiers origUris - statusRef <- newIORef def - entriesVar <- newMVar (fmap (const def) urisList) - eventStream <- newSendPort - return Session - { sessionTopic = ih - , sessionStatus = statusRef - , sessionTrackers = entriesVar - , sessionEvents = eventStream - } - --- | Release scarce resources associated with the given session. This --- function block until all trackers tied with this peer notified with --- 'Stopped' event. -closeSession :: Manager -> Session -> IO () -closeSession m s @ Session {..} = do - notify m s Stopped - send sessionEvents SessionClosed - -{----------------------------------------------------------------------- --- Operations ------------------------------------------------------------------------} - --- | Normally you need to use 'Control.Monad.Trans.Resource.alloc'. -withSession :: Manager -> InfoHash -> TrackerList () - -> (Session -> IO ()) -> IO () -withSession m ih uris = bracket (newSession ih uris) (closeSession m) - --- | Get last announced status. The only action can alter this status --- is 'notify'. -getStatus :: Session -> IO Status -getStatus Session {..} = readIORef sessionStatus - -getSessionState :: Session -> IO [[TierEntry TrackerSession]] -getSessionState Session {..} = TL.toList <$> readMVar sessionTrackers - --- | Do we need to sent this event to a first working tracker or to --- the all known good trackers? -allNotify :: AnnounceEvent -> Bool -allNotify Started = False -allNotify Stopped = True -allNotify Completed = True - -notifyAll :: Manager -> Session -> AnnounceEvent -> IO () -notifyAll mgr s @ Session {..} event = do - modifyMVar_ sessionTrackers $ - (traversal (notifyTo mgr s event)) - where - traversal - | allNotify event = traverseAll - | otherwise = traverseTiers - --- TODO send notifications to tracker periodically. --- | --- --- This function /may/ block until tracker query proceed. -notify :: Manager -> Session -> AnnounceEvent -> IO () -notify mgr ses event = do - prevStatus <- atomicModifyIORef (sessionStatus ses) $ \ s -> - (fromMaybe s (nextStatus event), s) - when (needNotify event (Just prevStatus) == Just True) $ do - notifyAll mgr ses event - --- TODO run announce if sesion have no peers --- | The returned list of peers can have duplicates. --- This function /may/ block. Use async if needed. -askPeers :: Manager -> Session -> IO [PeerAddr] -askPeers _mgr ses = do - list <- readMVar (sessionTrackers ses) - L.concat <$> collect (tryTakeData . trackerPeers) list - -collect :: (a -> IO (Maybe b)) -> TrackerList a -> IO [b] -collect f lst = (catMaybes . F.toList) <$> traverse f lst - ---sourcePeers :: Session -> Source (PeerAddr IP) ---sourcePeers - -{----------------------------------------------------------------------- --- Tracker exchange ------------------------------------------------------------------------} - --- Trackers discovered through this protocol SHOULD be treated with a --- certain amount of suspicion. Since the source of a tracker exchange --- message cannot be trusted, an implementation SHOULD have a lower --- number of retries before giving up entirely. - -addTracker :: Session -> URI -> IO () -addTracker Session {..} uri = do - undefined - send sessionEvents (TrackerAdded uri) - -removeTracker :: Manager -> Session -> URI -> IO () -removeTracker m Session {..} uri = do - send sessionEvents (TrackerRemoved uri) - --- Also, as specified under the definitions section, a tracker that --- has not worked should never be propagated to other peers over the --- tracker exchange protocol. - --- | Return all known trackers. -getTrackers :: Session -> IO [URI] -getTrackers = undefined - --- | Return trackers from torrent file and -getTrustedTrackers :: Session -> IO [URI] -getTrustedTrackers = undefined diff --git a/bittorrent/src/System/Torrent/FileMap.hs b/bittorrent/src/System/Torrent/FileMap.hs deleted file mode 100644 index 38c475e8..00000000 --- a/bittorrent/src/System/Torrent/FileMap.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS -fno-warn-orphans #-} -module System.Torrent.FileMap - ( FileMap - - -- * Construction - , Mode (..) - , def - , mmapFiles - , unmapFiles - - -- * Query - , System.Torrent.FileMap.size - - -- * Modification - , readBytes - , writeBytes - , unsafeReadBytes - - -- * Unsafe conversions - , fromLazyByteString - , toLazyByteString - ) where - -import Control.Applicative -import Control.Monad as L -import Data.ByteString as BS -import Data.ByteString.Internal as BS -import Data.ByteString.Lazy as BL -import Data.ByteString.Lazy.Internal as BL -import Data.Default -import Data.Vector as V -- TODO use unboxed vector -import Foreign -import System.IO.MMap - -import Data.Torrent - - -data FileEntry = FileEntry - { filePosition :: {-# UNPACK #-} !FileOffset - , fileBytes :: {-# UNPACK #-} !BS.ByteString -- XXX: mutable buffer (see 'writeBytes'). - } deriving (Show, Eq) - -type FileMap = Vector FileEntry - -instance Default Mode where - def = ReadWriteEx - -mmapFiles :: Mode -> FileLayout FileSize -> IO FileMap -mmapFiles mode layout = V.fromList <$> L.mapM mkEntry (accumPositions layout) - where - mkEntry (path, (pos, expectedSize)) = do - let esize = fromIntegral expectedSize -- FIXME does this safe? - (fptr, moff, msize) <- mmapFileForeignPtr path mode $ Just (0, esize) - if msize /= esize - then error "mmapFiles" -- TODO unmap mapped files on exception - else return $ FileEntry pos (PS fptr moff msize) - -unmapFiles :: FileMap -> IO () -unmapFiles = V.mapM_ unmapEntry - where - unmapEntry (FileEntry _ (PS fptr _ _)) = finalizeForeignPtr fptr - --- Unsafe: FileMap 'writeBytes' will modify supplied bytestrings in place. -fromLazyByteString :: BL.ByteString -> FileMap -fromLazyByteString lbs = V.unfoldr f (0, lbs) - where - f (_, Empty ) = Nothing - f (pos, Chunk x xs) = Just (FileEntry pos x, ((pos + chunkSize), xs)) - where chunkSize = fromIntegral $ BS.length x - --- | /O(n)/. --- --- Unsafe: mutable buffers are returned without copy. -toLazyByteString :: FileMap -> BL.ByteString -toLazyByteString = V.foldr f Empty - where - f FileEntry {..} bs = Chunk fileBytes bs - --- | /O(1)/. -size :: FileMap -> FileOffset -size m - | V.null m = 0 - | FileEntry {..} <- V.unsafeLast m - = filePosition + fromIntegral (BS.length fileBytes) - --- | Find the file number for a particular byte offset within a torrent. -bsearch :: FileOffset -> FileMap -> Maybe Int -bsearch x m - | V.null m = Nothing - | otherwise = branch (V.length m `div` 2) - where - branch c @ ((m !) -> FileEntry {..}) - | x < filePosition = bsearch x (V.take c m) - | x >= filePosition + fileSize = do - ix <- bsearch x (V.drop (succ c) m) - return $ succ c + ix - | otherwise = Just c - where - fileSize = fromIntegral (BS.length fileBytes) - --- | /O(log n)/. -drop :: FileOffset -> FileMap -> (FileSize, FileMap) -drop off m - | Just ix <- bsearch off m - , FileEntry {..} <- m ! ix = (off - filePosition, V.drop ix m) - | otherwise = (0 , V.empty) - --- | /O(log n)/. -take :: FileSize -> FileMap -> (FileMap, FileSize) -take len m - | len >= s = (m , 0) - | Just ix <- bsearch (pred len) m = let m' = V.take (succ ix) m - in (m', System.Torrent.FileMap.size m' - len) - | otherwise = (V.empty , 0) - where - s = System.Torrent.FileMap.size m - --- | /O(log n + m)/. Do not use this function with 'unmapFiles'. --- --- The returned bytestring points directly into an area memory mapped from a --- file. -unsafeReadBytes :: FileOffset -> FileSize -> FileMap -> BL.ByteString -unsafeReadBytes off s m - | (l , m') <- System.Torrent.FileMap.drop off m - , (m'', _ ) <- System.Torrent.FileMap.take (off + s) m' - = BL.take (fromIntegral s) $ BL.drop (fromIntegral l) $ toLazyByteString m'' - --- The returned bytestring is copied and safe to use after the file is --- unmapped. -readBytes :: FileOffset -> FileSize -> FileMap -> IO BL.ByteString -readBytes off s m = do - let bs_copy = BL.copy $ unsafeReadBytes off s m - forceLBS bs_copy - return bs_copy - where - forceLBS Empty = return () - forceLBS (Chunk _ x) = forceLBS x - --- UNSAFE: Uses the first byte string as a pointer to mutable data and writes --- the contents of the second bytestring there. -bscpy :: BL.ByteString -> BL.ByteString -> IO () -bscpy (PS _ _ 0 `Chunk` dest_rest) src = bscpy dest_rest src -bscpy dest (PS _ _ 0 `Chunk` src_rest) = bscpy dest src_rest -bscpy (PS dest_fptr dest_off dest_size `Chunk` dest_rest) - (PS src_fptr src_off src_size `Chunk` src_rest) - = do let csize = min dest_size src_size - withForeignPtr dest_fptr $ \dest_ptr -> - withForeignPtr src_fptr $ \src_ptr -> - memcpy (dest_ptr `advancePtr` dest_off) - (src_ptr `advancePtr` src_off) - (fromIntegral csize) -- TODO memmove? - bscpy (PS dest_fptr (dest_off + csize) (dest_size - csize) `Chunk` dest_rest) - (PS src_fptr (src_off + csize) (src_size - csize) `Chunk` src_rest) -bscpy _ _ = return () - --- UNSAFE: Mutates bytestring contents within the provided FileMap. -writeBytes :: FileOffset -> BL.ByteString -> FileMap -> IO () -writeBytes off lbs m = bscpy dest src - where - src = BL.take (fromIntegral (BL.length dest)) lbs - dest = unsafeReadBytes off (fromIntegral (BL.length lbs)) m diff --git a/bittorrent/src/System/Torrent/Storage.hs b/bittorrent/src/System/Torrent/Storage.hs deleted file mode 100644 index 1d77e55d..00000000 --- a/bittorrent/src/System/Torrent/Storage.hs +++ /dev/null @@ -1,221 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- This module implements mapping from single continious piece space --- to file storage. Storage can be used in two modes: --- --- * As in memory storage - in this case we don't touch filesystem. --- --- * As ordinary mmaped file storage - when we need to store --- data in the filesystem. --- -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DeriveDataTypeable #-} -module System.Torrent.Storage - ( -- * Storage - Storage - , StorageFailure (..) - - -- * Construction - , Mode (..) - , def - , open - , openInfoDict - , close - , withStorage - - -- * Query - , totalPieces - , verifyPiece - , genPieceInfo - , getBitfield - - -- * Modification - , writePiece - , readPiece - , hintRead - , unsafeReadPiece - - -- * Streaming - , sourceStorage - , sinkStorage - ) where - -import Control.Applicative -import Control.Exception -import Control.Monad as M -import Control.Monad.Trans -import Data.ByteString.Lazy as BL -import Data.Conduit as C -import Data.Conduit.Binary as C -import Data.Conduit.List as C -import Data.Typeable - -import Data.Torrent -import Network.BitTorrent.Exchange.Bitfield as BF -import System.Torrent.FileMap as FM - - --- | Some storage operations may throw an exception if misused. -data StorageFailure - -- | Occurs on a write operation if the storage has been opened - -- using 'ReadOnly' mode. - = StorageIsRO - - -- | Piece index is out of bounds. - | InvalidIndex PieceIx - - -- | Piece size do not match with one passed to the 'open' - -- function. - | InvalidSize PieceSize - deriving (Show, Eq, Typeable) - -instance Exception StorageFailure - --- | Pieces store. -data Storage = Storage - { mode :: !Mode - , pieceLen :: {-# UNPACK #-} !PieceSize - , fileMap :: {-# UNPACK #-} !FileMap - } - --- | Map torrent files: --- --- * when torrent first created use 'ReadWriteEx' mode; --- --- * when seeding, validation 'ReadOnly' mode. --- -open :: Mode -> PieceSize -> FileLayout FileSize -> IO Storage -open mode s l - | s <= 0 = throwIO (InvalidSize s) - | otherwise = Storage mode s <$> mmapFiles mode l - --- | Like 'open', but use 'InfoDict' file layout. -openInfoDict :: Mode -> FilePath -> InfoDict -> IO Storage -openInfoDict mode rootPath InfoDict {..} = - open mode (piPieceLength idPieceInfo) (flatLayout rootPath idLayoutInfo) - --- | Unmaps all files forcefully. It is recommended but not required. -close :: Storage -> IO () -close Storage {..} = unmapFiles fileMap - --- | Normally you need to use 'Control.Monad.Trans.Resource.allocate'. -withStorage :: Mode -> PieceSize -> FileLayout FileSize - -> (Storage -> IO ()) -> IO () -withStorage m s l = bracket (open m s l) close - --- TODO allocateStorage? - --- | Count of pieces in the storage. -totalPieces :: Storage -> PieceCount -totalPieces Storage {..} = FM.size fileMap `sizeInBase` pieceLen - -isValidIx :: PieceIx -> Storage -> Bool -isValidIx i s = 0 <= i && i < totalPieces s - --- | Put piece data at the piece index by overwriting existing --- data. --- --- This operation may throw 'StorageFailure'. --- -writePiece :: Piece BL.ByteString -> Storage -> IO () -writePiece p @ Piece {..} s @ Storage {..} - | mode == ReadOnly = throwIO StorageIsRO - | isNotValidIx pieceIndex = throwIO (InvalidIndex pieceIndex) - | isNotValidSize pieceIndex (pieceSize p) - = throwIO (InvalidSize (pieceSize p)) - | otherwise = writeBytes offset pieceData fileMap - where - isNotValidSize pix psize - | succ pix == pcount = psize /= lastPieceLen -- last piece may be shorter - | otherwise = psize /= pieceLen - where - lastPieceLen = fromIntegral (FM.size fileMap `rem` fromIntegral pieceLen) - {-# INLINE isNotValidSize #-} - - isNotValidIx i = i < 0 || i >= pcount - {-# INLINE isNotValidIx #-} - - pcount = totalPieces s - offset = fromIntegral pieceIndex * fromIntegral pieceLen - --- | Read specific piece from storage. --- --- This operation may throw 'StorageFailure'. --- -readPiece :: PieceIx -> Storage -> IO (Piece BL.ByteString) -readPiece pix s @ Storage {..} - | not (isValidIx pix s) = throwIO (InvalidIndex pix) - | otherwise = Piece pix <$> readBytes offset sz fileMap - where - offset = fromIntegral pix * fromIntegral pieceLen - sz = fromIntegral pieceLen - --- | Hint about the coming 'readPiece'. Ignores invalid indexes, for e.g.: --- --- @forall s. hindRead (-1) s == return ()@ --- -hintRead :: PieceIx -> Storage -> IO () -hintRead _pix Storage {..} = return () - --- | Zero-copy version of readPiece. Can be used only with 'ReadOnly' --- storages. -unsafeReadPiece :: PieceIx -> Storage -> IO (Piece BL.ByteString) -unsafeReadPiece pix s @ Storage {..} - | not (isValidIx pix s) = throwIO (InvalidIndex pix) - | otherwise = return $ Piece pix (unsafeReadBytes offset sz fileMap) - where - offset = fromIntegral pix * fromIntegral pieceLen - sz = fromIntegral pieceLen - --- | Stream storage pieces from first to the last. -sourceStorage :: Storage -> Source IO (Piece BL.ByteString) -sourceStorage s = go 0 - where - go pix - | pix < totalPieces s = do - piece <- liftIO $ readPiece pix s - liftIO $ hintRead (succ pix) s - yield piece - go (succ pix) - | otherwise = return () - --- | Write stream of pieces to the storage. Fail if storage is 'ReadOnly'. -sinkStorage :: Storage -> Sink (Piece BL.ByteString) IO () -sinkStorage s = do - awaitForever $ \ piece -> - liftIO $ writePiece piece s - --- | This function can be used to generate 'InfoDict' from a set of --- opened files. -genPieceInfo :: Storage -> IO PieceInfo -genPieceInfo s = do - hashes <- sourceStorage s $= C.map hashPiece $$ C.sinkLbs - return $ PieceInfo (pieceLen s) (HashList (BL.toStrict hashes)) - --- | Verify specific piece using infodict hash list. -verifyPiece :: Storage -> PieceInfo -> PieceIx -> IO Bool -verifyPiece s pinfo pix = do - piece <- unsafeReadPiece pix s - return $! checkPieceLazy pinfo piece - --- | Verify storage. --- --- Throws 'InvalidSize' if piece info size do not match with storage --- piece size. --- -getBitfield :: Storage -> PieceInfo -> IO Bitfield -getBitfield s @ Storage {..} pinfo @ PieceInfo {..} - | pieceLen /= piPieceLength = throwIO (InvalidSize piPieceLength) - | otherwise = M.foldM checkPiece (BF.haveNone total) [0..total - 1] - where - total = totalPieces s - - checkPiece :: Bitfield -> PieceIx -> IO Bitfield - checkPiece bf pix = do - valid <- verifyPiece s pinfo pix - return $ if valid then BF.insert pix bf else bf diff --git a/bittorrent/src/System/Torrent/Tree.hs b/bittorrent/src/System/Torrent/Tree.hs deleted file mode 100644 index 41cfb360..00000000 --- a/bittorrent/src/System/Torrent/Tree.hs +++ /dev/null @@ -1,83 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- Directory tree can be used to easily manipulate file layout info. --- -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveDataTypeable #-} -module System.Torrent.Tree - ( -- * Directory tree - DirTree (..) - - -- * Construction - , build - - -- * Query - , System.Torrent.Tree.lookup - , lookupDir - , fileNumber - , dirNumber - ) where - -import Data.ByteString as BS -import Data.ByteString.Char8 as BC -import Data.Foldable -import Data.List as L -import Data.Map as M -import Data.Monoid - -import Data.Torrent - - --- | 'DirTree' is more convenient form of 'LayoutInfo'. -data DirTree a = Dir { children :: Map ByteString (DirTree a) } - | File { node :: FileInfo a } - deriving Show - --- | Build directory tree from a list of files. -build :: LayoutInfo -> DirTree () -build SingleFile {liFile = FileInfo {..}} = Dir - { children = M.singleton fiName (File fi) } - where - fi = FileInfo fiLength fiMD5Sum () -build MultiFile {..} = Dir $ M.singleton liDirName files - where - files = Dir $ M.fromList $ L.map mkFileEntry liFiles - mkFileEntry FileInfo {..} = (L.head fiName, ent) -- TODO FIXME - where - ent = File $ FileInfo fiLength fiMD5Sum () - ---decompress :: DirTree () -> [FileInfo ()] ---decompress = undefined - --- TODO pretty print - --- | Lookup file by path. -lookup :: [FilePath] -> DirTree a -> Maybe (DirTree a) -lookup [] t = Just t -lookup (p : ps) (Dir m) | Just subTree <- M.lookup (BC.pack p) m - = System.Torrent.Tree.lookup ps subTree -lookup _ _ = Nothing - --- | Lookup directory by path. -lookupDir :: [FilePath] -> DirTree a -> Maybe [(ByteString, DirTree a)] -lookupDir ps d = do - subTree <- System.Torrent.Tree.lookup ps d - case subTree of - File _ -> Nothing - Dir es -> Just $ M.toList es - --- | Get total count of files in directory and subdirectories. -fileNumber :: DirTree a -> Sum Int -fileNumber File {..} = Sum 1 -fileNumber Dir {..} = foldMap fileNumber children - --- | Get total count of directories in the directory and subdirectories. -dirNumber :: DirTree a -> Sum Int -dirNumber File {..} = Sum 0 -dirNumber Dir {..} = Sum 1 <> foldMap dirNumber children diff --git a/bittorrent/tests/Config.hs b/bittorrent/tests/Config.hs deleted file mode 100644 index 55e30867..00000000 --- a/bittorrent/tests/Config.hs +++ /dev/null @@ -1,183 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE RecordWildCards #-} -module Config - ( -- * Types - ClientName - , ClientOpts (..) - , EnvOpts (..) - - -- * For test suite driver - , getOpts - - -- * For item specs - , getEnvOpts - , getThisOpts - , getMyAddr - - , getRemoteOpts - , withRemote - , withRemoteAddr - - , getTestTorrent - ) where - -import Control.Monad -import Network -import Data.Default -import Data.IORef -import Data.List as L -import Data.Maybe -import Options.Applicative -import System.Exit -import System.Environment -import System.IO.Unsafe -import Test.Hspec - -import Data.Torrent -import Network.BitTorrent.Address (IP, PeerAddr (PeerAddr), genPeerId) - - -type ClientName = String - - -#if !MIN_VERSION_network(2,6,3) -instance Read PortNumber where - readsPrec = error "readsPrec" -#endif - -data ClientOpts = ClientOpts - { peerPort :: PortNumber -- tcp port - , nodePort :: PortNumber -- udp port - } - -instance Default ClientOpts where - def = ClientOpts - { peerPort = 6881 - , nodePort = 6881 - } - -defRemoteOpts :: ClientOpts -defRemoteOpts = def - -defThisOpts :: ClientOpts -defThisOpts = def - { peerPort = 6882 - , nodePort = 6882 - } - -clientOptsParser :: Parser ClientOpts -clientOptsParser = ClientOpts - <$> option auto - ( long "peer-port" <> short 'p' - <> value 6881 <> showDefault - <> metavar "NUM" - <> help "port to bind the specified bittorrent client" - ) - <*> option auto - ( long "node-port" <> short 'n' - <> value 6881 <> showDefault - <> metavar "NUM" - <> help "port to bind node of the specified client" - ) - -data EnvOpts = EnvOpts - { testClient :: Maybe ClientName - , testTorrents :: [FilePath] - , remoteOpts :: ClientOpts - , thisOpts :: ClientOpts - } - -instance Default EnvOpts where - def = EnvOpts - { testClient = Just "rtorrent" - , testTorrents = ["testfile.torrent"] - , remoteOpts = defRemoteOpts - , thisOpts = defThisOpts - } - -findConflicts :: EnvOpts -> [String] -findConflicts EnvOpts {..} - | isNothing testClient = [] - | peerPort remoteOpts == peerPort thisOpts = ["Peer port the same"] - | nodePort remoteOpts == nodePort thisOpts = ["Node port the same"] - | otherwise = [] - - -envOptsParser :: Parser EnvOpts -envOptsParser = EnvOpts - <$> optional (strOption - ( long "bittorrent-client" - <> metavar "CLIENT" - <> help "torrent client to run" - )) - <*> pure [] - <*> clientOptsParser - <*> clientOptsParser - -envOptsInfo :: ParserInfo EnvOpts -envOptsInfo = info (helper <*> envOptsParser) - ( fullDesc - <> progDesc "The bittorrent library testsuite" - <> header "" - ) - --- do not modify this while test suite is running because spec items --- can run in parallel -envOptsRef :: IORef EnvOpts -envOptsRef = unsafePerformIO (newIORef def) - --- | Should be used from spec items. -getEnvOpts :: IO EnvOpts -getEnvOpts = readIORef envOptsRef - -getThisOpts :: IO ClientOpts -getThisOpts = thisOpts <$> getEnvOpts - --- | Return 'Nothing' if remote client is not running. -getRemoteOpts :: IO (Maybe ClientOpts) -getRemoteOpts = do - EnvOpts {..} <- getEnvOpts - return $ const remoteOpts <$> testClient - -withRemote :: (ClientOpts -> Expectation) -> Expectation -withRemote action = do - mopts <- getRemoteOpts - case mopts of - Nothing -> pendingWith "Remote client isn't running" - Just opts -> action opts - -withRemoteAddr :: (PeerAddr IP -> Expectation) -> Expectation -withRemoteAddr action = do - withRemote $ \ ClientOpts {..} -> - action (PeerAddr Nothing "0.0.0.0" peerPort) - -getMyAddr :: IO (PeerAddr (Maybe IP)) -getMyAddr = do - ClientOpts {..} <- getThisOpts - pid <- genPeerId - return $ PeerAddr (Just pid) Nothing peerPort - -getTestTorrent :: IO Torrent -getTestTorrent = do - EnvOpts {..} <- getEnvOpts - if L.null testTorrents - then error "getTestTorrent" - else fromFile ("res/" ++ L.head testTorrents) - --- TODO fix EnvOpts parsing - --- | Should be used by test suite driver. -getOpts :: IO (EnvOpts, [String]) -getOpts = do - args <- getArgs --- case runParser SkipOpts envOptsParser args) (prefs idm) of - case (Right (def, args), ()) of - (Left err , _ctx) -> exitFailure - (Right (envOpts, hspecOpts), _ctx) -> do - let conflicts = findConflicts envOpts - unless (L.null conflicts) $ do - forM_ conflicts putStrLn - exitFailure - - writeIORef envOptsRef envOpts - return (envOpts, hspecOpts) diff --git a/bittorrent/tests/Data/TorrentSpec.hs b/bittorrent/tests/Data/TorrentSpec.hs deleted file mode 100644 index b4a280e4..00000000 --- a/bittorrent/tests/Data/TorrentSpec.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS -fno-warn-orphans #-} -module Data.TorrentSpec (spec) where -import Control.Applicative -import Data.BEncode -import Data.ByteString as BS -import Data.ByteString.Lazy as BL -import Data.Convertible -import Data.Maybe -import Data.Monoid -import Data.Time -import Network.URI -import System.FilePath -import System.Posix.Types -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Instances () - -import Data.Torrent -import Network.BitTorrent.CoreSpec () - - -pico :: Gen (Maybe NominalDiffTime) -pico = oneof - [ pure Nothing - , (Just . fromIntegral) <$> (arbitrary :: Gen Int) - ] - -instance Arbitrary COff where - arbitrary = fromIntegral <$> (arbitrary :: Gen Int) - -instance Arbitrary URIAuth where - arbitrary = URIAuth <$> arbitrary <*> arbitrary <*> arbitrary - -instance Arbitrary URI where - arbitrary - = pure $ fromJust $ parseURI "http://ietf.org/1737.txt?a=1&b=h#123" - -instance Arbitrary InfoHash where - arbitrary = do - bs <- BS.pack <$> vectorOf 20 arbitrary - pure $ either (const (error "arbitrary infohash")) id $ safeConvert bs - -instance Arbitrary a => Arbitrary (FileInfo a) where - arbitrary = FileInfo <$> arbitrary <*> arbitrary <*> arbitrary - -instance Arbitrary LayoutInfo where - arbitrary = oneof - [ SingleFile <$> arbitrary - , MultiFile <$> arbitrary <*> arbitrary - ] - -instance Arbitrary a => Arbitrary (Piece a) where - arbitrary = Piece <$> arbitrary <*> arbitrary - -instance Arbitrary HashList where - arbitrary = HashList <$> arbitrary - -instance Arbitrary PieceInfo where - arbitrary = PieceInfo <$> arbitrary <*> arbitrary - -instance Arbitrary InfoDict where - arbitrary = infoDictionary <$> arbitrary <*> arbitrary <*> arbitrary - -instance Arbitrary Torrent where - arbitrary = Torrent <$> arbitrary - <*> arbitrary <*> arbitrary <*> arbitrary - <*> pico <*> arbitrary <*> arbitrary - <*> arbitrary - <*> arbitrary <*> pure Nothing <*> arbitrary - -instance Arbitrary Magnet where - arbitrary = Magnet <$> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary <*> pure mempty - -type TestPair = (FilePath, String) - --- TODO add a few more torrents here -torrentList :: [TestPair] -torrentList = - [ ( "res" "dapper-dvd-amd64.iso.torrent" - , "0221caf96aa3cb94f0f58d458e78b0fc344ad8bf") - ] - -infohashSpec :: (FilePath, String) -> Spec -infohashSpec (filepath, expectedHash) = do - it ("should match " ++ filepath) $ do - torrent <- fromFile filepath - let actualHash = show $ idInfoHash $ tInfoDict torrent - actualHash `shouldBe` expectedHash - -magnetEncoding :: Magnet -> IO () -magnetEncoding m = parseMagnet (renderMagnet m) `shouldBe` Just m - -data T a = T - -prop_properBEncode :: Show a => BEncode a => Eq a - => T a -> a -> IO () -prop_properBEncode _ expected = actual `shouldBe` Right expected - where - actual = decode $ BL.toStrict $ encode expected - -spec :: Spec -spec = do - describe "info hash" $ do - mapM_ infohashSpec torrentList - - describe "accumPosition" $ do - it "" $ property $ \ p1 p2 p3 s1 s2 s3 -> - accumPositions [(p1, s1), (p2, s2), (p3, s3)] - `shouldBe` [(p1, (0, s1)), (p2, (s1, s2)), (p3, (s1 + s2, s3))] - - describe "FileInfo" $ do - it "properly bencoded" $ property $ - prop_properBEncode (T :: T (FileInfo BS.ByteString)) - - describe "LayoutInfo" $ do - it "properly bencoded" $ property $ - prop_properBEncode (T :: T LayoutInfo) - - describe "Torrent" $ do - it "property bencoded" $ property $ - prop_properBEncode (T :: T Torrent) - - describe "Magnet" $ do - it "properly encoded" $ property $ magnetEncoding - - it "parse base32" $ do - let magnet = "magnet:?xt=urn:btih:CT76LXJDDCH5LS2TUHKH6EUJ3NYKX4Y6" - let ih = "CT76LXJDDCH5LS2TUHKH6EUJ3NYKX4Y6" - parseMagnet magnet `shouldBe` Just (nullMagnet ih) - - it "parse base16" $ do - let magnet = "magnet:?xt=urn:btih:0123456789abcdef0123456789abcdef01234567" - let ih = "0123456789abcdef0123456789abcdef01234567" - parseMagnet magnet `shouldBe` Just (nullMagnet ih) diff --git a/bittorrent/tests/Main.hs b/bittorrent/tests/Main.hs deleted file mode 100644 index 5ed953da..00000000 --- a/bittorrent/tests/Main.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module Main where -import Control.Exception -import Control.Monad -import Data.Functor -import Data.Maybe -import System.Directory -import System.Exit -import System.Environment -import System.FilePath -import System.Process -import Text.Printf -import Test.Hspec - -import Config -import qualified Spec as Generated - - -type Command = String -type Descr = (ClientName, ClientOpts -> FilePath -> Command) - -torrents :: [FilePath] -torrents = - [ "dapper-dvd-amd64-iso.torrent" - , "pkg.torrent" - , "testfile.torrent" - ] - -rtorrentSessionDir :: String -rtorrentSessionDir = "rtorrent-sessiondir" - -sessionName :: String -- screen session name -sessionName = "bittorrent-testsuite" - -tmpDir :: FilePath -tmpDir = "res" - -clients :: [Descr] -clients = - [ ("rtorrent" - , \ ClientOpts {..} tfile -> printf - "rtorrent -p %i-%i -O dht=on -O dht_port=%i -O session=%s %s" - (fromEnum peerPort) (fromEnum peerPort) (fromEnum nodePort) - rtorrentSessionDir tfile - ) - ] - -setupEnv :: EnvOpts -> IO (Maybe ()) -setupEnv EnvOpts {..} - | Just client <- testClient - , Just mkCmd <- lookup client clients = do - _ <- printf "Setting up %s\n" client - - let torrentPath = "testfile.torrent" - let runner = printf "screen -dm -S %s %s" sessionName - (mkCmd remoteOpts torrentPath) - - wd <- getCurrentDirectory - createDirectoryIfMissing True (wd tmpDir rtorrentSessionDir) - _ <- createProcess (shell runner) { cwd = Just (wd tmpDir) } - - return (Just ()) - - | Just client <- testClient = do - _ <- printf "Bad client `%s`, use one of %s\n" client (show (fst <$> clients)) - return Nothing - - | otherwise = do - _ <- printf "Running without remote client\n" - return (Just ()) - -terminateEnv :: IO () -terminateEnv = do - wd <- getCurrentDirectory - removeDirectoryRecursive (wd tmpDir rtorrentSessionDir) - _ <- printf "closing screen session: %s\n" sessionName - _ <- system (printf "screen -S %s -X quit" sessionName) - return () - -runTestSuite :: [String] -> IO ExitCode -runTestSuite args = do - _ <- printf "running hspec test suite with args: %s\n" (show args) - catch (withArgs args (hspec Generated.spec) >> return ExitSuccess) return - -withEnv :: EnvOpts -> IO a -> IO a -withEnv opts action = bracket (setupEnv opts) terminate (const action) - where - terminate running = do - when (isJust running) $ do - terminateEnv - -main :: IO () -main = do - (envOpts, suiteArgs) <- getOpts - withEnv envOpts $ do - code <- runTestSuite suiteArgs - exitWith code diff --git a/bittorrent/tests/Network/BitTorrent/Client/HandleSpec.hs b/bittorrent/tests/Network/BitTorrent/Client/HandleSpec.hs deleted file mode 100644 index d51bab02..00000000 --- a/bittorrent/tests/Network/BitTorrent/Client/HandleSpec.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Network.BitTorrent.Client.HandleSpec (spec) where -import Data.Default -import Test.Hspec - -import Data.Torrent -import Network.BitTorrent.Client -import Network.BitTorrent.Client.Handle - -data_dir :: FilePath -data_dir = "data" - -spec :: Spec -spec = do - describe "openMagnet" $ do - it "should add new infohash to index" $ do - simpleClient $ do - _ <- openMagnet data_dir (nullMagnet def) - _ <- getHandle def - return () diff --git a/bittorrent/tests/Network/BitTorrent/CoreSpec.hs b/bittorrent/tests/Network/BitTorrent/CoreSpec.hs deleted file mode 100644 index e9b17a42..00000000 --- a/bittorrent/tests/Network/BitTorrent/CoreSpec.hs +++ /dev/null @@ -1,309 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Network.BitTorrent.CoreSpec (spec) where -import Control.Applicative -import Data.BEncode as BE -import Data.ByteString.Lazy as BL -#if MIN_VERSION_iproute(1,7,4) -import Data.IP hiding (fromSockAddr) -#else -import Data.IP -#endif -import Data.Serialize as S -import Data.String -import Data.Text.Encoding as T -import Data.Word -import Network -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Instances () - -import Network.BitTorrent.Address - - -instance Arbitrary IPv4 where - arbitrary = do - a <- choose (0, 255) - b <- choose (0, 255) - c <- choose (0, 255) - d <- choose (0, 255) - return $ toIPv4 [a, b, c, d] - -instance Arbitrary IPv6 where - arbitrary = do - a <- choose (0, fromIntegral (maxBound :: Word16)) - b <- choose (0, fromIntegral (maxBound :: Word16)) - c <- choose (0, fromIntegral (maxBound :: Word16)) - d <- choose (0, fromIntegral (maxBound :: Word16)) - e <- choose (0, fromIntegral (maxBound :: Word16)) - f <- choose (0, fromIntegral (maxBound :: Word16)) - g <- choose (0, fromIntegral (maxBound :: Word16)) - h <- choose (0, fromIntegral (maxBound :: Word16)) - return $ toIPv6 [a, b, c, d, e, f, g, h] - -instance Arbitrary IP where - arbitrary = frequency - [ (1, IPv4 <$> arbitrary) - , (1, IPv6 <$> arbitrary) - ] - -instance Arbitrary PortNumber where - arbitrary = fromIntegral <$> (arbitrary :: Gen Word16) - -instance Arbitrary PeerId where - arbitrary = oneof - [ azureusStyle defaultClientId defaultVersionNumber - <$> (T.encodeUtf8 <$> arbitrary) - , shadowStyle 'X' defaultVersionNumber - <$> (T.encodeUtf8 <$> arbitrary) - ] - -instance Arbitrary a => Arbitrary (PeerAddr a) where - arbitrary = PeerAddr <$> arbitrary <*> arbitrary <*> arbitrary - -instance Arbitrary NodeId where - arbitrary = fromString <$> vector 20 - -instance Arbitrary a => Arbitrary (NodeAddr a) where - arbitrary = NodeAddr <$> arbitrary <*> arbitrary - -instance Arbitrary a => Arbitrary (NodeInfo a) where - arbitrary = NodeInfo <$> arbitrary <*> arbitrary - -spec :: Spec -spec = do - describe "PeerId" $ do - it "properly bencoded" $ do - BE.decode "20:01234567890123456789" - `shouldBe` Right ("01234567890123456789" :: PeerId) - - describe "PortNumber" $ do - it "properly serialized" $ do - S.decode "\x1\x2" `shouldBe` Right (258 :: PortNumber) - S.encode (258 :: PortNumber) `shouldBe` "\x1\x2" - - it "properly bencoded" $ do - BE.decode "i80e" `shouldBe` Right (80 :: PortNumber) - - it "fail if port number is invalid" $ do - (BE.decode "i-10e" :: BE.Result PortNumber) - `shouldBe` - Left "fromBEncode: unable to decode PortNumber: -10" - - (BE.decode "i70000e" :: BE.Result PortNumber) - `shouldBe` - Left "fromBEncode: unable to decode PortNumber: 70000" - - describe "Peer IPv4" $ do - it "properly serialized" $ do - S.decode "\x1\x2\x3\x4" `shouldBe` Right (toIPv4 [1, 2, 3, 4]) - S.encode (toIPv4 [1, 2, 3, 4]) `shouldBe` "\x1\x2\x3\x4" - - it "properly serialized (iso)" $ property $ \ ip -> do - S.decode (S.encode ip) `shouldBe` Right (ip :: IPv4) - - it "properly bencoded" $ do - BE.decode "11:168.192.0.1" `shouldBe` Right (toIPv4 [168, 192, 0, 1]) - BE.encode (toIPv4 [168, 192, 0, 1]) `shouldBe` "11:168.192.0.1" - - it "properly bencoded (iso)" $ property $ \ ip -> - BE.decode (BL.toStrict (BE.encode ip)) `shouldBe` Right (ip :: IPv4) - - it "fail gracefully on invalid strings" $ do - BE.decode "3:1.1" `shouldBe` - (Left "fromBEncode: unable to decode IP: 1.1" :: BE.Result IPv4) - - it "fail gracefully on invalid bencode" $ do - BE.decode "i10e" `shouldBe` - (Left "fromBEncode: unable to decode IP: addr should be a bstring" - :: BE.Result IPv4) - - describe "Peer IPv6" $ do - it "properly serialized" $ do - S.decode "\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10" - `shouldBe` - Right ("102:304:506:708:90a:b0c:d0e:f10" :: IPv6) - - S.encode ("102:304:506:708:90a:b0c:d0e:f10" :: IPv6) - `shouldBe` - "\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10" - - it "properly serialized (iso)" $ property $ \ ip -> - S.decode (S.encode ip) `shouldBe` Right (ip :: IPv6) - - it "properly bencoded" $ do - BE.decode "3:::1" `shouldBe` Right (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1]) - BE.encode (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1]) `shouldBe` - "23:00:00:00:00:00:00:00:01" - - BE.decode "23:00:00:00:00:00:00:00:01" - `shouldBe` - Right (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1]) - - it "properly bencoded iso" $ property $ \ ip -> - BE.decode (BL.toStrict (BE.encode ip)) `shouldBe` Right (ip :: IPv4) - - it "fail gracefully on invalid strings" $ do - BE.decode "4:g::1" `shouldBe` - (Left "fromBEncode: unable to decode IP: g::1" :: BE.Result IPv6) - - it "fail gracefully on invalid bencode" $ do - BE.decode "i10e" `shouldBe` - (Left "fromBEncode: unable to decode IP: addr should be a bstring" - :: BE.Result IPv6) - - - describe "Peer IP" $ do - it "properly serialized IPv6" $ do - S.decode "\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10" - `shouldBe` - Right ("102:304:506:708:90a:b0c:d0e:f10" :: IP) - - S.encode ("102:304:506:708:90a:b0c:d0e:f10" :: IP) - `shouldBe` - "\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10" - - it "properly serialized (iso) IPv6" $ property $ \ ip -> - S.decode (S.encode ip) `shouldBe` Right (ip :: IP) - - it "properly serialized IPv4" $ do - S.decode "\x1\x2\x3\x4" `shouldBe` Right (IPv4 $ toIPv4 [1, 2, 3, 4]) - S.encode (toIPv4 [1, 2, 3, 4]) `shouldBe` "\x1\x2\x3\x4" - - it "properly serialized (iso) IPv4" $ property $ \ ip -> do - S.decode (S.encode ip) `shouldBe` Right (ip :: IP) - - it "properly bencoded" $ do - BE.decode "11:168.192.0.1" `shouldBe` - Right (IPv4 (toIPv4 [168, 192, 0, 1])) - - BE.decode "3:::1" `shouldBe` Right - (IPv6 (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1])) - - BE.encode (IPv6 (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1])) `shouldBe` - "23:00:00:00:00:00:00:00:01" - - BE.decode "23:00:00:00:00:00:00:00:01" - `shouldBe` - Right (IPv6 (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1])) - - it "properly bencoded iso" $ property $ \ ip -> - BE.decode (BL.toStrict (BE.encode ip)) `shouldBe` Right (ip :: IP) - - it "fail gracefully on invalid strings" $ do - BE.decode "4:g::1" `shouldBe` - (Left "fromBEncode: unable to decode IP: g::1" :: BE.Result IP) - - it "fail gracefully on invalid bencode" $ do - BE.decode "i10e" `shouldBe` - (Left "fromBEncode: unable to decode IP: addr should be a bstring" - :: BE.Result IP) - - describe "PeerAddr" $ do - it "IsString" $ do - ("127.0.0.1:80" :: PeerAddr IP) - `shouldBe` PeerAddr Nothing "127.0.0.1" 80 - - ("127.0.0.1:80" :: PeerAddr IPv4) - `shouldBe` PeerAddr Nothing "127.0.0.1" 80 - - ("[::1]:80" :: PeerAddr IP) - `shouldBe` PeerAddr Nothing "::1" 80 - - ("[::1]:80" :: PeerAddr IPv6) - `shouldBe` PeerAddr Nothing "::1" 80 - - it "properly bencoded (iso)" $ property $ \ addr -> - BE.decode (BL.toStrict (BE.encode addr)) - `shouldBe` Right (addr :: PeerAddr IP) - - - it "properly bencoded (ipv4)" $ do - BE.decode "d2:ip11:168.192.0.1\ - \7:peer id20:01234567890123456789\ - \4:porti6881e\ - \e" - `shouldBe` - Right (PeerAddr (Just "01234567890123456789") - (IPv4 (toIPv4 [168, 192, 0, 1])) - 6881) - - it "properly bencoded (ipv6)" $ do - BE.decode "d2:ip3:::1\ - \7:peer id20:01234567890123456789\ - \4:porti6881e\ - \e" - `shouldBe` - Right (PeerAddr (Just "01234567890123456789") - (IPv6 (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1])) - 6881) - - it "peer id is optional" $ do - BE.decode "d2:ip11:168.192.0.1\ - \4:porti6881e\ - \e" - `shouldBe` - Right (PeerAddr Nothing (IPv4 (toIPv4 [168, 192, 0, 1])) 6881) - - it "has sock addr for both ipv4 and ipv6" $ do - show (peerSockAddr "128.0.0.1:80") `shouldBe` "128.0.0.1:80" - show (peerSockAddr "[::1]:8080" ) `shouldBe` "[::1]:8080" - - describe "NodeId" $ do - it "properly serialized" $ do - S.decode "mnopqrstuvwxyz123456" - `shouldBe` Right ("mnopqrstuvwxyz123456" :: NodeId) - - S.encode ("mnopqrstuvwxyz123456" :: NodeId) - `shouldBe` "mnopqrstuvwxyz123456" - - it "properly serialized (iso)" $ property $ \ nid -> - S.decode (S.encode nid) `shouldBe` - Right (nid :: NodeId) - - describe "NodeAddr" $ do - it "properly serialized" $ do - S.decode "\127\0\0\1\1\2" `shouldBe` - Right ("127.0.0.1:258" :: NodeAddr IPv4) - - it "properly serialized (iso)" $ property $ \ nid -> - S.decode (S.encode nid) `shouldBe` - Right (nid :: NodeAddr IPv4) - - describe "NodeInfo" $ do - it "properly serialized" $ do - S.decode "mnopqrstuvwxyz123456\ - \\127\0\0\1\1\2" `shouldBe` Right - (NodeInfo "mnopqrstuvwxyz123456" "127.0.0.1:258" :: NodeInfo IPv4) - - it "properly serialized (iso)" $ property $ \ nid -> - S.decode (S.encode nid) `shouldBe` - Right (nid :: NodeInfo IPv4) - - -- see - describe "Fingerprint" $ do - it "decode mainline encoded peer id" $ do - fingerprint "M4-3-6--xxxxxxxxxxxx" `shouldBe` "Mainline-4.3.6" - fingerprint "M4-20-8-xxxxxxxxxxxx" `shouldBe` "Mainline-4.20.8" - - it "decode azureus encoded peer id" $ do - fingerprint "-AZ2060-xxxxxxxxxxxx" `shouldBe` "Azureus-2060" - fingerprint "-BS0000-xxxxxxxxxxxx" `shouldBe` "BTSlave-0" - - it "decode Shad0w style peer id" $ do - fingerprint "S58B-----xxxxxxxxxxx" `shouldBe` "Shadow-5.8.11" - fingerprint "T58B-----xxxxxxxxxxx" `shouldBe` "BitTornado-5.8.11" - - it "decode bitcomet style peer id" $ do - fingerprint "exbc01xxxxxxxxxxxxxx" `shouldBe` "BitComet-48.49" - fingerprint "FUTB01xxxxxxxxxxxxxx" `shouldBe` "BitComet-48.49" - fingerprint "exbc01LORDxxxxxxxxxx" `shouldBe` "BitLord-48.49" - - it "decode opera style peer id" $ do - fingerprint "OP0123xxxxxxxxxxxxxx" `shouldBe` "Opera-123" - - it "decode ML donkey style peer id" $ do - fingerprint "-ML2.7.2-xxxxxxxxxxx" `shouldBe` "MLdonkey-0" - --- TODO XBT, Bits on Wheels, Queen Bee, BitTyrant, TorrenTopia, --- BitSpirit, Rufus, G3 Torrent, FlashGet diff --git a/bittorrent/tests/Network/BitTorrent/DHT/MessageSpec.hs b/bittorrent/tests/Network/BitTorrent/DHT/MessageSpec.hs deleted file mode 100644 index 6f3c7489..00000000 --- a/bittorrent/tests/Network/BitTorrent/DHT/MessageSpec.hs +++ /dev/null @@ -1,221 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module Network.BitTorrent.DHT.MessageSpec (spec) where -import Control.Monad.Reader -import Control.Monad.Logger -import Control.Concurrent -import Data.BEncode as BE -import Data.ByteString.Lazy as BL -import Data.Default -import Data.List as L -import Data.Maybe -import Network.BitTorrent.Address -import Network.BitTorrent.DHT.Message -import qualified Network.KRPC as KRPC (def) -import Network.KRPC hiding (def) -import Network.Socket (PortNumber) -import Test.Hspec -import Test.QuickCheck -import System.Timeout - -import Data.TorrentSpec () -import Network.BitTorrent.CoreSpec () -import Network.BitTorrent.DHT.TokenSpec () - --- Arbitrary queries and responses. -instance Arbitrary Ping where arbitrary = pure Ping -instance Arbitrary FindNode where arbitrary = FindNode <$> arbitrary -instance Arbitrary ip => Arbitrary (NodeFound ip) where arbitrary = NodeFound <$> arbitrary -instance Arbitrary GetPeers where arbitrary = GetPeers <$> arbitrary -instance Arbitrary ip => Arbitrary (GotPeers ip) where arbitrary = GotPeers <$> arbitrary <*> arbitrary -instance Arbitrary Announce where arbitrary = Announce <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -instance Arbitrary Announced where arbitrary = pure Announced -instance Arbitrary x => Arbitrary (Query x) where arbitrary = Query <$> arbitrary <*> arbitrary <*> arbitrary -instance Arbitrary x => Arbitrary (Response x) where arbitrary = Response <$> arbitrary <*> arbitrary - -instance MonadLogger IO where - monadLoggerLog _ _ _ _ = return () - -remoteAddr :: SockAddr -remoteAddr = SockAddrInet 6881 (256 * 256 * 256 + 127) - -thisAddr :: SockAddr -thisAddr = SockAddrInet 60000 (256 * 256 * 256 + 127) - -thisPort :: PortNumber -thisPort = 60001 - -rpc :: ReaderT (Manager IO) IO a -> IO a -rpc action = do - withManager KRPC.def thisAddr [] $ runReaderT $ do - listen - action - -isQueryError :: QueryFailure -> Bool -isQueryError _ = True - -prop_bencode :: Eq a => Show a => BEncode a => a -> Expectation -prop_bencode x = BE.decode (BL.toStrict (BE.encode x)) `shouldBe` Right x - -retry :: Int -> IO (Maybe a) -> IO (Maybe a) -retry 0 _ = return Nothing -retry n a = do - res <- a - case res of - Just _ -> return res - Nothing -> threadDelay (100 * 1000) >> retry (n-1) a - -spec :: Spec -spec = do - context ("you need running DHT node at " ++ show remoteAddr) $ do - it "is running" $ do - running <- retry 5 $ timeout (100 * 1000) $ do - nid <- genNodeId - Response _remoteAddr Ping <- - rpc (query remoteAddr (Query nid False Ping)) - return () - running `shouldSatisfy` isJust - - describe "ping" $ do - it "properly bencoded" $ do - BE.decode "d2:id20:abcdefghij0123456789e" - `shouldBe` Right (Query "abcdefghij0123456789" False Ping) - - BE.encode (Query "abcdefghij0123456789" False Ping) - `shouldBe` "d2:id20:abcdefghij0123456789e" - - BE.decode "d2:id20:mnopqrstuvwxyz123456e" - `shouldBe` Right (Response "mnopqrstuvwxyz123456" Ping) - - BE.encode (Response "mnopqrstuvwxyz123456" Ping) - `shouldBe` "d2:id20:mnopqrstuvwxyz123456e" - - it "properly bencoded (iso)" $ property $ \ nid -> do - prop_bencode (Query nid False Ping) - prop_bencode (Response nid Ping) - - it "does compatible with existing DHT" $ do - nid <- genNodeId - Response _remoteAddr Ping <- rpc (query remoteAddr (Query nid False Ping)) - return () - - describe "find_node" $ do - it "properly bencoded" $ do - BE.decode "d2:id20:abcdefghij0123456789\ - \6:target20:mnopqrstuvwxyz123456e" - `shouldBe` Right (Query "abcdefghij0123456789" False - (FindNode "mnopqrstuvwxyz123456")) - - BE.encode (Query "abcdefghij0123456789" False - (FindNode "mnopqrstuvwxyz123456")) - `shouldBe` - "d2:id20:abcdefghij01234567896:target20:mnopqrstuvwxyz123456e" - - let naddr = "127.0.0.1:258" :: NodeAddr IPv4 - let nid = "0123456789abcdefghij" - let nid' = "mnopqrstuvwxyz123456" - BE.decode "d2:id20:0123456789abcdefghij\ - \5:nodes26:mnopqrstuvwxyz123456\127\0\0\1\1\2\ - \e" - `shouldBe` Right (Response nid (NodeFound [NodeInfo nid' naddr])) - - it "properly bencoded (iso)" $ property $ \ nid x xs -> do - prop_bencode (Query nid False (FindNode x)) - prop_bencode (Response nid (NodeFound (xs :: [NodeInfo IPv4] ))) - - it "does compatible with existing DHT" $ do - nid <- genNodeId - Response _remoteAddr (NodeFound xs) <- rpc $ do - query remoteAddr (Query nid False (FindNode nid)) - L.length (xs :: [NodeInfo IPv4]) `shouldSatisfy` (> 0) - - describe "get_peers" $ do - it "properly bencoded" $ do - BE.decode "d2:id20:abcdefghij0123456789\ - \9:info_hash20:mnopqrstuvwxyz123456\ - \e" - `shouldBe` Right (Query "abcdefghij0123456789" False - (GetPeers "mnopqrstuvwxyz123456")) - - BE.decode "d2:id20:abcdefghij0123456789\ - \5:token8:aoeusnth\ - \6:valuesl6:\127\0\0\1\1\2\&6:\192\168\1\100\1\2e\ - \e" - `shouldBe` Right (Response "abcdefghij0123456789" - (GotPeers (Right [ "127.0.0.1:258" :: PeerAddr IPv4 - , "192.168.1.100:258" - ]) "aoeusnth")) - - BE.decode "d2:id20:abcdefghij0123456789\ - \5:nodes26:mnopqrstuvwxyz123456\127\0\0\1\1\2\ - \5:token8:aoeusnth\ - \e" - `shouldBe` Right (Response "abcdefghij0123456789" - (GotPeers - { peers = Left [NodeInfo "mnopqrstuvwxyz123456" "127.0.0.1:258" - :: NodeInfo IPv4] - , grantedToken = "aoeusnth" - })) - - it "properly bencoded (iso)" $ property $ \ nid topic exs token -> do - prop_bencode (Query nid False (GetPeers topic)) - let _ = exs :: Either [NodeInfo IPv4] [PeerAddr IPv4] - let nullPeerId paddr = paddr {peerId = Nothing} - let nullPeerIds = either Left (Right . L.map nullPeerId) - prop_bencode (Response nid (GotPeers (nullPeerIds exs) token)) - - it "does compatible with existing DHT" $ do - nid <- genNodeId - Response _remoteId (GotPeers {..}) - <- rpc $ query remoteAddr (Query nid False (GetPeers def)) - let _ = peers :: Either [NodeInfo IPv4] [PeerAddr IPv4] - either L.length L.length peers `shouldSatisfy` (> 0) - - describe "announce" $ do - it "properly bencoded" $ do - BE.decode "d2:id20:abcdefghij0123456789\ - \9:info_hash20:mnopqrstuvwxyz123456\ - \4:porti6881e\ - \5:token8:aoeusnth\ - \e" `shouldBe` Right - (Query "abcdefghij0123456789" False - (Announce False "mnopqrstuvwxyz123456" Nothing 6881 "aoeusnth")) - - BE.decode "d2:id20:abcdefghij0123456789\ - \12:implied_porti1e\ - \9:info_hash20:mnopqrstuvwxyz123456\ - \4:porti6881e\ - \5:token8:aoeusnth\ - \e" `shouldBe` Right - (Query "abcdefghij0123456789" False - (Announce True "mnopqrstuvwxyz123456" Nothing 6881 "aoeusnth")) - - - BE.decode "d2:id20:mnopqrstuvwxyz123456e" - `shouldBe` Right - (Response "mnopqrstuvwxyz123456" Announced) - - it "properly bencoded (iso)" $ property $ \ nid flag topic port token -> do - prop_bencode (Query nid False (Announce flag topic Nothing port token)) - prop_bencode (Response nid (Announced)) - - - it "does compatible with existing DHT" $ do - nid <- genNodeId - Response _remoteId Announced <- rpc $ do - Response _ GotPeers {..} <- query remoteAddr (Query nid False (GetPeers def)) - let _ = peers :: Either [NodeInfo IPv4] [PeerAddr IPv4] - query remoteAddr (Query nid False (Announce False def Nothing thisPort grantedToken)) - return () - - it "does fail on invalid token" $ do - nid <- genNodeId - (rpc $ do - Response _ GotPeers {..} <- query remoteAddr (Query nid False (GetPeers def)) - let _ = peers :: Either [NodeInfo IPv4] [PeerAddr IPv4] - let invalidToken = "" - let q :: MonadKRPC h m => SockAddr -> Query Announce - -> m (Response Announced) - q = query - q remoteAddr (Query nid False (Announce False def Nothing thisPort invalidToken))) - `shouldThrow` isQueryError - return () diff --git a/bittorrent/tests/Network/BitTorrent/DHT/QuerySpec.hs b/bittorrent/tests/Network/BitTorrent/DHT/QuerySpec.hs deleted file mode 100644 index 93f78263..00000000 --- a/bittorrent/tests/Network/BitTorrent/DHT/QuerySpec.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module Network.BitTorrent.DHT.QuerySpec (spec) where -import Control.Applicative -import Control.Exception -import Control.Monad.Reader -import Data.Conduit as C -import Data.Conduit.List as CL -import Data.Default -import Data.List as L -import Test.Hspec - -import Network.BitTorrent.Address -import Network.BitTorrent.DHT -import Network.BitTorrent.DHT.Session -import Network.BitTorrent.DHT.Query - -import Network.BitTorrent.DHT.TestData - - -myAddr :: NodeAddr IPv4 -myAddr = "0.0.0.0:0" - -nullLogger :: LogFun -nullLogger _ _ _ _ = return () - ---simpleLogger :: LogFun ---simpleLogger _ t _ _ = print t - -simpleDHT :: [NodeHandler IPv4] -> DHT IPv4 a -> IO a -simpleDHT hs m = - bracket (newNode hs def myAddr nullLogger Nothing) closeNode $ \ node -> - runDHT node m - -getBootInfo :: IO (NodeInfo IPv4) -getBootInfo = do - startAddr <- resolveHostName (L.head defaultBootstrapNodes) - simpleDHT [] $ fmap fst (pingQ startAddr) - -spec :: Spec -spec = parallel $ do - describe "environment" $ do - describe "test node" $ do - it "is alive" $ do - _ <- getBootInfo - return () - - describe "handlers" $ do - it "" $ pendingWith "need to setup 2 DHT locally" - - describe "basic queries" $ do - it "ping" $ do - _ <- getBootInfo - return () - - it "findNode" $ do - startInfo <- getBootInfo - _ <- simpleDHT [] $ do - nid <- myNodeIdAccordingTo (read "8.8.8.8:6881") - findNodeQ nid startInfo - return () - - it "getPeers" $ do - startInfo <- getBootInfo - peers <- simpleDHT [] $ do - nid <- myNodeIdAccordingTo (read "8.8.8.8:6881") - - -- we should not run getPeers query on boot node, because - -- it may not support it - Right infos <- findNodeQ nid startInfo - - when (L.null infos) $ - error "boot node malfunction" - - -- at least one node should reply - queryParallel $ do - getPeersQ (entryHash (L.head testTorrents)) <$> infos - - peers `shouldSatisfy` (not . L.null) - - it "announce" $ do - bootNode <- getBootInfo - _ <- simpleDHT [] $ do - let ih = entryHash (L.head testTorrents) - Right nodes <- findNodeQ ih bootNode - - when (L.null nodes) $ - error "boot node malfunction" - - queryParallel $ do - announceQ ih (nodePort myAddr) <$> nodes - - return () - - describe "iterative queries" $ do - forM_ testTorrents $ \ TestEntry {..} -> do - context entryName $ do - - it "get at least 10 unique peers for each infohash" $ do - bootNode <- getBootInfo - peers <- simpleDHT [] $ do - Right startNodes <- findNodeQ entryHash bootNode - sourceList [startNodes] $= - search entryHash (getPeersQ entryHash) $= - CL.concat $$ CL.take 10 - L.length peers `shouldBe` 10 diff --git a/bittorrent/tests/Network/BitTorrent/DHT/RoutingSpec.hs b/bittorrent/tests/Network/BitTorrent/DHT/RoutingSpec.hs deleted file mode 100644 index 07a906ba..00000000 --- a/bittorrent/tests/Network/BitTorrent/DHT/RoutingSpec.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -module Network.BitTorrent.DHT.RoutingSpec (spec) where -import Control.Applicative -import Control.Monad.State -import Data.Default -import Data.List as L -import Data.Maybe -import Test.Hspec -import Test.QuickCheck - -import Network.BitTorrent.Address -import Network.BitTorrent.DHT.Routing as T - -import Network.BitTorrent.CoreSpec hiding (spec) - - -type Network ip = [NodeAddr ip] - -data Env ip = Env - { currentTime :: Timestamp - , network :: Network ip - } deriving Show - -type Simulation ip = State (Env ip) - -runSimulation :: Eq ip => Env ip -> Routing ip a -> Maybe a -runSimulation e m = evalState (runRouting ping closest timestamp m) e - where - ping addr = gets (L.elem addr . network) - closest nid = error "runSimulation" - timestamp = gets currentTime - -instance Arbitrary ip => Arbitrary (Env ip) where - arbitrary = Env <$> arbitrary <*> (vector nodeCount) - where - nodeCount = 1000 - -instance (Arbitrary ip, Eq ip) => Arbitrary (Table ip) where - arbitrary = do - thisId <- arbitrary - bucketN <- choose (1, 20) - let table = nullTable thisId bucketN - --- nodeN <- (`mod` bucketN) <$> arbitrary --- nodes <- vector nodeN - - node <- arbitrary - mt <- do - env <- arbitrary - return $ runSimulation env $ do - (_,t') <- T.insert (currentTime env) (TryInsert node) table - return t' :: Routing ip (Table ip) - --(foldM (flip fillTable) table nodes) - return (fromJust mt) --- where --- fillTable x t = do --- t' <- T.insert x t --- return $ if T.full t' then t else t' - -spec :: Spec -spec = do - describe "size" $ do - it "null table is empty" $ do - T.size (nullTable def 2 :: Table IPv4) `shouldBe` 0 - - it "the same node never appear in different buckets" $ property $ \ t -> do - let xss = T.toList (t :: Table Int) - let justOnce x = L.length (L.filter (L.elem x) xss) == 1 - L.all justOnce (L.concat xss) - - it "insert is idemponent" $ property $ \ (e :: Env Int) n t -> do - let ins :: NodeInfo Int -> Table Int -> Routing Int (Table Int) - ins n t = snd <$> T.insert (currentTime e) (TryInsert n) t - let t1 = runSimulation e (ins n t) - let t2 = runSimulation e (ins n t >>= ins n) - t1 `shouldBe` t2 diff --git a/bittorrent/tests/Network/BitTorrent/DHT/SessionSpec.hs b/bittorrent/tests/Network/BitTorrent/DHT/SessionSpec.hs deleted file mode 100644 index 32e4c158..00000000 --- a/bittorrent/tests/Network/BitTorrent/DHT/SessionSpec.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Network.BitTorrent.DHT.SessionSpec (spec) where -import Control.Applicative -import Control.Concurrent -import Control.Exception -import Control.Monad.Reader -import Control.Monad.Trans.Resource -import Data.Conduit.Lazy -import Data.Default -import Data.List as L -import Test.Hspec -import Test.QuickCheck - -import Network.BitTorrent.Address -import Network.BitTorrent.DHT -import Network.BitTorrent.DHT.Message -import Network.BitTorrent.DHT.Session -import Network.BitTorrent.DHT.Query - -import Data.TorrentSpec () -import Network.BitTorrent.CoreSpec () -import Network.BitTorrent.DHT.TokenSpec () - - -myAddr :: NodeAddr IPv4 -myAddr = "127.0.0.1:60000" - -simpleDHT :: DHT IPv4 a -> IO a -simpleDHT m = - bracket (newNode defaultHandlers def myAddr nullLogger Nothing) closeNode $ \ node -> - runDHT node m - -isRight :: Either a b -> Bool -isRight (Left _) = False -isRight (Right _) = True - -isLeft :: Either a b -> Bool -isLeft = not . isRight - -nullLogger :: LogFun -nullLogger _ _ _ _ = return () - -spec :: Spec -spec = do - describe "session" $ do - it "is active until closeNode called" $ do - node <- newNode [] def myAddr nullLogger Nothing - runDHT node monadActive `shouldReturn` True - runDHT node monadActive `shouldReturn` True - closeNode node - runDHT node monadActive `shouldReturn` False - - describe "tokens" $ do - it "should not complain about valid token" $ - property $ \ (addrs :: [NodeAddr IPv4]) -> do - isOks <- simpleDHT $ do - forM addrs $ \ addr -> do - token <- grantToken addr - checkToken addr token - L.and isOks `shouldBe` True - - it "should complain about invalid token" $ - property $ \ (addr :: NodeAddr IPv4) token -> do - isOk <- simpleDHT (checkToken addr token) - isOk `shouldBe` False - - describe "routing table" $ - it "accept any node entry when table is empty" $ - property $ \ (nid :: NodeId) -> do - let info = NodeInfo nid myAddr - closest <- simpleDHT $ do - _ <- insertNode info Nothing - liftIO $ yield - getClosest nid - closest `shouldSatisfy` L.elem info - - describe "peer storage" $ do - it "should return nodes, if there are no peers" $ property $ \ ih -> do - res <- simpleDHT $ do getPeerList ih - res `shouldSatisfy` isLeft - - it "should return peers, if any" $ property $ \ ih addr -> do - res <- simpleDHT $ do - insertPeer ih addr - getPeerList ih - res `shouldSatisfy` isRight - - describe "topic storage" $ do - it "should not grow indefinitely" $ do - pending - - describe "messaging" $ do - describe "queryNode" $ do - it "should always ping this node" $ do - (rid, tid) <- simpleDHT $ do - (remoteId, Ping) <- queryNode myAddr Ping - thisId <- myNodeIdAccordingTo (read "8.8.8.8:6881") - return (remoteId, thisId) - rid `shouldBe` tid - - describe "queryParallel" $ do - it "should handle parallel requests" $ do - (nid, resps) <- simpleDHT $ do - me <- myNodeIdAccordingTo (read "8.8.8.8:6881") - ( (,) me ) <$> queryParallel (L.replicate 100 $ queryNode myAddr Ping) - resps `shouldSatisfy` L.all (== (nid, Ping)) - - describe "(<@>) operator" $ do - it "" $ - pending diff --git a/bittorrent/tests/Network/BitTorrent/DHT/TestData.hs b/bittorrent/tests/Network/BitTorrent/DHT/TestData.hs deleted file mode 100644 index e9473cbb..00000000 --- a/bittorrent/tests/Network/BitTorrent/DHT/TestData.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Network.BitTorrent.DHT.TestData - ( TestEntry (..) - , testTorrents - ) where - -import Data.Torrent - -data TestEntry = TestEntry - { entryName :: String - , entryHash :: InfoHash - , entryPeers :: Int -- ^ approximate number of peers, may change with time - } - -testTorrents :: [TestEntry] -testTorrents = - [ TestEntry - { entryName = "Automate with Arduino, Android..." - , entryHash = "8c0433e541dc5d1cfc095799cef171cd4eb586f7" - , entryPeers = 300 - } - - , TestEntry - { entryName = "Beginning Programming with Java For Dummies" - , entryHash = "fd8967721731cc16c8b203a03e49ce839cecf184" - , entryPeers = 200 - } - - , TestEntry - { entryName = "The C Programming Language" - , entryHash = "146d13f090e50e97091dbbe5b37678dd1471cfad" - , entryPeers = 100 - } - - , TestEntry - { entryName = "The C++ Programming Language" - , entryHash = "8e8e8e6319031a22cff26d895afe050085c84a7f" - , entryPeers = 50 - } - - , TestEntry - { entryName = "Game and Graphics Programming for iOS..." - , entryHash = "703d0595b727fccbfaa3d03be25f57347ccfd6de" - , entryPeers = 30 - } - ] diff --git a/bittorrent/tests/Network/BitTorrent/DHT/TokenSpec.hs b/bittorrent/tests/Network/BitTorrent/DHT/TokenSpec.hs deleted file mode 100644 index a45d2212..00000000 --- a/bittorrent/tests/Network/BitTorrent/DHT/TokenSpec.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Network.BitTorrent.DHT.TokenSpec (spec) where -import Control.Applicative -import Data.List as L -import Data.String -import Test.Hspec -import Test.QuickCheck - -import Network.BitTorrent.Address -import Network.BitTorrent.CoreSpec () -import Network.BitTorrent.DHT.Token as T - - -instance Arbitrary Token where - arbitrary = fromString <$> arbitrary - -instance Arbitrary TokenMap where - arbitrary = tokens <$> arbitrary - -repeatN :: Int -> (a -> a) -> (a -> a) -repeatN n f = L.foldr (.) id $ L.replicate n f - -spec :: Spec -spec = do - describe "Token" $ do - return () - - describe "TokenMap" $ do - it "is keeping any granted token in current session" $ - property $ \ (addr :: NodeAddr IPv4) m -> - T.member addr (T.lookup addr m) m - - it "is keeping any granted token in next session" $ - property $ \ (addr :: NodeAddr IPv4) m -> - T.member addr (T.lookup addr m) (T.update m) - - -- can fail with some small probability - it "is rejecting any outdated tokens" $ - property $ \ (addr :: NodeAddr IPv4) m k -> not $ - let n = min 100 (abs k + 2) in - T.member addr (T.lookup addr m) (repeatN n T.update m) \ No newline at end of file diff --git a/bittorrent/tests/Network/BitTorrent/DHTSpec.hs b/bittorrent/tests/Network/BitTorrent/DHTSpec.hs deleted file mode 100644 index 77160eb5..00000000 --- a/bittorrent/tests/Network/BitTorrent/DHTSpec.hs +++ /dev/null @@ -1,60 +0,0 @@ -module Network.BitTorrent.DHTSpec (spec) where -import Control.Exception -import Control.Monad -import Data.Default -import Data.List as L -import Test.Hspec -import System.Timeout - -import Data.Torrent -import Network.BitTorrent.DHT - - -partialBootstrapTimeout :: Int -partialBootstrapTimeout = 10 * 1000000 - -opts :: Options -opts = def { optBucketCount = 1 } - --- NOTE to shorten test cases run time include only "good" infohashes --- with many nodes -existingInfoHashes :: [InfoHash] -existingInfoHashes = - [ - ] - --- TODO use Test.Hspec.parallel - -spec :: Spec -spec = do - describe "bootstrapping" $ do - it "should resolve all default bootstrap nodes" $ do - nodes <- forM defaultBootstrapNodes resolveHostName - _ <- evaluate nodes - return () - - it "partial bootstrapping should finish in less than 10 seconds" $ do - node <- resolveHostName (L.head defaultBootstrapNodes) - res <- timeout partialBootstrapTimeout $ do - dht opts def fullLogging $ do - bootstrap Nothing [node] - isBootstrapped - res `shouldBe` Just True - - describe "initialization" $ do - it "should be bootstrapped after restore process" $ do - pending - - describe "lookup" $ do - describe "for any existing infohash" $ do - forM_ existingInfoHashes $ \ ih -> do - context (show ih) $ do - it "should find peers" $ do - pending - - describe "insert" $ do - it "should return this peer if announced" $ do - pending - - describe "delete" $ do - return () diff --git a/bittorrent/tests/Network/BitTorrent/Exchange/BitfieldSpec.hs b/bittorrent/tests/Network/BitTorrent/Exchange/BitfieldSpec.hs deleted file mode 100644 index 1ba772f6..00000000 --- a/bittorrent/tests/Network/BitTorrent/Exchange/BitfieldSpec.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# OPTIONS -fno-warn-orphans #-} -module Network.BitTorrent.Exchange.BitfieldSpec (spec) where -import Control.Applicative -import Data.ByteString.Arbitrary -import Test.Hspec -import Test.QuickCheck - -import Network.BitTorrent.Exchange.Bitfield - -instance Arbitrary Bitfield where - arbitrary = fromBitmap . fromABS <$> arbitrary - -spec :: Spec -spec = return () diff --git a/bittorrent/tests/Network/BitTorrent/Exchange/BlockSpec.hs b/bittorrent/tests/Network/BitTorrent/Exchange/BlockSpec.hs deleted file mode 100644 index 2dc8e0b8..00000000 --- a/bittorrent/tests/Network/BitTorrent/Exchange/BlockSpec.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Network.BitTorrent.Exchange.BlockSpec (spec) where -import Control.Applicative -import Control.Exception -import Data.Maybe -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Instances () - -import Network.BitTorrent.Exchange.Block as Block - - -instance Arbitrary a => Arbitrary (Block a) where - arbitrary = Block <$> arbitrary <*> arbitrary <*> arbitrary - -instance Arbitrary BlockIx where - arbitrary = BlockIx <$> arbitrary <*> arbitrary <*> arbitrary - -instance Arbitrary Bucket where - arbitrary = do - s <- arbitrary `suchThat` (> 0) - chunks <- arbitrary - return $ Block.fromList s chunks - -isSomeException :: SomeException -> Bool -isSomeException = const True - -spec :: Spec -spec = do - describe "empty" $ do - it "should fail on bad size" $ do - evaluate (Block.empty (-1)) `shouldThrow` isSomeException - - describe "toPiece" $ do - it "render to piece when it is full" $ property $ \ bkt -> - full bkt == isJust (toPiece bkt) \ No newline at end of file diff --git a/bittorrent/tests/Network/BitTorrent/Exchange/ConnectionSpec.hs b/bittorrent/tests/Network/BitTorrent/Exchange/ConnectionSpec.hs deleted file mode 100644 index d654cda1..00000000 --- a/bittorrent/tests/Network/BitTorrent/Exchange/ConnectionSpec.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Network.BitTorrent.Exchange.ConnectionSpec (spec) where -import Control.Applicative -import Control.Monad.Trans -import Data.Default -import Test.Hspec -import Test.QuickCheck - -import Data.Torrent -import Network.BitTorrent.Address -import Network.BitTorrent.Exchange.Connection -import Network.BitTorrent.Exchange.Message - -import Config -import Network.BitTorrent.Exchange.MessageSpec () - -nullSession :: InfoHash -> PeerId -> SessionLink () -nullSession ih pid = SessionLink ih pid Nothing Nothing () - -instance Arbitrary Options where - arbitrary = return def - -instance Arbitrary ConnectionPrefs where - arbitrary = ConnectionPrefs <$> arbitrary <*> pure def - <*> arbitrary <*> arbitrary - -withWire :: ConnectionPrefs -> Wire () () -> IO () -withWire prefs wire = - withRemote $ \ ClientOpts {..} -> do - pid <- genPeerId - t <- getTestTorrent - let ih = idInfoHash (tInfoDict t) - let cfg = ConnectionConfig prefs (nullSession ih pid) (wire) - let addr = PeerAddr Nothing "127.0.0.1" peerPort - connectWire addr cfg - -spec :: Spec -spec = do - describe "connectWire" $ do - it "can establish connection with all possible preferences" $ - property $ \ prefs -> do - withWire prefs (return ()) - - it "must not connect with invalid topic" $ do - pending - - describe "acceptWire" $ do - it "" $ do - pending - - describe "messaging" $ do - it "first message is bitfield" $ do - withWire def $ do - msg <- recvMessage - let isBitfield (Available (Bitfield _)) = True - isBitfield _ = False - liftIO $ msg `shouldSatisfy` isBitfield diff --git a/bittorrent/tests/Network/BitTorrent/Exchange/DownloadSpec.hs b/bittorrent/tests/Network/BitTorrent/Exchange/DownloadSpec.hs deleted file mode 100644 index d46f2034..00000000 --- a/bittorrent/tests/Network/BitTorrent/Exchange/DownloadSpec.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module Network.BitTorrent.Exchange.DownloadSpec (spec) where -import Control.Concurrent -import Data.ByteString as BS -import Data.ByteString.Lazy as BL -import Test.Hspec -import Test.QuickCheck - -import Data.BEncode as BE -import Data.Torrent as Torrent -import Network.BitTorrent.Address -import Network.BitTorrent.Exchange.Download -import Network.BitTorrent.Exchange.Message - -import Config -import Network.BitTorrent.CoreSpec () - - -placeholderAddr :: PeerAddr IP -placeholderAddr = "0.0.0.0:0" - -chunkBy :: Int -> BS.ByteString -> [BS.ByteString] -chunkBy s bs - | BS.null bs = [] - | otherwise = BS.take s bs : chunkBy s (BS.drop s bs) - -withUpdates :: Updates s a -> IO a -withUpdates m = do - Torrent {..} <- getTestTorrent - let infoDictLen = fromIntegral $ BL.length $ BE.encode tInfoDict - --mvar <- newMVar (nullStatus infoDictLen) - --runUpdates mvar placeholderAddr m - undefined - -simulateFetch :: InfoDict -> Updates s (Maybe InfoDict) -simulateFetch dict = undefined - -spec :: Spec -spec = do - describe "scheduleBlock" $ do - it "never schedule the same index twice" $ do - pending - - describe "resetPending" $ do - it "" $ do - pending - - describe "cancelPending" $ do - it "must not throw an exception if cancel the same piece twice" $ do - pending - - describe "pushBlock" $ do - it "assemble infodict from chunks" $ do - Torrent {..} <- getTestTorrent - mdict <- withUpdates $ simulateFetch tInfoDict - mdict `shouldBe` Just tInfoDict - - it "must throw an exception if block if not requested" $ do - pending \ No newline at end of file diff --git a/bittorrent/tests/Network/BitTorrent/Exchange/MessageSpec.hs b/bittorrent/tests/Network/BitTorrent/Exchange/MessageSpec.hs deleted file mode 100644 index d615b1ff..00000000 --- a/bittorrent/tests/Network/BitTorrent/Exchange/MessageSpec.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Network.BitTorrent.Exchange.MessageSpec (spec) where -import Control.Applicative -import Control.Exception -import Data.ByteString as BS -import Data.List as L -import Data.Set as S -import Data.Serialize as S -import Data.String -import Test.Hspec -import Test.QuickCheck - -import Data.TorrentSpec () -import Network.BitTorrent.Exchange.BitfieldSpec () -import Network.BitTorrent.CoreSpec () -import Network.BitTorrent.Address () -import Network.BitTorrent.Exchange.BlockSpec () -import Network.BitTorrent.Exchange.Message - -instance Arbitrary Extension where - arbitrary = elements [minBound .. maxBound] - -instance Arbitrary Caps where - arbitrary = toCaps <$> arbitrary - -instance Arbitrary ExtendedExtension where - arbitrary = elements [minBound .. maxBound] - -instance Arbitrary ExtendedCaps where - arbitrary = toCaps <$> arbitrary - -instance Arbitrary ProtocolName where - arbitrary = fromString <$> (arbitrary `suchThat` ((200 <) . L.length)) - -instance Arbitrary Handshake where - arbitrary = Handshake <$> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - -instance Arbitrary StatusUpdate where - arbitrary = frequency - [ (1, Choking <$> arbitrary) - , (1, Interested <$> arbitrary) - ] - -instance Arbitrary Available where - arbitrary = frequency - [ (1, Have <$> arbitrary) - , (1, Bitfield <$> arbitrary) - ] - -instance Arbitrary Transfer where - arbitrary = frequency - [ (1, Request <$> arbitrary) - , (1, Piece <$> arbitrary) - , (1, Cancel <$> arbitrary) - ] - -instance Arbitrary FastMessage where - arbitrary = frequency - [ (1, pure HaveAll) - , (1, pure HaveNone) - , (1, SuggestPiece <$> arbitrary) - , (1, RejectRequest <$> arbitrary) - , (1, AllowedFast <$> arbitrary) - ] - -instance Arbitrary Message where - arbitrary = frequency - [ (1, pure KeepAlive) - , (1, Status <$> arbitrary) - , (1, Available <$> arbitrary) - , (1, Transfer <$> arbitrary) - , (1, Fast <$> arbitrary) - ] - --- TODO test extension protocol - -spec :: Spec -spec = do - describe "Caps" $ do - it "set-like container" $ property $ \ exts -> - L.all (`allowed` (toCaps exts :: Caps)) exts - - it "preserve items" $ property $ \ extSet -> - S.fromList (fromCaps (toCaps (S.toList extSet) :: Caps)) - `shouldBe` extSet - - describe "ByteStats" $ do - it "preserve size" $ property $ \ msg -> - byteLength (stats msg) `shouldBe` - fromIntegral (BS.length (S.encode (msg :: Message))) - - describe "ProtocolName" $ do - it "fail to construct invalid string" $ do - let str = L.replicate 500 'x' - evaluate (fromString str :: ProtocolName) - `shouldThrow` - errorCall ("fromString: ProtocolName too long: " ++ str) - - describe "Handshake" $ do - it "properly serialized" $ property $ \ hs -> - S.decode (S.encode hs ) `shouldBe` Right (hs :: Handshake) diff --git a/bittorrent/tests/Network/BitTorrent/Exchange/SessionSpec.hs b/bittorrent/tests/Network/BitTorrent/Exchange/SessionSpec.hs deleted file mode 100644 index bf5b95a1..00000000 --- a/bittorrent/tests/Network/BitTorrent/Exchange/SessionSpec.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module Network.BitTorrent.Exchange.SessionSpec (spec) where -import Test.Hspec - -import Data.Torrent -import Network.BitTorrent.Address -import Network.BitTorrent.Exchange.Session - -import Config - - -nullLogger :: LogFun -nullLogger _ _ x _ = print x - -simpleSession :: InfoDict -> (Session -> IO ()) -> IO () -simpleSession dict action = do - withRemoteAddr $ \ addr -> do - myAddr <- getMyAddr - ses <- newSession nullLogger myAddr "" (Right dict) - connect addr ses - action ses - closeSession ses - -spec :: Spec -spec = do - describe "construction" $ do - describe "newSession" $ do - it "" $ do - pending - - describe "closeSession" $ do - it "" $ do - pending - - describe "connection set" $ do - describe "connect" $ do - it "" $ do - pending - - describe "establish" $ do - it "" $ do - pending - - describe "exchange" $ do - describe "metadata" $ do - it "should fetch info dictionary" $ do - Torrent {..} <- getTestTorrent - simpleSession tInfoDict $ \ ses -> do - dict <- waitMetadata ses - dict `shouldBe` tInfoDict - - it "should serve info dictionary" $ do - pending - - describe "content" $ do - it "should fetch torrent content" $ do - Torrent {..} <- getTestTorrent - simpleSession tInfoDict $ \ ses -> do - pending --- st <- waitData ses --- verifyStorage st (idPieceInfo tInfoDict) - - it "should serve torrent content" $ do - pending diff --git a/bittorrent/tests/Network/BitTorrent/Internal/CacheSpec.hs b/bittorrent/tests/Network/BitTorrent/Internal/CacheSpec.hs deleted file mode 100644 index 337e7add..00000000 --- a/bittorrent/tests/Network/BitTorrent/Internal/CacheSpec.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Network.BitTorrent.Internal.CacheSpec (spec) where -import Test.Hspec - -spec :: Spec -spec = do - describe "Cached" $ do - return () diff --git a/bittorrent/tests/Network/BitTorrent/Internal/ProgressSpec.hs b/bittorrent/tests/Network/BitTorrent/Internal/ProgressSpec.hs deleted file mode 100644 index acbfd84c..00000000 --- a/bittorrent/tests/Network/BitTorrent/Internal/ProgressSpec.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# OPTIONS -fno-warn-orphans #-} -module Network.BitTorrent.Internal.ProgressSpec (spec) where -import Control.Applicative -import Test.Hspec -import Test.QuickCheck -import Network.BitTorrent.Internal.Progress - - -instance Arbitrary Progress where - arbitrary = Progress <$> arbitrary <*> arbitrary <*> arbitrary - -spec :: Spec -spec = return () diff --git a/bittorrent/tests/Network/BitTorrent/Tracker/ListSpec.hs b/bittorrent/tests/Network/BitTorrent/Tracker/ListSpec.hs deleted file mode 100644 index bba9d0e2..00000000 --- a/bittorrent/tests/Network/BitTorrent/Tracker/ListSpec.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Network.BitTorrent.Tracker.ListSpec (spec) where -import Control.Exception -import Data.Default -import Data.Foldable as F -import Data.List as L -import Data.Maybe -import Network.URI -import Test.Hspec - -import Data.Torrent -import Network.BitTorrent.Tracker.List -import Network.BitTorrent.Tracker.RPC - - -uris :: [URI] -uris = fmap (fromJust . parseURI . renderURI) [1..10 :: Int] - where - renderURI n = "http://" ++ show n ++ ".org" - -list :: TrackerList () -list = trackerList def { tAnnounceList = Just [uris] } - -spec :: Spec -spec = do - describe "TrackerList" $ do - it "shuffleTiers (may fail with very small probability)" $ do - list' <- shuffleTiers list - list' `shouldSatisfy` (/= list) - - it "traverseAll" $ do - xs <- traverseAll (\ (uri, _) -> if uri == L.last uris - then throwIO (GenericException "") - else return ()) list - return () - - it "traverseTiers" $ do - xs' <- traverseTiers (\ (uri, _) -> if uri == L.last uris then return () - else throwIO (GenericException "")) list - - return () diff --git a/bittorrent/tests/Network/BitTorrent/Tracker/MessageSpec.hs b/bittorrent/tests/Network/BitTorrent/Tracker/MessageSpec.hs deleted file mode 100644 index 29854d58..00000000 --- a/bittorrent/tests/Network/BitTorrent/Tracker/MessageSpec.hs +++ /dev/null @@ -1,173 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS -fno-warn-orphans #-} -module Network.BitTorrent.Tracker.MessageSpec - ( spec - , arbitrarySample - ) where - -import Control.Applicative -import Control.Exception -import Data.BEncode as BE -import Data.ByteString.Lazy as BL -import Data.List as L -import Data.Maybe -import Test.Hspec -import Test.QuickCheck - -import Data.TorrentSpec () -import Network.BitTorrent.Internal.ProgressSpec () -import Network.BitTorrent.Address () -import Network.BitTorrent.Address () - -import Network.BitTorrent.Tracker.Message as Message -import Network.BitTorrent.Address - - ---prop_bencode :: Eq a => BEncode a => a -> Bool ---prop_bencode a = BE.decode (BL.toStrict (BE.encode a)) == return a - ---prop_urlencode :: Eq a => URLDecoded a => URLEncoded a => a -> Bool ---prop_urlencode a = urlDecode (T.pack (urlEncode a)) == a - -instance Arbitrary AnnounceEvent where - arbitrary = elements [minBound..maxBound] - -instance Arbitrary AnnounceQuery where - arbitrary = AnnounceQuery - <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary <*> arbitrary - -instance Arbitrary (PeerList IP) where - arbitrary = frequency - [ (1, (PeerList . maybeToList) <$> arbitrary) - , (1, (CompactPeerList . maybeToList . fmap zeroPeerId) <$> arbitrary) - ] - - shrink ( PeerList xs) = PeerList <$> shrink xs - shrink (CompactPeerList xs) = CompactPeerList <$> shrink xs - -instance Arbitrary AnnounceInfo where - arbitrary = AnnounceInfo - <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - -arbitrarySample :: Arbitrary a => IO a -arbitrarySample = L.head <$> sample' arbitrary - -zeroPeerId :: PeerAddr a -> PeerAddr a -zeroPeerId addr = addr { peerId = Nothing } - -spec :: Spec -spec = do - describe "AnnounceQuery" $ do - it "properly url encoded" $ property $ \ q -> - parseAnnounceQuery (renderAnnounceQuery q) - `shouldBe` Right q - - describe "PeerList" $ do - context "Non compact" $ do - it "properly encoded (both ipv4 and ipv6)" $ do - BE.decode "ld2:ip7:1.2.3.44:porti80eed2:ip3:::14:porti8080eee" - `shouldBe` Right - (PeerList ["1.2.3.4:80", "[::1]:8080"] :: PeerList IPv4) - - it "properly encoded (iso)" $ property $ \ xs -> - BE.decode (BL.toStrict (BE.encode (PeerList xs :: PeerList IPv4))) - `shouldBe` Right (PeerList xs :: PeerList IPv4) - - context "Compact" $ do - it "properly encodes (ipv4)" $ do - BE.decode "12:\x1\x2\x3\x4\x1\x2\x9\x8\x7\x6\x1\x2" - `shouldBe` Right - (CompactPeerList ["1.2.3.4:258", "9.8.7.6:258"] :: PeerList IPv4) - - it "properly encodes (ipv6)" $ do - BE.decode "18:\x1\x2\x3\x4\x5\x6\x7\x8\x1\x2\x3\x4\x5\x6\x7\x8\x1\x2" - `shouldBe` Right - (CompactPeerList ["[102:304:506:708:102:304:506:708]:258"] - :: PeerList IPv6) - - it "properly encoded (ipv4, iso)" $ - property $ \ (fmap zeroPeerId -> xs) -> - BE.decode (BL.toStrict (BE.encode (CompactPeerList xs))) - `shouldBe` Right (CompactPeerList xs :: PeerList IPv4) - - it "properly encoded (ipv6, iso)" $ - property $ \ (fmap zeroPeerId -> xs) -> - BE.decode (BL.toStrict (BE.encode (CompactPeerList xs))) - `shouldBe` Right (CompactPeerList xs :: PeerList IPv6) - - describe "AnnounceInfo" $ do - it "parses minimal sample" $ do - "d8:intervali0e5:peerslee" - `shouldBe` - AnnounceInfo Nothing Nothing 0 Nothing (PeerList []) Nothing - - it "parses optional fields" $ do - "d8:completei1e\ - \10:incompletei2e\ - \8:intervali3e\ - \12:min intervali4e\ - \5:peersle\ - \15:warning message3:str\ - \e" - `shouldBe` - AnnounceInfo (Just 1) (Just 2) 3 (Just 4) (PeerList []) (Just "str") - - it "parses failed response" $ do - "d14:failure reason10:any reasone" - `shouldBe` - Message.Failure "any reason" - - it "fail if no peer list present" $ do - evaluate ("d8:intervali0ee" :: AnnounceInfo) - `shouldThrow` - errorCall "fromString: unable to decode AnnounceInfo: \ - \required field `peers' not found" - - it "parses `peer' list" $ do -- TODO - "d8:intervali0e\ - \5:peersl\ - \d2:ip7:1.2.3.4\ - \4:porti80e\ - \e\ - \d2:ip3:::1\ - \4:porti80e\ - \e\ - \e\ - \e" `shouldBe` - let xs = PeerList ["1.2.3.4:80", "[::1]:80"] in - AnnounceInfo Nothing Nothing 0 Nothing xs Nothing - - it "parses `peers6' list" $ do - "d8:intervali0e\ - \5:peers0:\ - \6:peers60:\ - \e" `shouldBe` - AnnounceInfo Nothing Nothing 0 Nothing (CompactPeerList []) Nothing - - it "fails on invalid combinations of the peer lists" $ do - BE.decode "d8:intervali0e\ - \5:peers0:\ - \6:peers6le\ - \e" - `shouldBe` (Left - "PeerList: the `peers6' field value should contain \ - \*compact* peer list" :: BE.Result AnnounceInfo) - - BE.decode "d8:intervali0e\ - \5:peersle\ - \6:peers60:\ - \e" - `shouldBe` (Left - "PeerList: non-compact peer list provided, \ - \but the `peers6' field present" :: BE.Result AnnounceInfo) - - it "properly bencoded (iso)" $ property $ \ info -> - BE.decode (BL.toStrict (BE.encode info)) - `shouldBe` Right (info :: AnnounceInfo) - - describe "Scrape" $ do - return () diff --git a/bittorrent/tests/Network/BitTorrent/Tracker/RPC/HTTPSpec.hs b/bittorrent/tests/Network/BitTorrent/Tracker/RPC/HTTPSpec.hs deleted file mode 100644 index e928f917..00000000 --- a/bittorrent/tests/Network/BitTorrent/Tracker/RPC/HTTPSpec.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module Network.BitTorrent.Tracker.RPC.HTTPSpec (spec) where -import Control.Monad -import Data.Default -import Data.List as L -import Test.Hspec - -import Network.BitTorrent.Internal.Progress -import Network.BitTorrent.Tracker.Message as Message -import Network.BitTorrent.Tracker.RPC.HTTP - -import Network.BitTorrent.Tracker.TestData -import Network.BitTorrent.Tracker.MessageSpec hiding (spec) - - -validateInfo :: AnnounceQuery -> AnnounceInfo -> Expectation -validateInfo _ (Message.Failure reason) = do - error $ "validateInfo: " ++ show reason -validateInfo AnnounceQuery {..} AnnounceInfo {..} = do - return () --- case respComplete <|> respIncomplete of --- Nothing -> return () --- Just n -> n `shouldBe` L.length (getPeerList respPeers) - -isUnrecognizedScheme :: RpcException -> Bool -isUnrecognizedScheme (RequestFailed _) = True -isUnrecognizedScheme _ = False - -isNotResponding :: RpcException -> Bool -isNotResponding (RequestFailed _) = True -isNotResponding _ = False - -spec :: Spec -spec = parallel $ do - describe "Manager" $ do - describe "newManager" $ do - it "" $ pending - - describe "closeManager" $ do - it "" $ pending - - describe "withManager" $ do - it "" $ pending - - describe "RPC" $ do - describe "announce" $ do - it "must fail on bad uri scheme" $ do - withManager def $ \ mgr -> do - q <- arbitrarySample - announce mgr "magnet://foo.bar" q - `shouldThrow` isUnrecognizedScheme - - describe "scrape" $ do - it "must fail on bad uri scheme" $ do - withManager def $ \ mgr -> do - scrape mgr "magnet://foo.bar" [] - `shouldThrow` isUnrecognizedScheme - - forM_ (L.filter isHttpTracker trackers) $ \ TrackerEntry {..} -> - context trackerName $ do - - describe "announce" $ do - if tryAnnounce - then do - it "have valid response" $ do - withManager def $ \ mgr -> do --- q <- arbitrarySample - let ih = maybe def L.head hashList - let q = AnnounceQuery ih "-HS0003-203534.37420" 6000 - (Progress 0 0 0) Nothing Nothing (Just Started) - info <- announce mgr trackerURI q - validateInfo q info - else do - it "should fail with RequestFailed" $ do - withManager def $ \ mgr -> do - q <- arbitrarySample - announce mgr trackerURI q - `shouldThrow` isNotResponding - - describe "scrape" $ do - if tryScraping - then do - it "have valid response" $ do - withManager def $ \ mgr -> do - xs <- scrape mgr trackerURI [def] - L.length xs `shouldSatisfy` (>= 1) - else do - it "should fail with ScrapelessTracker" $ do - pending - - when (not tryAnnounce) $ do - it "should fail with RequestFailed" $ do - withManager def $ \ mgr -> do - scrape mgr trackerURI [def] - `shouldThrow` isNotResponding diff --git a/bittorrent/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs b/bittorrent/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs deleted file mode 100644 index 73acb3fa..00000000 --- a/bittorrent/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module Network.BitTorrent.Tracker.RPC.UDPSpec (spec, rpcOpts) where -import Control.Concurrent -import Control.Concurrent.Async -import Control.Exception -import Control.Monad -import Data.Default -import Data.List as L -import Data.Maybe -import Test.Hspec - -import Network.BitTorrent.Address -import Network.BitTorrent.Tracker.Message as Message - -import Network.BitTorrent.Tracker.TestData -import Network.BitTorrent.Tracker.MessageSpec hiding (spec) -import Network.BitTorrent.Tracker.RPC.UDP - - -validateInfo :: AnnounceQuery -> AnnounceInfo -> Expectation -validateInfo _ Message.Failure {} = error "validateInfo: failure" -validateInfo AnnounceQuery {..} AnnounceInfo {..} = do - respComplete `shouldSatisfy` isJust - respIncomplete `shouldSatisfy` isJust - respMinInterval `shouldSatisfy` isNothing - respWarning `shouldSatisfy` isNothing - peerList `shouldSatisfy` L.all (isNothing . peerId) - where - peerList = getPeerList respPeers - --- | Number of concurrent calls. -rpcCount :: Int -rpcCount = 100 - -rpcOpts :: Options -rpcOpts = def - { optMinTimeout = 1 - , optMaxTimeout = 10 - } - -isTimeoutExpired :: RpcException -> Bool -isTimeoutExpired (TimeoutExpired _) = True -isTimeoutExpired _ = False - -isSomeException :: SomeException -> Bool -isSomeException _ = True - -isIOException :: IOException -> Bool -isIOException _ = True - -spec :: Spec -spec = parallel $ do - describe "newManager" $ do - it "should throw exception on zero optMaxPacketSize" $ do - let opts = def { optMaxPacketSize = 0 } - newManager opts `shouldThrow` isSomeException - - it "should throw exception on zero optMinTimout" $ do - let opts = def { optMinTimeout = 0 } - newManager opts `shouldThrow` isSomeException - - it "should throw exception on zero optMaxTimeout" $ do - let opts = def { optMaxTimeout = 0 } - newManager opts `shouldThrow` isSomeException - - it "should throw exception on maxTimeout < minTimeout" $ do - let opts = def { optMinTimeout = 2, optMaxTimeout = 1 } - newManager opts `shouldThrow` isSomeException - - it "should throw exception on zero optMultiplier" $ do - let opts = def { optMultiplier = 0 } - newManager opts `shouldThrow` isSomeException - - describe "closeManager" $ do - it "unblock rpc calls" $ do - mgr <- newManager rpcOpts - _ <- forkIO $ do - threadDelay 10000000 - closeManager mgr - q <- arbitrarySample - announce mgr (trackerURI badTracker) q `shouldThrow` (== ManagerClosed) - - it "announce throw exception after manager closed" $ do - mgr <- newManager rpcOpts - closeManager mgr - q <- arbitrarySample - announce mgr (trackerURI badTracker) q `shouldThrow` isIOException - - it "scrape throw exception after manager closed" $ do - mgr <- newManager rpcOpts - closeManager mgr - scrape mgr (trackerURI badTracker) [def] `shouldThrow` isIOException - - describe "withManager" $ do - it "closesManager at exit" $ do - mgr <- withManager rpcOpts return - scrape mgr (trackerURI badTracker) [def] `shouldThrow` isSomeException - - describe "RPC" $ do - describe "announce" $ do - it "must fail on bad scheme" $ do - withManager rpcOpts $ \ mgr -> do - q <- arbitrarySample - announce mgr "magnet://a.com" q - `shouldThrow` (== UnrecognizedScheme "magnet:") - - describe "scrape" $ do - it "must fail on bad scheme" $ do - withManager rpcOpts $ \ mgr -> do - scrape mgr "magnet://a.com" [] - `shouldThrow` (== UnrecognizedScheme "magnet:") - - forM_ (L.filter isUdpTracker trackers) $ \ TrackerEntry {..} -> - context trackerName $ do - - describe "announce" $ do - if tryAnnounce then do - it "have valid response" $ do - withManager rpcOpts $ \ mgr -> do - q <- arbitrarySample - announce mgr trackerURI q >>= validateInfo q - else do - it "should throw TimeoutExpired" $ do - withManager rpcOpts $ \ mgr -> do - q <- arbitrarySample - announce mgr trackerURI q `shouldThrow` isTimeoutExpired - - describe "scrape" $ do - if tryScraping then do - it "have valid response" $ do - withManager rpcOpts $ \ mgr -> do - xs <- scrape mgr trackerURI [def] - L.length xs `shouldSatisfy` (>= 1) - else do - it "should throw TimeoutExpired" $ do - withManager rpcOpts $ \ mgr -> do - scrape mgr trackerURI [def] `shouldThrow` isTimeoutExpired - - describe "Manager" $ do - when tryScraping $ do - it "should handle arbitrary intermixed concurrent queries" $ do - withManager rpcOpts $ \ mgr -> do - _ <- mapConcurrently (\ _ -> scrape mgr trackerURI [def]) [1..rpcCount] - return () diff --git a/bittorrent/tests/Network/BitTorrent/Tracker/RPCSpec.hs b/bittorrent/tests/Network/BitTorrent/Tracker/RPCSpec.hs deleted file mode 100644 index dfc13a1e..00000000 --- a/bittorrent/tests/Network/BitTorrent/Tracker/RPCSpec.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Network.BitTorrent.Tracker.RPCSpec (spec) where -import Control.Applicative -import Control.Monad -import Data.Default -import Data.List as L -import Test.Hspec -import Test.QuickCheck - -import Network.BitTorrent.Tracker.RPC as RPC - -import Network.BitTorrent.Tracker.TestData -import Network.BitTorrent.Tracker.MessageSpec hiding (spec) -import qualified Network.BitTorrent.Tracker.RPC.UDPSpec as UDP (rpcOpts) - - -instance Arbitrary SAnnounceQuery where - arbitrary = SAnnounceQuery <$> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - -rpcOpts :: Options -rpcOpts = def - { optUdpRPC = UDP.rpcOpts - } - -matchUnrecognizedScheme :: String -> RpcException -> Bool -matchUnrecognizedScheme x (UnrecognizedScheme scheme) = x == scheme -matchUnrecognizedScheme _ _ = False - -spec :: Spec -spec = parallel $ do - describe "Manager" $ do - describe "newManager" $ do - it "" $ pending - - describe "closeManager" $ do - it "" $ pending - - describe "withManager" $ do - it "" $ pending - - describe "RPC" $ do - describe "announce" $ do - it "must fail on bad uri scheme" $ do - withManager rpcOpts def $ \ mgr -> do - q <- arbitrarySample - announce mgr "magnet://foo.bar" q - `shouldThrow` matchUnrecognizedScheme "magnet:" - - describe "scrape" $ do - it "must fail on bad uri scheme" $ do - withManager rpcOpts def $ \ mgr -> do - scrape mgr "magnet://foo.bar" [] - `shouldThrow` matchUnrecognizedScheme "magnet:" - - forM_ trackers $ \ TrackerEntry {..} -> - context trackerName $ do - - describe "announce" $ do - if tryAnnounce then do - it "have valid response" $ do - withManager rpcOpts def $ \ mgr -> do - q <- arbitrarySample - _ <- announce mgr trackerURI q - return () - else do - it "should throw exception" $ do - pending - - describe "scrape" $ do - if tryScraping then do - it "have valid response" $ do - withManager rpcOpts def $ \ mgr -> do - xs <- scrape mgr trackerURI [def] - L.length xs `shouldSatisfy` (>= 1) - else do - it "should throw exception" $ do - pending diff --git a/bittorrent/tests/Network/BitTorrent/Tracker/SessionSpec.hs b/bittorrent/tests/Network/BitTorrent/Tracker/SessionSpec.hs deleted file mode 100644 index 72936ee7..00000000 --- a/bittorrent/tests/Network/BitTorrent/Tracker/SessionSpec.hs +++ /dev/null @@ -1,61 +0,0 @@ -module Network.BitTorrent.Tracker.SessionSpec (spec) where -import Control.Monad -import Data.Default -import Data.List as L -import Test.Hspec - -import Data.Torrent -import Network.BitTorrent.Tracker.Message -import Network.BitTorrent.Tracker.List -import Network.BitTorrent.Tracker.RPC -import Network.BitTorrent.Tracker.Session - -import Config - -testSession :: Bool -> (Manager -> Session -> IO ()) -> IO () -testSession runEmpty action = do - t <- getTestTorrent - withManager def def $ \ m -> do - withSession m (idInfoHash (tInfoDict t)) (trackerList t) $ \ s -> - action m s - - when runEmpty $ do - withSession m (idInfoHash (tInfoDict t)) def $ \ s -> - action m s - -spec :: Spec -spec = do - describe "Session" $ do - it "start new session in paused state" $ do - testSession True $ \ _ s -> do - status <- getStatus s - status `shouldBe` Paused - - describe "Query" $ do - it "change status after notify" $ do - testSession True $ \ m s -> do - notify m s Started - status <- getStatus s - status `shouldBe` Running - - notify m s Stopped - stopped <- getStatus s - stopped `shouldBe` Paused - - it "completed event do not change status" $ do - testSession True $ \ m s -> do - notify m s Completed - status <- getStatus s - status `shouldBe` Paused - - testSession True $ \ m s -> do - notify m s Started - notify m s Completed - status <- getStatus s - status `shouldBe` Running - - it "return non-empty list of peers" $ do - testSession False $ \ m s -> do - notify m s Started - peers <- askPeers m s - peers `shouldSatisfy` (not . L.null) diff --git a/bittorrent/tests/Network/BitTorrent/Tracker/TestData.hs b/bittorrent/tests/Network/BitTorrent/Tracker/TestData.hs deleted file mode 100644 index b95e2df4..00000000 --- a/bittorrent/tests/Network/BitTorrent/Tracker/TestData.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Network.BitTorrent.Tracker.TestData - ( TrackerEntry (..) - , isUdpTracker - , isHttpTracker - , trackers - , badTracker - ) where - -import Data.Maybe -import Data.String -import Network.URI - -import Data.Torrent - - -data TrackerEntry = TrackerEntry - { -- | May be used to show tracker name in test suite report. - trackerName :: String - - -- | Announce uri of the tracker. - , trackerURI :: URI - - -- | Some trackers abadoned, so don't even try to announce. - , tryAnnounce :: Bool - - -- | Some trackers do not support scraping, so we should not even - -- try to scrape them. - , tryScraping :: Bool - - -- | Some trackers allow - , hashList :: Maybe [InfoHash] - } - -isUdpTracker :: TrackerEntry -> Bool -isUdpTracker TrackerEntry {..} = uriScheme trackerURI == "udp:" - -isHttpTracker :: TrackerEntry -> Bool -isHttpTracker TrackerEntry {..} = uriScheme trackerURI == "http:" - || uriScheme trackerURI == "https:" - -instance IsString URI where - fromString str = fromMaybe err $ parseURI str - where - err = error $ "fromString: bad URI " ++ show str - -trackerEntry :: URI -> TrackerEntry -trackerEntry uri = TrackerEntry - { trackerName = maybe "" uriRegName (uriAuthority uri) - , trackerURI = uri - , tryAnnounce = False - , tryScraping = False - , hashList = Nothing - } - -announceOnly :: String -> URI -> TrackerEntry -announceOnly name uri = (trackerEntry uri) - { trackerName = name - , tryAnnounce = True - } - -announceScrape :: String -> URI -> TrackerEntry -announceScrape name uri = (announceOnly name uri) - { tryScraping = True - } - -notWorking :: String -> URI -> TrackerEntry -notWorking name uri = (trackerEntry uri) - { trackerName = name - } - -trackers :: [TrackerEntry] -trackers = - [ (announceOnly "LinuxTracker" - "http://linuxtracker.org:2710/00000000000000000000000000000000/announce") - { hashList = Just ["1c82a95b9e02bf3db4183da072ad3ef656aacf0e"] -- debian 7 - } - - , (announceScrape "Arch" "http://tracker.archlinux.org:6969/announce") - { hashList = Just ["bc9ae647a3e6c3636de58535dd3f6360ce9f4621"] - } - - , notWorking "rarbg" "udp://9.rarbg.com:2710/announce" - - , announceScrape "OpenBitTorrent" "udp://tracker.openbittorrent.com:80/announce" - , announceScrape "PublicBT" "udp://tracker.publicbt.com:80/announce" - , notWorking "OpenBitTorrent" "http://tracker.openbittorrent.com:80/announce" - , notWorking "PublicBT" "http://tracker.publicbt.com:80/announce" - ] - -badTracker :: TrackerEntry -badTracker = notWorking "rarbg" "udp://9.rarbg.com:2710/announce" \ No newline at end of file diff --git a/bittorrent/tests/Network/KRPC/MessageSpec.hs b/bittorrent/tests/Network/KRPC/MessageSpec.hs deleted file mode 100644 index 498ef679..00000000 --- a/bittorrent/tests/Network/KRPC/MessageSpec.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Network.KRPC.MessageSpec (spec) where -import Control.Applicative -import Data.ByteString.Lazy as BL -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Instances () - -import Data.BEncode as BE -import Network.KRPC.Message - -instance Arbitrary ErrorCode where - arbitrary = arbitraryBoundedEnum - -instance Arbitrary KError where - arbitrary = KError <$> arbitrary <*> arbitrary <*> arbitrary - -instance Arbitrary KQuery where - arbitrary = KQuery <$> pure (BInteger 0) <*> arbitrary <*> arbitrary - -instance Arbitrary KResponse where - -- TODO: Abitrary instance for ReflectedIP - arbitrary = KResponse <$> pure (BList []) <*> arbitrary <*> pure Nothing - -instance Arbitrary KMessage where - arbitrary = frequency - [ (1, Q <$> arbitrary) - , (1, R <$> arbitrary) - , (1, E <$> arbitrary) - ] - -spec :: Spec -spec = do - describe "error message" $ do - it "properly bencoded (iso)" $ property $ \ ke -> - BE.decode (BL.toStrict (BE.encode ke)) `shouldBe` Right (ke :: KError) - - it "properly bencoded" $ do - BE.decode "d1:eli201e23:A Generic Error Ocurrede1:t2:aa1:y1:ee" - `shouldBe` Right (KError GenericError "A Generic Error Ocurred" "aa") - - BE.decode "d1:eli202e22:A Server Error Ocurrede1:t2:bb1:y1:ee" - `shouldBe` Right (KError ServerError "A Server Error Ocurred" "bb") - - BE.decode "d1:eli203e24:A Protocol Error Ocurrede1:t2:cc1:y1:ee" - `shouldBe` Right (KError ProtocolError "A Protocol Error Ocurred" "cc") - - BE.decode "d1:eli204e30:Attempt to call unknown methode1:t2:dd1:y1:ee" - `shouldBe` Right - (KError MethodUnknown "Attempt to call unknown method" "dd") - - describe "query message" $ do - it "properly bencoded (iso)" $ property $ \ kq -> - BE.decode (BL.toStrict (BE.encode kq)) `shouldBe` Right (kq :: KQuery) - - it "properly bencoded" $ do - BE.decode "d1:ale1:q4:ping1:t2:aa1:y1:qe" `shouldBe` - Right (KQuery (BList []) "ping" "aa") - - - describe "response message" $ do - it "properly bencoded (iso)" $ property $ \ kr -> - BE.decode (BL.toStrict (BE.encode kr)) `shouldBe` Right (kr :: KResponse) - - it "properly bencoded" $ do - BE.decode "d1:rle1:t2:aa1:y1:re" `shouldBe` - Right (KResponse (BList []) "aa" Nothing) - - describe "generic message" $ do - it "properly bencoded (iso)" $ property $ \ km -> - BE.decode (BL.toStrict (BE.encode km)) `shouldBe` Right (km :: KMessage) diff --git a/bittorrent/tests/Network/KRPC/MethodSpec.hs b/bittorrent/tests/Network/KRPC/MethodSpec.hs deleted file mode 100644 index c1c58282..00000000 --- a/bittorrent/tests/Network/KRPC/MethodSpec.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Network.KRPC.MethodSpec where -import Control.Applicative -import Data.BEncode -import Data.ByteString as BS -import Data.Typeable -import Network.KRPC -import Test.Hspec - - -data Ping = Ping - deriving (Show, Eq, Typeable) - -instance BEncode Ping where - toBEncode Ping = toBEncode () - fromBEncode b = Ping <$ (fromBEncode b :: Result ()) - -instance KRPC Ping Ping - -ping :: Monad h => Handler h -ping = handler $ \ _ Ping -> return Ping - -newtype Echo a = Echo a - deriving (Show, Eq, BEncode, Typeable) - -echo :: Monad h => Handler h -echo = handler $ \ _ (Echo a) -> return (Echo (a :: ByteString)) - -instance (Typeable a, BEncode a) => KRPC (Echo a) (Echo a) - -spec :: Spec -spec = do - describe "ping method" $ do - it "name is ping" $ do - (method :: Method Ping Ping) `shouldBe` "ping" - - it "has pretty Show instance" $ do - show (method :: Method Ping Ping) `shouldBe` "ping :: Ping -> Ping" - - describe "echo method" $ do - it "is overloadable" $ do - (method :: Method (Echo Int ) (Echo Int )) `shouldBe` "echo int" - (method :: Method (Echo Bool) (Echo Bool)) `shouldBe` "echo bool" - - it "has pretty Show instance" $ do - show (method :: Method (Echo Int) (Echo Int)) - `shouldBe` "echo int :: Echo Int -> Echo Int" \ No newline at end of file diff --git a/bittorrent/tests/Network/KRPCSpec.hs b/bittorrent/tests/Network/KRPCSpec.hs deleted file mode 100644 index eabcc817..00000000 --- a/bittorrent/tests/Network/KRPCSpec.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Network.KRPCSpec (spec) where -import Control.Monad.Logger -import Control.Monad.Reader -import Network.KRPC -import Network.KRPC.MethodSpec hiding (spec) -import Test.Hspec - -servAddr :: SockAddr -servAddr = SockAddrInet 6000 (256 * 256 * 256 + 127) - -handlers :: [Handler IO] -handlers = - [ handler $ \ _ Ping -> return Ping - , handler $ \ _ (Echo a) -> return (Echo (a :: Bool)) - , handler $ \ _ (Echo a) -> return (Echo (a :: Int)) - ] - -instance MonadLogger IO where - monadLoggerLog _ _ _ _ = return () - -opts :: Options -opts = def { optQueryTimeout = 1 } - -spec :: Spec -spec = do - let qr :: MonadKRPC h m => SockAddr -> Echo Int -> m (Echo Int) - qr = query - - describe "manager" $ do - it "is active until closeManager called" $ do - m <- newManager opts servAddr [] - isActive m `shouldReturn` True - closeManager m - isActive m `shouldReturn` False - - describe "query" $ do - it "run handlers" $ do - let int = 0xabcd :: Int - (withManager opts servAddr handlers $ runReaderT $ do - listen - query servAddr (Echo int)) - `shouldReturn` Echo int - - it "count transactions properly" $ do - (withManager opts servAddr handlers $ runReaderT $ do - listen - _ <- qr servAddr (Echo 0xabcd) - _ <- qr servAddr (Echo 0xabcd) - getQueryCount - ) - `shouldReturn` 2 - - it "throw timeout exception" $ do - (withManager opts servAddr handlers $ runReaderT $ do - qr servAddr (Echo 0xabcd) - ) - `shouldThrow` (== TimeoutExpired) diff --git a/bittorrent/tests/Readme.md b/bittorrent/tests/Readme.md deleted file mode 100644 index 7a9d8914..00000000 --- a/bittorrent/tests/Readme.md +++ /dev/null @@ -1,4 +0,0 @@ -Prerequisites -============= - -To run test suite you need rtorrent and screen installed. diff --git a/bittorrent/tests/Spec.hs b/bittorrent/tests/Spec.hs deleted file mode 100644 index b4e92e75..00000000 --- a/bittorrent/tests/Spec.hs +++ /dev/null @@ -1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-} diff --git a/bittorrent/tests/System/Torrent/FileMapSpec.hs b/bittorrent/tests/System/Torrent/FileMapSpec.hs deleted file mode 100644 index 29252925..00000000 --- a/bittorrent/tests/System/Torrent/FileMapSpec.hs +++ /dev/null @@ -1,116 +0,0 @@ --- this is test string used in the 'spec' --- don't touch me! -module System.Torrent.FileMapSpec (spec) where - -import Control.Monad.Loops -import Data.List as L -import Data.ByteString.Lazy as BL -import System.Directory -import System.FilePath -import System.IO.Temp -import Test.Hspec - -import Data.Torrent -import System.Torrent.FileMap as FM - - -withLayout :: (FileLayout FileSize -> IO ()) -> IO () -withLayout f = do - tmp <- getTemporaryDirectory - withTempDirectory tmp "bittorrentTestDir" $ \dir -> - f [ (dir "a", 2) - , (dir "b", 3) - , (dir "c", 2) - ] `seq` return () - -spec :: Spec -spec = do - describe "mmapFiles" $ do - it "creates new files" $ withLayout $ \layout -> do - m <- mmapFiles ReadWriteEx layout - unmapFiles m - - (doesFileExist . fst) `allM` layout - `shouldReturn` True - - describe "size" $ do - it "is equal to the layout size" $ withLayout $ \layout -> do - m <- mmapFiles ReadOnly layout - FM.size m `shouldBe` L.sum (L.map snd layout) - unmapFiles m - - describe "readBytes" $ do - it "read from files" $ do - let thisFile = [("tests/System/Torrent/FileMapSpec.hs", 15)] - m <- mmapFiles ReadOnly thisFile - readBytes 3 15 m `shouldReturn` "this is test" - unmapFiles m - - it "ignore underflow reads" $ withLayout $ \layout -> do - m <- mmapFiles ReadOnly layout - readBytes (-1) 1 m `shouldReturn` "" - readBytes (-5) 12 m `shouldReturn` "" - unmapFiles m - - it "crop overflow reads" $ withLayout $ \layout -> do - _m <- mmapFiles ReadWrite layout - writeBytes 5 "cc" _m - unmapFiles _m - - m <- mmapFiles ReadOnly layout - readBytes 5 10 m `shouldReturn` "cc" - unmapFiles m - - describe "writeBytes" $ do - it "writes to files" $ withLayout $ \layout -> do - m <- mmapFiles ReadWriteEx layout - writeBytes 0 "a" m - readBytes 0 1 m `shouldReturn` "a" - writeBytes 1 "ab" m - readBytes 1 2 m `shouldReturn` "ab" - writeBytes 3 "b" m - readBytes 3 1 m `shouldReturn` "b" - writeBytes 4 "bc" m - readBytes 4 2 m `shouldReturn` "bc" - writeBytes 6 "c" m - readBytes 6 1 m `shouldReturn` "c" - readBytes 0 7 m `shouldReturn` "aabbbcc" - unmapFiles m - - BL.readFile (fst (layout !! 0)) `shouldReturn` "aa" - BL.readFile (fst (layout !! 1)) `shouldReturn` "bbb" - BL.readFile (fst (layout !! 2)) `shouldReturn` "cc" - - let max_page_size = 4 * 1024 * 1024 - let long_bs = BL.replicate (fromIntegral max_page_size) 0 - - it "no buffer underflow errors" $ withLayout $ \layout -> do - m <- mmapFiles ReadWrite layout - writeBytes (1 - max_page_size) long_bs m - unmapFiles m - - it "no buffer overflow errors" $ withLayout $ \layout -> do - m <- mmapFiles ReadWrite layout - writeBytes 5 long_bs m - unmapFiles m - - it "ignore underflow writes" $ withLayout $ \layout -> do - _m <- mmapFiles ReadWrite layout - writeBytes 0 "aa" _m - unmapFiles _m - - m <- mmapFiles ReadWrite layout - writeBytes (-1) "hhh" m - unmapFiles m - BL.readFile (fst (layout !! 0)) `shouldReturn` "aa" - - it "crop overflow writes" $ withLayout $ \layout -> do - m <- mmapFiles ReadWrite layout - writeBytes 5 "ddddddddd" m - unmapFiles m - BL.readFile (fst (layout !! 2)) `shouldReturn` "dd" - - describe "from/to lazy bytestring" $ do - it "isomorphic to lazy bytestring" $ withLayout $ \layout -> do - m <- mmapFiles ReadOnly layout - fromLazyByteString (toLazyByteString m) `shouldBe` m - unmapFiles m diff --git a/bittorrent/tests/System/Torrent/StorageSpec.hs b/bittorrent/tests/System/Torrent/StorageSpec.hs deleted file mode 100644 index b5e49078..00000000 --- a/bittorrent/tests/System/Torrent/StorageSpec.hs +++ /dev/null @@ -1,91 +0,0 @@ -module System.Torrent.StorageSpec (spec) where -import Data.ByteString.Lazy as BL -import Data.Conduit as C -import Data.Conduit.List as C -import System.FilePath -import System.Directory -import System.IO.Unsafe -import Test.Hspec - -import Data.Torrent -import Network.BitTorrent.Exchange.Bitfield as BF -import System.Torrent.Storage - - -layout :: FileLayout FileSize -layout = - [ (dir "_a", 20) - , (dir "_b", 50) - , (dir "_c", 100) - , (dir "_d", 5) - ] - where - dir = unsafePerformIO $ getTemporaryDirectory - -createLayout :: IO () -createLayout = withStorage ReadWriteEx 1 layout (const (return ())) - -psize :: PieceSize -psize = 16 - -pcount :: PieceCount -pcount = 11 - -spec :: Spec -spec = before createLayout $ do - describe "writePiece" $ do - it "should fail gracefully on write operation in RO mode" $ do - withStorage ReadOnly 1 layout $ \ s -> - writePiece (Piece 0 "a") s `shouldThrow` (== StorageIsRO) - - it "should fail if piece size do not match" $ do - withStorage ReadWrite 1 layout $ \ s -> - writePiece (Piece 0 "") s `shouldThrow` (== InvalidSize 0) - - it "should fail on negative index" $ do - withStorage ReadWrite 1 layout $ \ s -> - writePiece (Piece (-1) "") s `shouldThrow` (== InvalidIndex (-1)) - - it "should fail on out of upper bound index" $ do - withStorage ReadWrite 100 layout $ \ s -> do - let bs = BL.replicate 100 0 - writePiece (Piece 0 bs) s - - let bs' = BL.replicate 75 0 - writePiece (Piece 1 bs') s - - writePiece (Piece 2 bs') s `shouldThrow` (== InvalidIndex 2) - - describe "readPiece" $ do - it "should fail on negative index" $ - withStorage ReadOnly 1 layout $ \ s -> - readPiece (-1) s `shouldThrow` (== InvalidIndex (-1)) - - it "should fail on out of upper bound index" $ do - withStorage ReadOnly 100 layout $ \ s -> do - _ <- readPiece 1 s - readPiece 2 s `shouldThrow` (== InvalidIndex 2) - - describe "sourceStorage" $ do - it "should source all chunks" $ do - withStorage ReadOnly psize layout $ \ s -> do - n <- sourceStorage s $$ C.fold (\ n _ -> succ n) 0 - n `shouldBe` pcount - - -- this test should fail if 'sourceStorage' test fail - describe "sinkStorage" $ do - it "should write all chunks" $ do - let byteVal = 0 - let bzeroPiece p = p { pieceData = BL.replicate (BL.length (pieceData p)) byteVal } - let isZeroPiece p = (== byteVal) `BL.all` pieceData p - - withStorage ReadWrite psize layout $ \ s -> do - sourceStorage s $= C.map bzeroPiece $$ sinkStorage s - b <- sourceStorage s $$ C.fold (\ b p -> b && isZeroPiece p) True - b `shouldBe` True - - describe "genPieceInfo" $ do - it "" $ do - withStorage ReadWrite psize layout $ \ s -> do - bf <- genPieceInfo s >>= getBitfield s - bf `shouldSatisfy` BF.full \ No newline at end of file -- cgit v1.2.3