7 files changed, 833 insertions, 0 deletions

diff --git a/src/Network/BitTorrent/PeerID.hs b/src/Network/BitTorrent/PeerID.hs
new file mode 100644
index 00000000..cef1fa58
--- /dev/null
+++ b/src/Network/BitTorrent/PeerID.hs
@@ -0,0 +1,205 @@
+-- TODO: tests
+-- |
+--   Copyright   :  (c) Sam T. 2013
+--   License     :  MIT
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  non-portable
+--
+--   This module provides 'Peer' and 'PeerID' datatypes and all related
+--   operations.
+--   Recommended method for generation of the peer ID's is 'newPeerID',
+--   though this module exports some other goodies for custom generation.
+--
+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}
+module Network.BitTorrent.PeerID
+       ( -- * Peer addr
+         Peer(..)
+       , peerSockAddr, connectToPeer
+
+         -- * Peer identification
+       , PeerID (getPeerID)
+
+         -- ** Encoding styles
+       , azureusStyle, shadowStyle
+
+         -- ** Defaults
+       , defaultClientID, defaultVersionNumber
+
+         -- ** Generation
+       , newPeerID, timestampByteString
+         -- ** Extra
+
+       , byteStringPadded
+       ) where
+
+import Control.Applicative
+import Data.Word
+import Data.Bits
+import Data.BEncode
+import           Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.Builder as B
+import Data.Foldable    (foldMap)
+import Data.Monoid      ((<>))
+import Data.Serialize
+import Data.URLEncoded
+import Data.Version     (Version(Version), versionBranch)
+import Data.Time.Clock  (getCurrentTime)
+import Data.Time.Format (formatTime)
+import System.Locale    (defaultTimeLocale)
+import Network
+import Network.Socket
+
+
+-- TODO we have linker error here, so manual hardcoded version for a while.
+-- import Paths_network_bittorrent (version)
+version :: Version
+version = Version [0, 10, 0, 0] []
+
+
+
+data Peer = Peer {
+      peerID   :: Maybe PeerID
+    , peerIP   :: HostAddress
+    , peerPort :: PortNumber
+    } deriving Show
+
+-- TODO make platform independent, clarify htonl
+-- | Convert peer info from tracker response to socket address.
+--   Used for establish connection between peers.
+--
+peerSockAddr :: Peer -> SockAddr
+peerSockAddr = SockAddrInet <$> (g . peerPort) <*> (htonl . peerIP)
+  where
+    htonl :: Word32 -> Word32
+    htonl d =
+       ((d .&. 0xff) `shiftL` 24) .|.
+       (((d `shiftR` 8 ) .&. 0xff) `shiftL` 16) .|.
+       (((d `shiftR` 16) .&. 0xff) `shiftL` 8)  .|.
+       ((d `shiftR` 24) .&. 0xff)
+
+    g :: PortNumber -> PortNumber
+    g = id
+
+-- ipv6 extension
+-- | Tries to connect to peer using reasonable default parameters.
+--
+connectToPeer :: Peer -> IO Socket
+connectToPeer p = do
+  sock <- socket AF_INET Stream Network.Socket.defaultProtocol
+  connect sock (peerSockAddr p)
+  return sock
+
+
+-- | Peer identifier is exactly 20 bytes long bytestring.
+newtype PeerID = PeerID { getPeerID :: ByteString }
+                 deriving (Show, Eq, Ord, BEncodable)
+
+instance Serialize PeerID where
+  put = putByteString . getPeerID
+  get = PeerID <$> getBytes 20
+
+instance URLShow PeerID where
+  urlShow = BC.unpack . getPeerID
+
+
+-- | Azureus-style encoding have the following layout:
+--
+--     * 1  byte : '-'
+--
+--     * 2  bytes: client id
+--
+--     * 4  bytes: version number
+--
+--     * 1  byte : '-'
+--
+--     * 12 bytes: random number
+--
+azureusStyle :: ByteString -- ^ 2 character client ID, padded with 'H'.
+             -> ByteString -- ^ Version number, padded with 'X'.
+             -> ByteString -- ^ Random number, padded with '0'.
+             -> PeerID     -- ^ Azureus-style encoded peer ID.
+azureusStyle cid ver rnd = PeerID $ BL.toStrict $ B.toLazyByteString $
+    B.char8 '-' <>
+      byteStringPadded cid 2  'H' <>
+      byteStringPadded ver 4  'X' <>
+    B.char8 '-' <>
+      byteStringPadded rnd 12 '0'
+
+-- | Shadow-style encoding have the following layout:
+--
+--     * 1 byte   : client id.
+--
+--     * 0-4 bytes: version number. If less than 4 then padded with '-' char.
+--
+--     * 15 bytes : random number. If length is less than 15 then padded with '0' char.
+--
+shadowStyle :: Char       -- ^ Client ID.
+            -> ByteString -- ^ Version number.
+            -> ByteString -- ^ Random number.
+            -> PeerID     -- ^ Shadow style encoded peer ID.
+shadowStyle cid ver rnd = PeerID $ BL.toStrict $ B.toLazyByteString $
+    B.char8 cid <>
+      byteStringPadded ver 4  '-' <>
+      byteStringPadded rnd 15 '0'
+
+
+-- | "HS" - 2 bytes long client identifier.
+defaultClientID :: ByteString
+defaultClientID = "HS"
+
+-- | Gives exactly 4 bytes long version number for any version of the package.
+--   Version is taken from .cabal.
+defaultVersionNumber :: ByteString
+defaultVersionNumber = B.take 4 (BC.pack (foldMap show (versionBranch version)))
+
+-- | Gives 15 characters long decimal timestamp such that:
+--
+--     * 6 bytes   : first 6 characters from picoseconds obtained with %q.
+--
+--     * 1 bytes   : character '.' for readability.
+--
+--     * 9..* bytes: number of whole seconds since the Unix epoch (!)REVERSED.
+--
+--   Can be used both with shadow and azureus style encoding. This format is
+--   used to make the ID's readable(for debugging) and more or less random.
+--
+timestampByteString :: IO ByteString
+timestampByteString = (BC.pack . format) <$> getCurrentTime
+  where
+    format t = take 6 (formatTime defaultTimeLocale "%q" t) ++ "." ++
+               take 9 (reverse (formatTime defaultTimeLocale "%s" t))
+
+-- |  Here we use Azureus-style encoding with the following args:
+--
+--      * 'HS' for the client id.
+--
+--      * Version of the package for the version number
+--
+--      * UTC time day ++ day time for the random number.
+--
+newPeerID :: IO PeerID
+newPeerID = azureusStyle defaultClientID defaultVersionNumber
+                                     <$> timestampByteString
+
+-- | Pad bytestring so it's becomes exactly request length. Conversion is done
+--   like so:
+--
+--     * length < size: Complete bytestring by given charaters.
+--
+--     * length = size: Output bytestring as is.
+--
+--     * length > size: Drop last (length - size) charaters from a given bytestring.
+--
+byteStringPadded :: ByteString -- ^ bytestring to be padded.
+                 -> Int        -- ^ size of result builder.
+                 -> Char       -- ^ character used for padding.
+                 -> B.Builder
+byteStringPadded bs s c =
+      B.byteString (B.take s bs) <>
+      B.byteString (BC.replicate padLen c)
+  where
+    padLen = s - min (B.length bs) s
\ No newline at end of file
diff --git a/src/Network/BitTorrent/PeerWire.hs b/src/Network/BitTorrent/PeerWire.hs
new file mode 100644
index 00000000..768da5f2
--- /dev/null
+++ b/src/Network/BitTorrent/PeerWire.hs
@@ -0,0 +1,17 @@
+-- |
+--   Copyright   :  (c) Sam T. 2013
+--   License     :  MIT
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
+{-# LANGUAGE DoAndIfThenElse #-}
+module Network.BitTorrent.PeerWire
+       ( module Network.BitTorrent.PeerWire.Block
+       , module Network.BitTorrent.PeerWire.Message
+       , module Network.BitTorrent.PeerWire.Handshake
+       ) where
+
+import Network.BitTorrent.PeerWire.Block
+import Network.BitTorrent.PeerWire.Message
+import Network.BitTorrent.PeerWire.Handshake
diff --git a/src/Network/BitTorrent/PeerWire/Block.hs b/src/Network/BitTorrent/PeerWire/Block.hs
new file mode 100644
index 00000000..33e3dead
--- /dev/null
+++ b/src/Network/BitTorrent/PeerWire/Block.hs
@@ -0,0 +1,56 @@
+module Network.BitTorrent.PeerWire.Block
+       ( BlockIx(..), Block(..)
+       , defaultBlockSize
+       , blockRange, ixRange, pieceIx
+       , isPiece
+       ) where
+
+import           Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import Data.Int
+
+
+data BlockIx = BlockIx {
+    ixPiece  :: {-# UNPACK #-} !Int -- ^ Zero-based piece index.
+  , ixOffset :: {-# UNPACK #-} !Int -- ^ Zero-based byte offset within the piece.
+  , ixLength :: {-# UNPACK #-} !Int -- ^ Block size starting from offset.
+  } deriving (Show, Eq)
+
+data Block = Block {
+    blkPiece  :: Int         -- ^ Zero-based piece index.
+  , blkOffset :: Int         -- ^ Zero-based byte offset within the piece.
+  , blkData   :: ByteString  -- ^ Payload.
+  } deriving (Show, Eq)
+
+
+-- | Widely used semi-official block size.
+defaultBlockSize :: Int
+defaultBlockSize = 16 * 1024
+
+
+isPiece :: Int -> Block -> Bool
+isPiece pieceSize (Block i offset bs) =
+  offset == 0 && B.length bs == pieceSize && i >= 0
+{-# INLINE isPiece #-}
+
+pieceIx :: Int -> Int -> BlockIx
+pieceIx i = BlockIx i 0
+{-# INLINE pieceIx #-}
+
+blockRange :: (Num a, Integral a) => Int -> Block -> (a, a)
+blockRange pieceSize blk = (offset, offset + len)
+  where
+    offset = fromIntegral pieceSize * fromIntegral (blkPiece blk)
+           + fromIntegral (blkOffset blk)
+    len    = fromIntegral (B.length (blkData blk))
+{-# INLINE blockRange #-}
+{-# SPECIALIZE blockRange :: Int -> Block -> (Int64, Int64) #-}
+
+ixRange :: (Num a, Integral a) => Int -> BlockIx -> (a, a)
+ixRange pieceSize ix = (offset, offset + len)
+  where
+    offset = fromIntegral  pieceSize * fromIntegral (ixPiece ix)
+           + fromIntegral (ixOffset ix)
+    len    = fromIntegral (ixLength ix)
+{-# INLINE ixRange #-}
+{-# SPECIALIZE ixRange :: Int -> BlockIx -> (Int64, Int64) #-}
diff --git a/src/Network/BitTorrent/PeerWire/Handshake.hs b/src/Network/BitTorrent/PeerWire/Handshake.hs
new file mode 100644
index 00000000..6ce37887
--- /dev/null
+++ b/src/Network/BitTorrent/PeerWire/Handshake.hs
@@ -0,0 +1,79 @@
+-- |
+--   Copyright   :  (c) Sam T. 2013
+--   License     :  MIT
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
+{-# LANGUAGE OverloadedStrings #-}
+module Network.BitTorrent.PeerWire.Handshake
+       ( Handshake
+       , handshakeMaxSize
+       , defaultBTProtocol, defaultReserved, defaultHandshake
+       , handshake
+       ) where
+
+import Control.Applicative
+import Data.Word
+import           Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import Data.Serialize as S
+import Data.Torrent.InfoHash
+import Network
+import Network.Socket.ByteString
+
+import Network.BitTorrent.PeerID
+
+
+-- | 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.
+data Handshake = Handshake {
+    hsProtocol    :: ByteString  -- ^ Identifier of the protocol.
+  , hsReserved    :: Word64      -- ^ Reserved bytes, rarely used.
+  , hsInfoHash    :: InfoHash    -- ^ Hash from the metainfo file.
+    -- This /should be/ same hash that is transmitted in tracker requests.
+  , hsPeerID      :: PeerID      -- ^ Peer id of the initiator.
+    -- This is /usually the same peer id that is transmitted in tracker requests.
+  } deriving (Show, Eq)
+
+instance Serialize Handshake where
+  put hs = do
+    putWord8 (fromIntegral (B.length (hsProtocol hs)))
+    putByteString (hsProtocol hs)
+    putWord64be   (hsReserved hs)
+    put (hsInfoHash hs)
+    put (hsPeerID hs)
+
+  get = do
+    len  <- getWord8
+    Handshake <$> getBytes (fromIntegral len)
+              <*> getWord64be
+              <*> get
+              <*> get
+
+-- | Maximum size of handshake message in bytes.
+handshakeMaxSize :: Int
+handshakeMaxSize = 1 + 256 + 8 + 20 + 20
+
+-- | Default protocol string "BitTorrent protocol" as is.
+defaultBTProtocol :: ByteString
+defaultBTProtocol = "BitTorrent protocol"
+
+-- | Default reserved word is 0.
+defaultReserved :: Word64
+defaultReserved = 0
+
+-- | Length of info hash and peer id is unchecked, so it /should/ be equal 20.
+defaultHandshake :: InfoHash -> PeerID -> Handshake
+defaultHandshake = Handshake defaultBTProtocol defaultReserved
+
+
+-- TODO check if hash the same
+-- | Handshaking with a peer specified by the second argument.
+--
+handshake :: Socket -> Handshake -> IO (Either String Handshake)
+handshake sock hs = do
+  sendAll sock (S.encode hs)
+  r <- recv sock handshakeMaxSize
+  return (S.decode r)
diff --git a/src/Network/BitTorrent/PeerWire/Message.hs b/src/Network/BitTorrent/PeerWire/Message.hs
new file mode 100644
index 00000000..1bcb2ee5
--- /dev/null
+++ b/src/Network/BitTorrent/PeerWire/Message.hs
@@ -0,0 +1,91 @@
+module Network.BitTorrent.PeerWire.Message
+       ( Message(..)
+       ) where
+
+import Control.Applicative
+import           Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+
+import Data.Serialize
+
+import Network.BitTorrent.PeerWire.Block
+
+
+-- TODO comment message constructors
+data Message = KeepAlive
+             | Choke
+             | Unchoke
+             | Interested
+             | NotInterested
+             | Have     Int
+             | Bitfield ByteString
+             | Request  BlockIx
+             | Piece    Block
+             | Cancel   BlockIx
+             | Port     Int
+               deriving (Show, Eq)
+
+instance Serialize BlockIx where
+  {-# SPECIALIZE instance Serialize BlockIx #-}
+  get = BlockIx <$> getInt <*> getInt <*> getInt
+  {-# INLINE get #-}
+
+  put ix = do putInt (ixPiece ix)
+              putInt (ixOffset ix)
+              putInt (ixLength ix)
+  {-# INLINE put #-}
+
+instance Serialize Message where
+  get = do
+    len <- getInt
+    lookAhead $ ensure len
+    if len == 0 then return KeepAlive -- FIX check if BS is empty instead of reading len
+      else do
+        mid <- getWord8
+        case mid of
+          0 -> return Choke
+          1 -> return Unchoke
+          2 -> return Interested
+          3 -> return NotInterested
+          4 -> Have     <$> getInt
+          5 -> Bitfield <$> getBytes (pred len)
+          6 -> Request  <$> get
+          7 -> Piece    <$> getBlock (len - 9)
+          8 -> Cancel   <$> get
+          9 -> (Port . fromIntegral) <$> getWord16be
+          _ -> fail $ "unknown message ID: " ++ show mid
+
+    where
+      getBlock :: Int -> Get Block
+      getBlock len = Block <$> getInt <*> getInt <*> getBytes len
+      {-# INLINE getBlock #-}
+
+  put KeepAlive     = putInt 0
+  put Choke         = putInt 1  >> putWord8 0
+  put Unchoke       = putInt 1  >> putWord8 1
+  put Interested    = putInt 1  >> putWord8 2
+  put NotInterested = putInt 1  >> putWord8 3
+  put (Have i)      = putInt 5  >> putWord8 4 >> putInt i
+  put (Bitfield b)  = putInt l  >> putWord8 5 >> putByteString b
+    where l = succ (B.length b)
+          {-# INLINE l #-}
+  put (Request blk) = putInt 13 >> putWord8 6 >> put blk
+  put (Piece   blk) = putInt l  >> putWord8 7 >> putBlock
+    where l = 9 + B.length (blkData blk)
+          {-# INLINE l #-}
+          putBlock = do putInt (blkPiece blk)
+                        putInt (blkOffset  blk)
+                        putByteString (blkData blk)
+          {-# INLINE putBlock #-}
+
+  put (Cancel  blk) = putInt 13 >> putWord8 8 >> put blk
+  put (Port    p  ) = putInt 3  >> putWord8 9 >> putWord16be (fromIntegral p)
+
+
+getInt :: Get Int
+getInt = fromIntegral <$> getWord32be
+{-# INLINE getInt #-}
+
+putInt :: Putter Int
+putInt = putWord32be . fromIntegral
+{-# INLINE putInt #-}
diff --git a/src/Network/BitTorrent/Tracker.hs b/src/Network/BitTorrent/Tracker.hs
new file mode 100644
index 00000000..3cafbe1d
--- /dev/null
+++ b/src/Network/BitTorrent/Tracker.hs
@@ -0,0 +1,272 @@
+-- TODO: add "compact" field to TRequest
+-- |
+--   Copyright   :  (c) Sam T. 2013
+--   License     :  MIT
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  non-portable
+--
+{-# OPTIONS -fno-warn-orphans #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Network.BitTorrent.Tracker
+       ( module Network.BitTorrent.Tracker.Scrape
+
+         -- * Requests
+       , Event(..), TRequest(..)
+       , startedReq, regularReq, stoppedReq, completedReq
+
+         -- * Responses
+       , TResponse(..)
+       , sendRequest
+
+         -- * Defaults
+       , defaultPorts, defaultNumWant
+       )
+       where
+
+import Control.Applicative
+import Data.Char as Char
+import Data.Word (Word32)
+import Data.List as L
+import Data.Map  as M
+import Data.Monoid
+import Data.BEncode
+import Data.ByteString as B
+import           Data.ByteString.Char8 as BC
+import           Data.Text as T
+import Data.Serialize.Get hiding (Result)
+import Data.URLEncoded as URL
+import Data.Torrent
+
+import Network
+import Network.Socket
+import Network.HTTP
+import Network.URI
+
+import Network.BitTorrent.PeerID
+import Network.BitTorrent.Tracker.Scrape
+
+
+data Event = Started   -- ^ For first request.
+           | Stopped   -- ^ Sent when the peer is shutting down.
+           | Completed -- ^ To be sent when the peer completes a download.
+             deriving (Show, Read, Eq, Ord, Enum, Bounded)
+
+data TRequest = TRequest { -- TODO peer here -- TODO detach announce
+     reqAnnounce   :: URI         -- ^ Announce url of the torrent.
+   , reqInfoHash   :: InfoHash    -- ^ Hash of info part of the torrent.
+   , reqPeerID     :: PeerID      -- ^ Id of the peer doing request. ()
+   , reqPort       :: PortNumber  -- ^ Port to listen to for connection from other peers.
+   , reqUploaded   :: Integer     -- ^ # of bytes that the peer has uploaded in the swarm.
+   , reqDownloaded :: Integer     -- ^ # of bytes downloaded in the swarm by the peer.
+   , reqLeft       :: Integer     -- ^ # of bytes needed in order to complete download.
+   , reqIP         :: Maybe HostAddress    -- ^ The peer IP.
+   , reqNumWant    :: Maybe Int   -- ^ Number of peers that the peers wants to receive from.
+   , reqEvent      :: Maybe Event -- ^ If not specified,
+                                  --   the request is regular periodic request.
+   } deriving Show
+
+data TResponse =
+     Failure Text           -- ^ Failure reason in human readable form.
+   | OK {
+       respWarning     :: Maybe Text
+     , respInterval    :: Int       -- ^ Recommended interval to wait between requests.
+     , respMinInterval :: Maybe Int -- ^ Minimal amount of time between requests.
+     , respComplete    :: Maybe Int -- ^ Number of peers completed the torrent. (seeders)
+     , respIncomplete  :: Maybe Int -- ^ Number of peers downloading the torrent.
+     , respPeers       :: [Peer]    -- ^ Peers that must be contacted.
+     } deriving Show
+
+instance BEncodable PortNumber where
+  toBEncode = toBEncode . fromEnum
+  fromBEncode b = toEnum <$> fromBEncode b
+
+instance BEncodable Peer where
+  toBEncode (Peer pid pip pport) = fromAssocs
+    [ "peer id" -->? pid
+    , "ip"      -->  pip
+    , "port"    -->  pport
+    ]
+
+  fromBEncode (BDict d) =
+    Peer <$> d >--? "peer id"
+         <*> d >--  "ip"
+         <*> d >--  "port"
+
+  fromBEncode _ = decodingError "Peer"
+
+instance BEncodable TResponse where
+  toBEncode (Failure t)  = fromAssocs ["failure reason" --> t]
+  toBEncode resp@(OK {}) = fromAssocs
+    [ "interval"     -->  respInterval resp
+    , "min interval" -->? respMinInterval resp
+    , "complete"     -->? respComplete resp
+    , "incomplete"   -->? respIncomplete resp
+    , "peers"        -->  respPeers resp
+    ]
+
+  fromBEncode (BDict d)
+    | Just t <- M.lookup "failure reason" d = Failure <$> fromBEncode t
+    | otherwise = OK <$> d >--? "warning message"
+                     <*> d >--  "interval"
+                     <*> d >--? "min interval"
+                     <*> d >--? "complete"
+                     <*> d >--? "incomplete"
+                     <*> getPeers (M.lookup "peers" d)
+
+      where
+        getPeers :: Maybe BEncode -> Result [Peer]
+        getPeers (Just (BList l))     = fromBEncode (BList l)
+        getPeers (Just (BString s))
+            | B.length s `mod` 6 == 0 =
+              let cnt = B.length s `div` 6 in
+              runGet (sequence (L.replicate cnt peerG)) s
+            | otherwise = decodingError "peers length not a multiple of 6"
+          where
+            peerG = do
+              pip   <- getWord32be
+              pport <- getWord16be
+              return (Peer Nothing (fromIntegral pip) (fromIntegral pport))
+
+        getPeers _ = decodingError "Peers"
+
+  fromBEncode _ = decodingError "TResponse"
+
+
+instance URLShow PortNumber where
+  urlShow = urlShow . fromEnum
+
+instance URLShow Word32 where
+  urlShow = show
+
+instance URLShow Event where
+  urlShow e = urlShow (Char.toLower x : xs)
+    where
+      -- this is always nonempty list
+      (x : xs) = show e
+
+instance URLEncode TRequest where
+  urlEncode req = mconcat
+      [ s "peer_id"    %=  reqPeerID req
+      , s "port"       %=  reqPort req
+      , s "uploaded"   %=  reqUploaded req
+      , s "downloaded" %=  reqDownloaded req
+      , s "left"       %=  reqLeft req
+      , s "ip"         %=? reqIP req
+      , s "numwant"    %=? reqNumWant req
+      , s "event"      %=? reqEvent req
+      ]
+    where s :: String -> String;  s = id; {-# INLINE s #-}
+
+encodeRequest :: TRequest -> URI
+encodeRequest req = URL.urlEncode req
+                    `addToURI`      reqAnnounce req
+                    `addHashToURI`  reqInfoHash req
+
+
+-- | Ports typically reserved for bittorrent.
+defaultPorts :: [PortNumber]
+defaultPorts = [6881..6889]
+
+-- | 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. So default value is set to 25.
+--
+defaultNumWant :: Int
+defaultNumWant = 25
+
+
+-- | 'TSession' (shorthand for Tracker session) combines tracker request
+--   fields neccessary for tracker, torrent and client identification.
+--   This data is considered as static within one session.
+--
+data TSession = TSession {
+    tsesAnnounce :: URI        -- ^ Announce URL.
+  , tsesInfoHash :: InfoHash   -- ^ Hash of info part of current .torrent file.
+  , tsesPeerID   :: PeerID     -- ^ Client peer ID.
+  , tsesPort     :: PortNumber -- ^ The port number the client is listenning on.
+  } deriving Show
+
+-- | 'Progress' contains upload/download/left stats about
+--   current client state.
+--   This data is considered as dynamic within one session.
+--
+data Progress = Progress {
+    prUploaded   :: Integer -- ^ Total amount of bytes uploaded.
+  , prDownloaded :: Integer -- ^ Total amount of bytes downloaded.
+  , prLeft       :: Integer -- ^ Total amount of bytes left.
+  } deriving Show
+
+-- | used to avoid boilerplate; do NOT export me
+genericReq :: TSession -> Progress -> TRequest
+genericReq ses pr =   TRequest {
+    reqAnnounce   = tsesAnnounce ses
+  , reqInfoHash   = tsesInfoHash ses
+  , reqPeerID     = tsesPeerID   ses
+  , reqPort       = tsesPort     ses
+
+  , reqUploaded   = prUploaded   pr
+  , reqDownloaded = prDownloaded pr
+  , reqLeft       = prLeft       pr
+
+  , reqIP         = Nothing
+  , reqNumWant    = Nothing
+  , reqEvent      = Nothing
+  }
+
+
+-- | The first request to the tracker that should be created is 'startedReq'.
+--   It includes necessary 'Started' event field.
+--
+startedReq :: TSession -> Progress -> TRequest
+startedReq ses pr = (genericReq ses pr) {
+    reqIP         = Nothing
+  , reqNumWant    = Just defaultNumWant
+  , reqEvent      = Just Started
+  }
+
+-- | Regular request must be sent to keep track new peers and
+--   notify tracker about current state of the client
+--   so new peers could connect to the client.
+--
+regularReq :: Int -> TSession -> Progress -> TRequest
+regularReq numWant ses pr = (genericReq ses pr) {
+    reqIP         = Nothing
+  , reqNumWant    = Just numWant
+  , reqEvent      = Nothing
+  }
+
+-- | Must be sent to the tracker if the client is shutting down gracefully.
+--
+stoppedReq :: TSession -> Progress -> TRequest
+stoppedReq ses pr = (genericReq ses pr) {
+    reqIP         = Nothing
+  , reqNumWant    = Nothing
+  , reqEvent      = Just Stopped
+  }
+
+-- | Must be sent to the tracker when the download completes.
+--   However, must not be sent if the download was already 100% complete.
+--
+completedReq :: TSession -> Progress -> TRequest
+completedReq ses pr = (genericReq ses pr) {
+    reqIP         = Nothing
+  , reqNumWant    = Nothing
+  , reqEvent      = Just Completed
+  }
+
+
+-- | TODO rename to ask for peers
+--
+sendRequest :: TRequest -> IO (Result TResponse)
+sendRequest req = do
+  let r = mkHTTPRequest (encodeRequest req)
+
+  rawResp  <- simpleHTTP r
+  respBody <- getResponseBody rawResp
+  return (decoded (BC.pack respBody))
+
+  where
+    mkHTTPRequest :: URI -> Request String
+    mkHTTPRequest uri = Request uri GET [] ""
diff --git a/src/Network/BitTorrent/Tracker/Scrape.hs b/src/Network/BitTorrent/Tracker/Scrape.hs
new file mode 100644
index 00000000..49451a57
--- /dev/null
+++ b/src/Network/BitTorrent/Tracker/Scrape.hs
@@ -0,0 +1,113 @@
+-- |
+--   Copyright   :  (c) Sam T. 2013
+--   License     :  MIT
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
+--   By convention most trackers support anouther form of request,
+--   which queries the state of a given torrent (or all torrents) that the
+--   tracker is managing. This module provides a way to easily request
+--   scrape info for a particular torrent list.
+--
+{-# LANGUAGE OverloadedStrings #-}
+module Network.BitTorrent.Tracker.Scrape
+       ( ScrapeInfo(..), Scrape
+       , scrapeURL
+
+         -- * Requests
+       , scrape
+       , scrapeOne
+       ) where
+
+import Control.Applicative
+import Data.BEncode
+import           Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as BC
+import           Data.Map (Map)
+import qualified Data.Map as M
+import Data.Monoid
+import Data.Torrent.InfoHash
+import Network.URI
+import Network.HTTP
+
+-- | Information about particular torrent.
+data ScrapeInfo = ScrapeInfo {
+    siComplete   :: Int
+    -- ^ Number of seeders - peers with the entire file.
+  , siDownloaded :: Int
+    -- ^ Total number of times the tracker has registered a completion.
+  , siIncomplete :: Int
+    -- ^ Number of leechers.
+  , siName       :: Maybe ByteString
+    -- ^ Name of the torrent file, as specified by the "name"
+    --   file in the info section of the .torrent file.
+  } deriving (Show, Eq)
+
+-- | Scrape info about a set of torrents.
+type Scrape = Map InfoHash ScrapeInfo
+
+instance BEncodable ScrapeInfo where
+  toBEncode si = fromAssocs
+    [ "complete"   -->  siComplete si
+    , "downloaded" -->  siDownloaded si
+    , "incomplete" -->  siIncomplete si
+    , "name"       -->? siName si
+    ]
+
+  fromBEncode (BDict d) =
+    ScrapeInfo <$> d >--  "complete"
+               <*> d >--  "downloaded"
+               <*> d >--  "incomplete"
+               <*> d >--? "name"
+  fromBEncode _ = decodingError "ScrapeInfo"
+
+-- | Trying to convert /announce/ URL to /scrape/ URL. If 'scrapeURL'
+--   gives 'Nothing' then tracker do not support scraping. The info hash
+--   list is used to restrict the tracker's report to that particular
+--   torrents. Note that scrapping of multiple torrents may not be
+--   supported. (Even if scrapping convention is supported)
+--
+scrapeURL :: URI -> [InfoHash] -> Maybe URI
+scrapeURL uri ihs = do
+  newPath <- replace (BC.pack (uriPath uri))
+  let newURI = uri { uriPath = BC.unpack newPath }
+  return (foldl addHashToURI newURI ihs)
+ where
+    replace :: ByteString -> Maybe ByteString
+    replace p
+      | ps <- BC.splitWith (== '/') p
+      , "announce" `B.isPrefixOf` last ps
+      = let newSuff = "scrape" <> B.drop (B.length "announce") (last ps)
+        in Just (B.intercalate "/" (init ps ++ [newSuff]))
+      | otherwise = Nothing
+
+
+-- | 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.
+--   Note that the 'URI' should be /announce/ URI, not /scrape/ URI.
+--
+scrape :: URI                -- ^ Announce 'URI'.
+       -> [InfoHash]         -- ^ Torrents to be scrapped.
+       -> IO (Result Scrape) -- ^ 'ScrapeInfo' for each torrent.
+scrape announce ihs
+  | Just uri<- scrapeURL announce ihs = do
+    rawResp  <- simpleHTTP (Request uri GET [] "")
+    respBody <- getResponseBody rawResp
+    return (decoded (BC.pack respBody))
+
+  | otherwise = return (Left "Tracker do not support scraping")
+
+-- | More particular version of 'scrape', just for one torrent.
+--
+scrapeOne :: URI                     -- ^ Announce 'URI'
+          -> InfoHash                -- ^ Hash of the torrent info.
+          -> IO (Result ScrapeInfo)  -- ^ 'ScrapeInfo' for the torrent.
+scrapeOne uri ih = extract <$> scrape uri [ih]
+  where
+    extract (Right m)
+      | Just s <- M.lookup ih m = Right s
+      | otherwise = Left "unable to find info hash in response dict"
+    extract (Left e) = Left e