WIP: UDP Tracker support

Add binary packet creation/parsing of the UDP request and response
packets.

diff --git a/src/FuncTorrent/Tracker.hs b/src/FuncTorrent/Tracker.hs
index 3926a12fa99862dded1c47fbc5dcc42dad0ba492..7e64f82a4836ab8db13a832a5c7703a9db5593ce 100644 (file)
--- a/src/FuncTorrent/Tracker.hs
+++ b/src/FuncTorrent/Tracker.hs
@@ -7,8 +7,12 @@ module FuncTorrent.Tracker
 
 import Prelude hiding (lookup, splitAt)
 
+import Control.Applicative (liftA2)
 import Control.Concurrent (threadDelay)
 import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, readMVar, putMVar)
+import Data.Binary (Binary(..))
+import Data.Binary.Put (putWord16be, putWord32be, putWord64be, putByteString)
+import Data.Binary.Get (getWord16be, getWord32be)
 import Data.ByteString (ByteString)
 import Data.ByteString.Char8 as BC (pack, unpack, splitAt)
 import Data.Char (chr)
@@ -32,7 +36,8 @@ data TrackerResponse = TrackerResponse {
   , incomplete :: Maybe Integer
   } deriving (Show, Eq)
 
-data TrackerEventState = Started
+data TrackerEventState = None
+                       | Started
                        | Stopped
                        | Completed
                        deriving (Show, Eq)
@@ -45,12 +50,88 @@ data TState = TState {
   , connectedPeers :: MVar [Peer]
   }
 
+-- UDP tracker: http://bittorrent.org/beps/bep_0015.html
+data Action = Connect
+            | Announce
+            | Scrape
+            deriving (Show, Eq)
+
+data UDPRequest = ConnectReq Integer
+                | AnnounceReq Integer Integer ByteString String Integer Integer Integer TrackerEventState Integer
+                | ScrapeReq Integer Integer ByteString
+                deriving (Show, Eq)
+
+data UDPResponse = ConnectResp Integer Integer
+                 | AnnounceResp Integer Integer Integer Integer Integer Integer
+                 | ScrapeResp Integer Integer Integer Integer
+                 deriving (Show, Eq)
+
+actionToInteger :: Action -> Integer
+actionToInteger Connect  = 0
+actionToInteger Announce = 1
+actionToInteger Scrape   = 2
+
+intToAction :: Integer -> Action
+intToAction 0 = Connect
+intToAction 1 = Announce
+intToAction 2 = Scrape
+
+eventToInteger :: TrackerEventState -> Integer
+eventToInteger None = 0
+eventToInteger Completed = 1
+eventToInteger Started = 2
+eventToInteger Stopped = 3
+
+instance Binary UDPRequest where
+  put (ConnectReq transId) = do
+    putWord64be 0x41727101980
+    putWord32be $ fromIntegral (actionToInteger Connect)
+    putWord32be (fromIntegral transId)
+  put (AnnounceReq connId transId infohash peerId down left up event port) = do
+    putWord64be $ fromIntegral connId
+    putWord32be $ fromIntegral (actionToInteger Announce)
+    putWord32be $ fromIntegral transId
+    putByteString infohash
+    putByteString (BC.pack peerId)
+    putWord64be (fromIntegral down)
+    putWord64be (fromIntegral left)
+    putWord64be (fromIntegral up)
+    putWord32be $ fromIntegral (eventToInteger None)
+    putWord32be 0
+    -- key is optional, we will not send it for now
+    putWord32be $ fromIntegral (-1)
+    putWord16be $ fromIntegral port
+  put (ScrapeReq _ _ _) = undefined
+  get = undefined
+
+instance Binary UDPResponse where
+  put = undefined
+  get = do
+    a <- getWord32be -- action
+    case a of
+      0 -> liftA2 ConnectResp (fromIntegral <$> getWord32be) (fromIntegral <$> getWord32be)
+      1 -> do
+        tid <- fromIntegral <$> getWord32be
+        interval' <- fromIntegral <$> getWord32be
+        _ <- getWord32be -- leechers
+        _ <- getWord32be -- seeders
+        _ <- getWord32be -- ip
+        _ <- getWord16be -- port
+        return $ AnnounceResp tid interval' 0 0 0 0
+      2 -> do
+        tid <- fromIntegral <$> getWord32be
+        _ <- getWord32be
+        _ <- getWord32be
+        _ <- getWord32be
+        return $ ScrapeResp tid 0 0 0
+      _ -> error ("unknown response action type: " ++ show a)
+
 initialTrackerState :: Integer -> IO TState
 initialTrackerState sz = do
   ps <- newEmptyMVar
   up <- newMVar 0
   down <- newMVar 0
-  return $ TState { currentState = Started
+  return $ TState { currentState = None
                   , connectedPeers = ps
                   , uploaded = up
                   , downloaded = down