Redesign tracker subsustem

3 files changed, 989 insertions, 0 deletions

diff --git a/src/Network/BitTorrent/Tracker/RPC/HTTP.hs b/src/Network/BitTorrent/Tracker/RPC/HTTP.hs
new file mode 100644
index 00000000..0eef2b7e
--- /dev/null
+++ b/src/Network/BitTorrent/Tracker/RPC/HTTP.hs
@@ -0,0 +1,106 @@
+-- |
+--   Copyright   :  (c) Sam Truzjan 2013
+--   License     :  BSD
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  non-portable
+--
+--   The tracker is an 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 easily request scrape
+--   info for a particular torrent list.
+--
+--   For more information see:
+--   <https://wiki.theory.org/BitTorrentSpecification#Tracker_HTTP.2FHTTPS_Protocol>
+--
+module Network.BitTorrent.Tracker.RPC.HTTP
+       ( Connection
+       , connect
+       , announce
+       , scrape
+       ) where
+
+import Control.Applicative
+import Control.Exception
+import Data.BEncode as BE
+import Data.ByteString as B
+import Data.ByteString.Char8 as BC
+import Data.ByteString.Lazy  as BL
+import Data.List as L
+import Data.Map as M
+import Data.Monoid
+import Network.URI
+import Network.HTTP.Conduit
+
+import Data.Torrent.InfoHash
+import Network.BitTorrent.Tracker.RPC.Message
+
+
+data Connection = Connection
+  { announceURI :: URI
+  } deriving Show
+
+connect :: URI -> IO Connection
+connect = return . Connection
+
+-- | Send request and receive response from the tracker specified in
+-- announce list. This function throws 'IOException' if it couldn't
+-- send request or receive response or decode response.
+--
+announce :: AnnounceQuery -> Connection -> IO (Result AnnounceInfo)
+announce req = do
+  let uri = undefined
+  resp  <- BL.toStrict <$> simpleHttp uri
+  return $ BE.decode resp
+
+scrape :: ScrapeQuery -> Connection -> IO (Result Scrape)
+scrape = undefined
+
+{-
+-- | 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 (L.foldl addHashToURI newURI ihs)
+ where
+    replace :: ByteString -> Maybe ByteString
+    replace p
+      | ps <- BC.splitWith (== '/') p
+      , "announce" `B.isPrefixOf` L.last ps
+      = let newSuff = "scrape" <> B.drop (B.length "announce") (L.last ps)
+        in Just (B.intercalate "/" (L.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.
+--
+scrapeHTTP :: HTTPTracker -- ^ Announce 'URI'.
+           -> [InfoHash]  -- ^ Torrents to be scrapped.
+           -> IO Scrape   -- ^ 'ScrapeInfo' for each torrent.
+scrapeHTTP HTTPTracker {..} ihs
+  | Just uri <- scrapeURL announceURI ihs = do
+    rawResp  <- simpleHTTP (Request uri GET [] "")
+    respBody <- getResponseBody rawResp
+    case decode (BC.pack respBody) of
+      Left  e -> throwIO $ userError $ e ++ " in scrape response"
+      Right r -> return r
+
+  | otherwise = throwIO $ userError "Tracker do not support scraping"
+
+-- | 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"
+
+-}
\ No newline at end of file
diff --git a/src/Network/BitTorrent/Tracker/RPC/Message.hs b/src/Network/BitTorrent/Tracker/RPC/Message.hs
new file mode 100644
index 00000000..18c1a4c7
--- /dev/null
+++ b/src/Network/BitTorrent/Tracker/RPC/Message.hs
@@ -0,0 +1,539 @@
+-- |
+--   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 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 FlexibleInstances          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# OPTIONS -fno-warn-orphans           #-}
+module Network.BitTorrent.Tracker.RPC.Message
+       ( -- * Announce
+         -- ** Request
+         Event(..)
+       , AnnounceQuery(..)
+       , renderAnnounceQuery
+       , ParamParseFailure
+       , parseAnnounceQuery
+
+         -- ** Response
+       , PeerList (..)
+       , AnnounceInfo(..)
+       , defaultNumWant
+       , parseFailureStatus
+
+         -- * Scrape
+       , ScrapeQuery
+       , ScrapeInfo(..)
+       , Scrape
+       )
+       where
+
+import Control.Applicative
+import Control.Monad
+import Data.Aeson (ToJSON(..), FromJSON(..))
+import Data.Aeson.TH
+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.List as L
+import Data.Map  as M
+import Data.Maybe
+import Data.Serialize as S hiding (Result)
+import Data.Text (Text)
+import Data.Text.Encoding
+import Data.Typeable
+import Data.Word
+import Network
+import Network.HTTP.Types.QueryLike
+import Network.HTTP.Types.URI hiding (urlEncode)
+import Network.HTTP.Types.Status
+import Network.Socket
+import Text.Read (readMaybe)
+
+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 announce query 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 QueryValueLike Event 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 :: 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
+   {
+     -- | 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. See
+     -- note for 'defaultNumWant'.
+   , reqNumWant    :: Maybe Int
+
+     -- | If not specified, the request is regular periodic request.
+   , reqEvent      :: Maybe Event
+   } deriving (Show, Eq, Typeable)
+
+$(deriveJSON (L.map toLower . L.dropWhile isLower) ''AnnounceQuery)
+
+-- | 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
+      }
+
+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)
+      , ("peer_id"  , toQueryValue reqPeerId)
+      , ("port"     , toQueryValue reqPort)
+      , ("ip"       , toQueryValue reqIP)
+      , ("numwant"  , toQueryValue reqNumWant)
+      , ("event"    , toQueryValue reqEvent)
+      ]
+
+--renderAnnounceQueryBuilder :: AnnounceQuery -> BS.Builder
+--renderAnnounceQueryBuilder = undefined
+
+-- | Encode announce query and add it to the base tracker URL.
+renderAnnounceQuery :: AnnounceQuery -> SimpleQuery
+renderAnnounceQuery = filterMaybes . toQuery
+  where
+    filterMaybes :: [(a, Maybe b)] -> [(a, b)]
+    filterMaybes = catMaybes . L.map f
+      where
+        f (_, Nothing) = Nothing
+        f (a, Just b ) = Just (a, b)
+
+data QueryParam
+  = ParamInfoHash
+  | ParamPeerId
+  | ParamPort
+  | ParamUploaded
+  | ParamLeft
+  | ParamDownloaded
+  | ParamIP
+  | ParamNumWant
+  | ParamEvent
+    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"
+
+class FromParam a where
+  fromParam :: BS.ByteString -> Maybe a
+
+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 Event where
+  fromParam bs = do
+    (x, xs) <- BC.uncons bs
+    readMaybe $ BC.unpack $ BC.cons (Char.toUpper x) xs
+
+data ParamParseFailure
+  = Missing QueryParam               -- ^ param not found in query string;
+  | Invalid QueryParam BS.ByteString -- ^ param present but not valid.
+    deriving (Show, Eq)
+
+type Result = Either ParamParseFailure
+
+withError :: ParamParseFailure -> Maybe a -> Result a
+withError e = maybe (Left e) Right
+
+reqParam :: FromParam a => QueryParam -> SimpleQuery -> Result 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 -> Result (Maybe a)
+optParam param ps
+  | Just x <- L.lookup (paramName param) ps
+  = pure <$> withError (Invalid param x) (fromParam x)
+  | otherwise = pure Nothing
+
+parseProgress :: SimpleQuery -> Result Progress
+parseProgress params = Progress
+  <$> reqParam ParamDownloaded params
+  <*> reqParam ParamLeft       params
+  <*> reqParam ParamUploaded   params
+
+-- | Parse announce request from a query string.
+parseAnnounceQuery :: SimpleQuery -> Either ParamParseFailure AnnounceQuery
+parseAnnounceQuery params = AnnounceQuery
+  <$> reqParam ParamInfoHash params
+  <*> reqParam ParamPeerId   params
+  <*> reqParam ParamPort     params
+  <*> parseProgress params
+  <*> optParam ParamIP       params
+  <*> optParam ParamNumWant  params
+  <*> optParam ParamEvent    params
+
+-- TODO add extension datatype
+--type AnnounceRequest = ()
+
+{-----------------------------------------------------------------------
+--  Announce response
+-----------------------------------------------------------------------}
+
+-- | Tracker can return peer list in either compact(BEP23) or not
+-- compact form.
+--
+--   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
+
+missingOffset :: Int
+missingOffset = 101
+
+invalidOffset :: Int
+invalidOffset = 150
+
+-- | Get HTTP response error code from a announce params parse
+-- failure.
+--
+--   For more info see:
+--   <https://wiki.theory.org/BitTorrent_Tracker_Protocol#Response_Codes>
+--
+parseFailureCode :: ParamParseFailure -> Int
+parseFailureCode (Missing param  ) = missingOffset + fromEnum param
+parseFailureCode (Invalid param _) = invalidOffset + fromEnum param
+
+-- | Human readable message
+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]
+
+parseFailureStatus :: ParamParseFailure -> Status
+parseFailureStatus = mkStatus <$> parseFailureCode <*> parseFailureMessage
+
+--type AnnounceResponse = Either Status AnnounceInfo -- TODO
+--type TrackerResponse = () -- TODO
+
+{-----------------------------------------------------------------------
+  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
+      }
diff --git a/src/Network/BitTorrent/Tracker/RPC/UDP.hs b/src/Network/BitTorrent/Tracker/RPC/UDP.hs
new file mode 100644
index 00000000..beff6b4f
--- /dev/null
+++ b/src/Network/BitTorrent/Tracker/RPC/UDP.hs
@@ -0,0 +1,344 @@
+-- |
+--   Copyright   :  (c) Sam Truzjan 2013
+--   License     :  BSD3
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
+--   This module implement low-level UDP tracker protocol.
+--   For more info see:
+--   <http://www.bittorrent.org/beps/bep_0015.html>
+--
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies               #-}
+module Network.BitTorrent.Tracker.RPC.UDP
+       ( UDPTracker
+       , connect
+       , announce
+       , scrape
+       , retransmission
+
+         -- * Debug
+       , putTracker
+       ) where
+
+import Control.Applicative
+import Control.Exception
+import Control.Monad
+import Data.ByteString (ByteString)
+import Data.IORef
+import Data.List as L
+import Data.Map as M
+import Data.Maybe
+import Data.Monoid
+import Data.Serialize
+import Data.Text as T
+import Data.Text.Encoding
+import Data.Time
+import Data.Word
+import Text.Read (readMaybe)
+import Network.Socket hiding (Connected)
+import Network.Socket.ByteString as BS
+import Network.URI
+import System.Entropy
+import System.Timeout
+import Numeric
+
+import Network.BitTorrent.Tracker.RPC.Message
+
+{-----------------------------------------------------------------------
+  Tokens
+-----------------------------------------------------------------------}
+
+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
+
+genConnectionId :: IO ConnectionId
+genConnectionId = ConnectionId <$> genToken
+
+initialConnectionId :: ConnectionId
+initialConnectionId =  ConnectionId 0x41727101980
+
+-- TODO rename
+-- | Transaction Id is used within a UDP RPC.
+newtype TransactionId = TransactionId Word32
+                        deriving (Eq, Serialize)
+
+instance Show TransactionId where
+  showsPrec _ (TransactionId tid) = showString "0x" <> showHex tid
+
+genTransactionId :: IO TransactionId
+genTransactionId = (TransactionId . fromIntegral) <$> genToken
+
+{-----------------------------------------------------------------------
+  Transactions
+-----------------------------------------------------------------------}
+
+data Request  = Connect
+              | Announce  AnnounceQuery
+              | Scrape    ScrapeQuery
+                deriving Show
+
+data Response = Connected ConnectionId
+              | Announced AnnounceInfo
+              | Scraped   [ScrapeInfo]
+              | Failed    Text
+                deriving Show
+
+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 <$> get <*> getBody mid
+    where
+      getBody :: MessageId -> 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 -> 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
+
+{-----------------------------------------------------------------------
+  Connection
+-----------------------------------------------------------------------}
+
+connectionLifetime :: NominalDiffTime
+connectionLifetime = 60
+
+connectionLifetimeServer :: NominalDiffTime
+connectionLifetimeServer = 120
+
+data Connection = Connection
+    { connectionId        :: ConnectionId
+    , connectionTimestamp :: UTCTime
+    } deriving Show
+
+initialConnection :: IO Connection
+initialConnection = Connection initialConnectionId <$> getCurrentTime
+
+isExpired :: Connection -> IO Bool
+isExpired Connection {..} = do
+  currentTime <- getCurrentTime
+  let timeDiff = diffUTCTime currentTime connectionTimestamp
+  return $ timeDiff > connectionLifetime
+
+{-----------------------------------------------------------------------
+  RPC
+-----------------------------------------------------------------------}
+
+maxPacketSize :: Int
+maxPacketSize = 98 -- announce request packet
+
+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
+
+getTrackerAddr :: URI -> IO SockAddr
+getTrackerAddr 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
+    _                 -> fail "getTrackerAddr: unable to lookup host addr"
+getTrackerAddr _       = fail "getTrackerAddr: hostname unknown"
+
+call :: SockAddr -> ByteString -> IO ByteString
+call addr arg = bracket open close rpc
+  where
+    open = socket AF_INET Datagram defaultProtocol
+    rpc sock = do
+      BS.sendAllTo sock arg addr
+      (res, addr') <- BS.recvFrom sock maxPacketSize
+      unless (addr' == addr) $ do
+        throwIO $ userError "address mismatch"
+      return res
+
+-- TODO retransmissions
+-- TODO blocking
+data UDPTracker = UDPTracker
+    { trackerURI        :: URI
+    , trackerConnection :: IORef Connection
+    }
+
+updateConnection :: ConnectionId -> UDPTracker -> IO ()
+updateConnection cid UDPTracker {..} = do
+  newConnection <- Connection cid <$> getCurrentTime
+  writeIORef trackerConnection newConnection
+
+getConnectionId :: UDPTracker -> IO ConnectionId
+getConnectionId UDPTracker {..}
+  = connectionId <$> readIORef trackerConnection
+
+putTracker :: UDPTracker -> IO ()
+putTracker UDPTracker {..} = do
+  print trackerURI
+  print =<< readIORef trackerConnection
+
+transaction :: UDPTracker -> Request -> IO Response
+transaction tracker @ UDPTracker {..} request = do
+  cid <- getConnectionId tracker
+  tid <- genTransactionId
+  let trans = TransactionQ cid tid request
+
+  addr <- getTrackerAddr trackerURI
+  res  <- call addr (encode trans)
+  case decode res of
+    Right (TransactionR {..})
+      | tid == transIdR -> return response
+      |   otherwise     -> throwIO $ userError "transaction id mismatch"
+    Left msg            -> throwIO $ userError msg
+
+connectUDP :: UDPTracker -> IO ConnectionId
+connectUDP tracker = do
+  resp <- transaction tracker Connect
+  case resp of
+    Connected cid -> return cid
+    Failed    msg -> throwIO $ userError $ T.unpack msg
+    _             -> throwIO $ userError "message type mismatch"
+
+initialTracker :: URI -> IO UDPTracker
+initialTracker uri = do
+  tracker <- UDPTracker uri <$> (newIORef =<< initialConnection)
+  connId  <- connectUDP tracker
+  updateConnection connId tracker
+  return tracker
+
+freshConnection :: UDPTracker -> IO ()
+freshConnection tracker @ UDPTracker {..} = do
+  conn    <- readIORef trackerConnection
+  expired <- isExpired conn
+  when expired $ do
+    connId <- connectUDP tracker
+    updateConnection connId tracker
+
+announce :: UDPTracker -> AnnounceQuery -> IO AnnounceInfo
+announce tracker ann = do
+  freshConnection tracker
+  resp <- transaction tracker (Announce ann)
+  case resp of
+    Announced info -> return info
+    _              -> fail "announce: response type mismatch"
+
+scrape :: UDPTracker -> ScrapeQuery -> IO Scrape
+scrape tracker scr = do
+  freshConnection tracker
+  resp <- transaction tracker (Scrape scr)
+  case resp of
+    Scraped info -> return $ M.fromList $ L.zip scr info
+    _            -> fail "scrape: response type mismatch"
+
+{-----------------------------------------------------------------------
+  Retransmission
+-----------------------------------------------------------------------}
+
+sec :: Int
+sec = 1000000
+
+minTimeout :: Int
+minTimeout = 15 * sec
+
+maxTimeout :: Int
+maxTimeout = 15 * 2 ^ (8 :: Int) * sec
+
+retransmission :: IO a -> IO a
+retransmission action = go minTimeout
+  where
+    go curTimeout
+      | maxTimeout < curTimeout = throwIO $ userError "tracker down"
+      |       otherwise         = do
+        r <- timeout curTimeout action
+        maybe (go (2 * curTimeout)) return r