1 files changed, 406 insertions, 0 deletions

diff --git a/src/Network/BitTorrent/Tracker/Message.hs b/src/Network/BitTorrent/Tracker/Message.hs
new file mode 100644
index 00000000..8f4c9228
--- /dev/null
+++ b/src/Network/BitTorrent/Tracker/Message.hs
@@ -0,0 +1,406 @@
+-- |
+--   Copyright   :  (c) Sam Truzjan 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 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 FlexibleInstances          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# OPTIONS -fno-warn-orphans           #-}
+module Network.BitTorrent.Tracker.Protocol
+       ( -- * Announce
+         Event(..)
+       , AnnounceQuery(..)
+       , AnnounceInfo(..)
+
+         -- ** Defaults
+       , defaultNumWant
+       , defaultPorts
+
+         -- * Scrape
+       , ScrapeQuery
+       , ScrapeInfo(..)
+       , Scrape
+
+         -- * TODO
+       , Tracker(..)
+       , scrapeOne
+       )
+       where
+
+import Control.Applicative
+import Control.Exception
+import Control.Monad
+import Data.Aeson (ToJSON, FromJSON)
+import Data.Aeson.TH
+import Data.BEncode as BE
+import Data.BEncode.BDict as BE
+import Data.Char as Char
+import Data.List as L
+import Data.Map  as M
+import Data.Maybe
+import Data.Monoid
+import Data.Serialize as S hiding (Result)
+import Data.Text (Text)
+import Data.Text.Encoding
+import Data.Typeable
+import Data.URLEncoded as URL
+import Data.Word
+import Network
+import Network.URI
+import Network.Socket
+
+import Data.Torrent.InfoHash
+import Data.Torrent.Progress
+import Network.BitTorrent.Core.PeerId
+import Network.BitTorrent.Core.PeerAddr
+
+{-----------------------------------------------------------------------
+  Announce messages
+-----------------------------------------------------------------------}
+
+-- | Events used to specify which kind of tracker request is performed.
+data Event = Started
+             -- ^ For the first request: when a peer join the swarm.
+           | 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, Typeable)
+
+$(deriveJSON (L.map toLower . L.dropWhile isLower) ''Event)
+
+-- | 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 {
+     reqInfoHash   :: !InfoHash
+     -- ^ Hash of info part of the torrent usually obtained from
+     -- 'Torrent'.
+
+   , reqPeerId     :: !PeerId
+     -- ^ ID of the peer doing request.
+
+   , reqPort       :: !PortNumber
+     -- ^ Port to listen to for connections from other
+     -- peers. Normally, tracker should respond with this port when
+     -- some peer request the tracker with the same info hash.
+
+   , reqProgress   :: !Progress
+     -- ^ Current progress of peer doing request.
+
+   , reqIP         :: Maybe HostAddress
+     -- ^ The peer IP. Needed only when client communicated with
+     -- tracker throught a proxy.
+
+   , reqNumWant    :: Maybe Int
+     -- ^ Number of peers that the peers wants to receive from. See
+     -- note for 'defaultNumWant'.
+
+   , reqEvent      :: Maybe Event
+      -- ^ If not specified, the request is regular periodic request.
+   } deriving (Show, Typeable)
+
+$(deriveJSON (L.map toLower . L.dropWhile isLower) ''AnnounceQuery)
+
+newtype PeerList = PeerList { getPeerList :: [PeerAddr] }
+                   deriving (Show, Eq, ToJSON, FromJSON, Typeable)
+
+-- | 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.
+     , respInterval    :: !Int
+
+       -- | Minimal amount of time between requests. 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
+
+       -- | Human readable warning.
+     , respWarning     :: !(Maybe Text)
+     } deriving (Show, Typeable)
+
+$(deriveJSON (L.map toLower . L.dropWhile isLower) ''AnnounceInfo)
+
+-- | Ports typically reserved for bittorrent P2P listener.
+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 the default value is set to 50 because usually 30-50% of peers
+--   are not responding.
+--
+defaultNumWant :: Int
+defaultNumWant = 50
+
+{-----------------------------------------------------------------------
+  Bencode announce encoding
+-----------------------------------------------------------------------}
+
+instance BEncode PeerList where
+  toBEncode   (PeerList xs) = toBEncode xs
+  fromBEncode (BList    l ) = PeerList <$> fromBEncode (BList l)
+  fromBEncode (BString  s ) = PeerList <$> runGet getCompactPeerList s
+  fromBEncode  _            = decodingError "Peer list"
+
+-- | 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"           .=! respPeers
+    .: "warning message" .=? respWarning
+    .: endDict
+
+  fromBEncode (BDict d)
+    | Just t <- BE.lookup "failure reason" d = Failure <$> fromBEncode t
+    | otherwise = (`fromDict` (BDict d)) $ do
+      AnnounceInfo
+        <$>? "complete"
+        <*>? "incomplete"
+        <*>! "interval"
+        <*>? "min interval"
+        <*>! "peers"
+        <*>? "warning message"
+  fromBEncode _ = decodingError "Announce info"
+
+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
+      -- INVARIANT: this is always nonempty list
+      (x : xs) = show e
+
+instance URLShow Word64 where
+  urlShow = show
+
+instance URLEncode Progress where
+  urlEncode Progress {..} = mconcat
+    [ s "uploaded"   %=  _uploaded
+    , s "left"       %=  _left
+    , s "downloaded" %=  _downloaded
+    ]
+    where s :: String -> String;  s = id; {-# INLINE s #-}
+
+-- | HTTP tracker protocol compatible encoding.
+instance URLEncode AnnounceQuery where
+  urlEncode AnnounceQuery {..} = mconcat
+      [ s "peer_id"    %=  reqPeerId
+      , s "port"       %=  reqPort
+      , urlEncode reqProgress
+
+
+      , s "ip"         %=? reqIP
+      , s "numwant"    %=? reqNumWant
+      , s "event"      %=? reqEvent
+      ]
+    where s :: String -> String;  s = id; {-# INLINE s #-}
+
+{-----------------------------------------------------------------------
+  Binary announce encoding
+-----------------------------------------------------------------------}
+
+type EventId = Word32
+
+eventId :: Event -> EventId
+eventId Completed = 1
+eventId Started   = 2
+eventId Stopped   = 3
+
+-- TODO add Regular event
+putEvent :: Putter (Maybe Event)
+putEvent Nothing  = putWord32be 0
+putEvent (Just e) = putWord32be (eventId e)
+
+getEvent :: S.Get (Maybe Event)
+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"
+
+-- | UDP tracker protocol compatible encoding.
+instance Serialize AnnounceQuery where
+  put AnnounceQuery {..} = do
+    put           reqInfoHash
+    put           reqPeerId
+    put           reqProgress
+    putEvent      reqEvent
+    putWord32be $ 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
+      }
+
+-- | 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 get
+
+    return $ AnnounceInfo {
+        respWarning     = Nothing
+      , respInterval    = fromIntegral interval
+      , respMinInterval = Nothing
+      , respIncomplete  = Just $ fromIntegral leechers
+      , respComplete    = Just $ fromIntegral seeders
+      , respPeers       = PeerList peers
+      }
+
+{-----------------------------------------------------------------------
+  Scrape messages
+-----------------------------------------------------------------------}
+
+type ScrapeQuery = [InfoHash]
+
+-- | Overall information about particular torrent.
+data ScrapeInfo = ScrapeInfo {
+    -- | 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)
+
+$(deriveJSON (L.map toLower . L.dropWhile isLower) ''ScrapeInfo)
+
+-- TODO hash map
+-- | Scrape info about a set of torrents.
+type Scrape = Map InfoHash ScrapeInfo
+
+-- | HTTP tracker protocol compatible encoding.
+instance BEncode ScrapeInfo where
+  toBEncode ScrapeInfo {..} = toDict $
+       "complete"   .=! siComplete
+    .: "downloaded" .=! siDownloaded
+    .: "incomplete" .=! siIncomplete
+    .: "name"       .=? siName
+    .: endDict
+
+  fromBEncode = fromDict $ do
+    ScrapeInfo <$>! "complete"
+               <*>! "downloaded"
+               <*>! "incomplete"
+               <*>? "name"
+
+-- | UDP tracker protocol complatble encoding.
+instance Serialize ScrapeInfo where
+  put ScrapeInfo {..} = do
+    putWord32be $ fromIntegral siComplete
+    putWord32be $ fromIntegral siDownloaded
+    putWord32be $ fromIntegral siIncomplete
+
+  get = do
+    seeders   <- getWord32be
+    downTimes <- getWord32be
+    leechers  <- getWord32be
+
+    return $ ScrapeInfo {
+        siComplete   = fromIntegral seeders
+      , siDownloaded = fromIntegral downTimes
+      , siIncomplete = fromIntegral leechers
+      , siName       = Nothing
+      }
+
+-- | Set of tracker RPCs.
+class Tracker s where
+  connect  :: URI -> IO s
+  announce :: s -> AnnounceQuery -> IO AnnounceInfo
+  scrape   :: s -> ScrapeQuery   -> IO Scrape
+
+-- | More particular version of 'scrape', just for one torrent.
+--
+scrapeOne :: Tracker t => t -> InfoHash -> IO ScrapeInfo
+scrapeOne uri ih = scrape uri [ih] >>= maybe err return . M.lookup ih
+  where
+    err = throwIO $ userError "unable to find info hash in response dict"