WIP: udp tracker: get the peer ip, port pairs

[functorrent.git] / src / FuncTorrent / Tracker.hs

diff --git a/src/FuncTorrent/Tracker.hs b/src/FuncTorrent/Tracker.hs
index cf1648e1d44a9fd29287b1f46b7d1363d145377f..f995f1be3d6e04663399a602ef72e3a177b596ee 100644 (file)
--- a/src/FuncTorrent/Tracker.hs
+++ b/src/FuncTorrent/Tracker.hs
@@ -7,9 +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, takeMVar)
-import Control.Monad.State
+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 (Get, isEmpty, getByteString, getWord16be, getWord32be)
 import Data.ByteString (ByteString)
 import Data.ByteString.Char8 as BC (pack, unpack, splitAt)
 import Data.Char (chr)
@@ -21,7 +24,7 @@ import qualified Data.ByteString.Base16 as B16 (encode)
 
 import FuncTorrent.Bencode (BVal(..), decode)
 import FuncTorrent.Metainfo (Info(..), Metainfo(..))
-import FuncTorrent.Network (httpget)
+import FuncTorrent.Network (sendGetRequest)
 import FuncTorrent.Peer (Peer(..))
 import FuncTorrent.Utils (splitN)
 
@@ -33,7 +36,8 @@ data TrackerResponse = TrackerResponse {
   , incomplete :: Maybe Integer
   } deriving (Show, Eq)
 
-data TrackerEventState = Started
+data TrackerEventState = None
+                       | Started
                        | Stopped
                        | Completed
                        deriving (Show, Eq)
@@ -46,12 +50,101 @@ data TState = TState {
   , connectedPeers :: MVar [Peer]
   }
 
+-- UDP tracker: http://bittorrent.org/beps/bep_0015.html
+data Action = Connect
+            | Announce
+            | Scrape
+            deriving (Show, Eq)
+
+type IP = String
+type Port = Integer
+
+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 -- transaction_id connection_id
+                 | AnnounceResp Integer Integer Integer Integer [(IP, Port)] -- transaction_id interval leechers seeders [(ip, port)]
+                 | 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
+        ipportpairs <- getIPPortPairs -- [(ip, port)]
+        return $ AnnounceResp tid interval' 0 0 ipportpairs
+      2 -> do
+        tid <- fromIntegral <$> getWord32be
+        _ <- getWord32be
+        _ <- getWord32be
+        _ <- getWord32be
+        return $ ScrapeResp tid 0 0 0
+      _ -> error ("unknown response action type: " ++ show a)
+
+getIPPortPairs :: Get [(IP, Port)]
+getIPPortPairs = do
+  empty <- isEmpty
+  if empty
+    then return []
+    else do
+    ip <- toIP <$> getByteString 6
+    port <- toPort <$> getByteString 2
+    ipportpairs <- getIPPortPairs
+    return $ (ip, port) : ipportpairs
+
 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
@@ -76,20 +169,20 @@ mkTrackerResponse resp =
     where
       (Bdict body) = resp
 
-      toInt :: String -> Integer
-      toInt = read
+toInt :: String -> Integer
+toInt = read
 
-      toPort :: ByteString -> Integer
-      toPort = read . ("0x" ++) . unpack . B16.encode
+makePeer :: ByteString -> Peer
+makePeer peer = Peer "" (toIP ip') (toPort port')
+  where (ip', port') = splitAt 4 peer
 
-      toIP :: ByteString -> String
-      toIP = Data.List.intercalate "." .
-             map (show . toInt . ("0x" ++) . unpack) .
-                 splitN 2 . B16.encode
+toPort :: ByteString -> Port
+toPort = read . ("0x" ++) . unpack . B16.encode
 
-      makePeer :: ByteString -> Peer
-      makePeer peer = Peer "" (toIP ip') (toPort port')
-          where (ip', port') = splitAt 4 peer
+toIP :: ByteString -> IP
+toIP = Data.List.intercalate "." .
+       map (show . toInt . ("0x" ++) . unpack) .
+       splitN 2 . B16.encode
 
 --- | URL encode hash as per RFC1738
 --- TODO: Add tests
@@ -123,9 +216,9 @@ mkArgs port peer_id up down m =
 
 trackerLoop :: PortNumber -> String -> Metainfo -> TState -> IO ByteString
 trackerLoop port peerId m st = do
-  up <- liftIO $ readMVar $ uploaded st
-  down <- liftIO $ readMVar $ downloaded st
-  resp <- liftIO $ httpget (head . announceList $ m) $ mkArgs port peerId up down m
+  up <- readMVar $ uploaded st
+  down <- readMVar $ downloaded st
+  resp <- sendGetRequest (head . announceList $ m) $ mkArgs port peerId up down m
   case decode resp of
     Left e -> return $ pack (show e)
     Right trackerInfo ->