path: root/src/Network/BitTorrent/Tracker/Message.hs

-- |
--   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.Message
       ( -- * Announce
         -- ** Request
         Event(..)
       , AnnounceQuery(..)
       , encodeRequest

         -- ** Response
       , PeerList (..)
       , AnnounceInfo(..)
       , defaultNumWant

         -- * Scrape
       , ScrapeQuery
       , ScrapeInfo(..)
       , Scrape
       )
       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


{-----------------------------------------------------------------------
--  Events
-----------------------------------------------------------------------}

-- | 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)

-- | HTTP tracker protocol compatible encoding.
instance URLShow Event where
  urlShow e = urlShow (Char.toLower x : xs)
    where
      -- INVARIANT: this is always nonempty list
      (x : xs) = show e

type EventId = Word32

-- | UDP tracker encoding event codes.
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"

{-----------------------------------------------------------------------
  Announce query
-----------------------------------------------------------------------}

-- | 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)

instance URLShow PortNumber where
  urlShow = urlShow . fromEnum

instance URLShow Word32 where
  urlShow = show
  {-# INLINE urlShow #-}

-- | 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 #-}

-- | 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
      }

encodeRequest :: URI -> AnnounceQuery -> URI
encodeRequest announceURI req = URL.urlEncode req
                    `addToURI`      announceURI
                    `addHashToURI`  reqInfoHash req

{-----------------------------------------------------------------------
--  Announce response
-----------------------------------------------------------------------}

-- | For more info see: <http://www.bittorrent.org/beps/bep_0023.html>
data PeerList
  =        PeerList { getPeerList :: [PeerAddr] }
  | CompactPeerList { getPeerList :: [PeerAddr] }
    deriving (Show, Eq, Typeable)

instance ToJSON PeerList where
  toJSON      = toJSON . getPeerList

instance FromJSON PeerList where
  parseJSON v = PeerList <$> parseJSON v

putCompactPeerList :: S.Putter [PeerAddr]
putCompactPeerList = mapM_ put

getCompactPeerList :: S.Get [PeerAddr]
getCompactPeerList = many get

instance BEncode PeerList where
  toBEncode (PeerList        xs) = toBEncode xs
  toBEncode (CompactPeerList xs) = toBEncode $ runPut (putCompactPeerList xs)

  fromBEncode (BList    l ) = PeerList        <$> fromBEncode (BList l)
  fromBEncode (BString  s ) = CompactPeerList <$> runGet getCompactPeerList s
  fromBEncode  _            = decodingError "Peer list"

-- | 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

       -- | Human readable warning.
     , respWarning     :: !(Maybe Text)
     } deriving (Show, Typeable)

$(deriveJSON (L.map toLower . L.dropWhile isLower) ''AnnounceInfo)

-- | 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"

-- | 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
      }

-- | 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.
--
--   <https://wiki.theory.org/BitTorrent_Tracker_Protocol#Basic_Tracker_Announce_Request>
--
defaultNumWant :: Int
defaultNumWant = 50

{-----------------------------------------------------------------------
  Scrape message
-----------------------------------------------------------------------}

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 compatible 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
      }