Expose UDP tracker specific message types

Those can be used to implement UDP tracker server by third party
libraries or projects.

4 files changed, 169 insertions, 155 deletions

diff --git a/src/Network/BitTorrent/Tracker/Message.hs b/src/Network/BitTorrent/Tracker/Message.hs
index edafdaba..8131ecf0 100644
--- a/src/Network/BitTorrent/Tracker/Message.hs
+++ b/src/Network/BitTorrent/Tracker/Message.hs
@@ -25,6 +25,7 @@
 {-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE DeriveFunctor              #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TypeFamilies               #-}
 {-# OPTIONS -fno-warn-orphans           #-}
 module Network.BitTorrent.Tracker.Message
        ( -- * Announce
@@ -76,6 +77,21 @@ module Network.BitTorrent.Tracker.Message
 
          -- ** Extra
        , queryToSimpleQuery
+
+         -- * UDP specific
+         -- ** Connection
+       , ConnectionId
+       , initialConnectionId
+
+         -- ** Messages
+       , Request (..)
+       , Response (..)
+       , responseName
+
+         -- ** Transaction
+       , genTransactionId
+       , TransactionId
+       , Transaction  (..)
        )
        where
 
@@ -104,7 +120,9 @@ import Network
 import Network.HTTP.Types.QueryLike
 import Network.HTTP.Types.URI hiding (urlEncode)
 import Network.HTTP.Types.Status
-import Network.Socket
+import Network.Socket hiding (Connected)
+import Numeric
+import System.Entropy
 import Text.Read (readMaybe)
 
 import Data.Torrent.InfoHash
@@ -765,3 +783,146 @@ scrapeType = "text/plain"
 --
 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/src/Network/BitTorrent/Tracker/RPC/HTTP.hs b/src/Network/BitTorrent/Tracker/RPC/HTTP.hs
index cc5bd318..4a8e5f79 100644
--- a/src/Network/BitTorrent/Tracker/RPC/HTTP.hs
+++ b/src/Network/BitTorrent/Tracker/RPC/HTTP.hs
@@ -49,7 +49,7 @@ import           Network.HTTP.Types.URI    (SimpleQuery, renderSimpleQuery)
 
 import Data.Torrent.InfoHash               (InfoHash)
 import Network.BitTorrent.Core.Fingerprint (libUserAgent)
-import Network.BitTorrent.Tracker.Message
+import Network.BitTorrent.Tracker.Message hiding (Request, Response)
 
 {-----------------------------------------------------------------------
 -- Exceptions
diff --git a/src/Network/BitTorrent/Tracker/RPC/UDP.hs b/src/Network/BitTorrent/Tracker/RPC/UDP.hs
index 0c9c3367..35e8b7b6 100644
--- a/src/Network/BitTorrent/Tracker/RPC/UDP.hs
+++ b/src/Network/BitTorrent/Tracker/RPC/UDP.hs
@@ -15,7 +15,6 @@
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE DeriveDataTypeable         #-}
-{-# LANGUAGE TypeFamilies               #-}
 module Network.BitTorrent.Tracker.RPC.UDP
        ( -- * Manager
          Options (..)
@@ -52,7 +51,6 @@ import Text.Read (readMaybe)
 import Network.Socket hiding (Connected, connect, listen)
 import Network.Socket.ByteString as BS
 import Network.URI
-import System.Entropy
 import System.Timeout
 import Numeric
 
@@ -259,151 +257,6 @@ getTrackerAddr _ uri
   |        otherwise        = throwIO (UnrecognizedScheme (uriScheme uri))
 
 {-----------------------------------------------------------------------
-  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
-
-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
-
-{-----------------------------------------------------------------------
-  Transactions
------------------------------------------------------------------------}
-
-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 <$> 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
 -----------------------------------------------------------------------}
 
diff --git a/src/Network/BitTorrent/Tracker/Session.hs b/src/Network/BitTorrent/Tracker/Session.hs
index 7be16fd6..9fe02b52 100644
--- a/src/Network/BitTorrent/Tracker/Session.hs
+++ b/src/Network/BitTorrent/Tracker/Session.hs
@@ -50,13 +50,13 @@ import Network.BitTorrent.Tracker.RPC as RPC
 --  Tracker entry
 -----------------------------------------------------------------------}
 
-data Scrape = Scrape
+data LastScrape = LastScrape
   { leechersCount :: Maybe Int
   , seedersCount  :: Maybe Int
   } deriving (Show, Eq)
 
-instance Default Scrape where
-  def = Scrape Nothing Nothing
+instance Default LastScrape where
+  def = LastScrape Nothing Nothing
 
 
 data Status
@@ -102,7 +102,7 @@ data TrackerEntry = TrackerEntry
   , peersCache    :: Cached [PeerAddr IP]
 
     -- | May be used to show brief swarm stats in client GUI.
-  , scrapeCache   :: Cached Scrape
+  , scrapeCache   :: Cached LastScrape
   }
 
 nullEntry :: URI -> TrackerEntry
@@ -140,11 +140,11 @@ cachePeers AnnounceInfo {..} =
             (seconds (fromMaybe respInterval respMinInterval))
             (getPeerList respPeers)
 
-cacheScrape :: AnnounceInfo -> IO (Cached Scrape)
+cacheScrape :: AnnounceInfo -> IO (Cached LastScrape)
 cacheScrape AnnounceInfo {..} =
   newCached (seconds respInterval)
             (seconds (fromMaybe respInterval respMinInterval))
-    Scrape
+    LastScrape
       { seedersCount  = respComplete
       , leechersCount = respIncomplete
       }