UDP Tracker: connect + announce. Does not work

diff --git a/src/FuncTorrent/Tracker.hs b/src/FuncTorrent/Tracker.hs
index 815d081d0fc93a6ef011327bb4c5e1411a731bcb..5e059f75c0dda0fb4896ec3941a95869e3013d9f 100644 (file)
--- a/src/FuncTorrent/Tracker.hs
+++ b/src/FuncTorrent/Tracker.hs
@@ -29,20 +29,49 @@ import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
 import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar)
 import Control.Monad.State (StateT, liftIO, get, runStateT)
 import Control.Monad (forever)
 import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar)
 import Control.Monad.State (StateT, liftIO, get, runStateT)
 import Control.Monad (forever)

-import Data.ByteString.Char8 (ByteString)
+import Data.ByteString.Char8 (ByteString, pack, unpack)

 import Data.List (isPrefixOf)
 import Network (PortNumber)
 
 import Data.List (isPrefixOf)
 import Network (PortNumber)
 

-import FuncTorrent.Tracker.Http (trackerLoop)
+import qualified FuncTorrent.Tracker.Http as HT (trackerLoop)
+import qualified FuncTorrent.Tracker.Udp as UT (trackerLoop)

 import FuncTorrent.Tracker.Types (TState(..), TrackerEventState(..), TrackerProtocol(..), TrackerMsg(..))
 import FuncTorrent.Tracker.Types (TState(..), TrackerEventState(..), TrackerProtocol(..), TrackerMsg(..))

+import FuncTorrent.Utils (Port, toPort)

 import qualified FuncTorrent.FileSystem as FS (MsgChannel)
 import FuncTorrent.Peer (Peer)
 
 type MsgChannel = Chan TrackerMsg
 
 import qualified FuncTorrent.FileSystem as FS (MsgChannel)
 import FuncTorrent.Peer (Peer)
 
 type MsgChannel = Chan TrackerMsg
 

+data TrackerUrl = TrackerUrl { protocol :: TrackerProtocol
+                             , host :: String
+                             , port :: Port
+                             , path :: String
+                             }
+

 newTracker :: IO MsgChannel
 newTracker = newChan
 
 newTracker :: IO MsgChannel
 newTracker = newChan
 

+parseUrl :: String -> TrackerUrl
+parseUrl url = TrackerUrl proto host port path
+  where proto = getTrackerType url
+        host = getHostname url
+        port = getPort url
+        path = getPath url
+
+getTrackerType :: String -> TrackerProtocol
+getTrackerType url | isPrefixOf "http://" url = Http
+                   | isPrefixOf "udp://" url  = Udp
+                   | otherwise                = UnknownProtocol
+
+getHostname :: String -> String
+getHostname url = takeWhile (/= ':') $ drop 2 $ dropWhile (/= '/') url
+
+getPort :: String -> Port
+getPort url = toPort . pack $ takeWhile (/= '/') $ drop 1 $ dropWhile (/= ':') $ drop 2 $ dropWhile (/= '/') url
+
+getPath :: String -> String
+getPath url = dropWhile (/= '/') $ dropWhile (/= ':') $ drop 1 $ dropWhile (/= ':') url
+

 runTracker :: MsgChannel -> FS.MsgChannel -> ByteString -> PortNumber
            -> String -> [String] -> Integer -> IO ()
 runTracker msgChannel fsChan infohash port peerId announceList sz = do
 runTracker :: MsgChannel -> FS.MsgChannel -> ByteString -> PortNumber
            -> String -> [String] -> Integer -> IO ()
 runTracker msgChannel fsChan infohash port peerId announceList sz = do


@@ -51,20 +80,18 @@ runTracker msgChannel fsChan infohash port peerId announceList sz = do
                              , connectedPeers = ps
                              , left = sz }
       turl = head announceList
                              , connectedPeers = ps
                              , left = sz }
       turl = head announceList

+      host = getHostname turl

   case getTrackerType turl of
     Http -> do
   case getTrackerType turl of
     Http -> do

-      _ <- forkIO $ trackerLoop turl port peerId infohash fsChan initialTState
+      _ <- forkIO $ HT.trackerLoop host port peerId infohash fsChan initialTState

       runStateT (msgHandler msgChannel) initialTState
       return ()
       runStateT (msgHandler msgChannel) initialTState
       return ()

-    _ -> do
+    Udp -> do
+      _ <- forkIO $ UT.trackerLoop host (fromIntegral port) peerId infohash fsChan initialTState
+      return ()
+    _ ->

       error "Tracker Protocol unimplemented"
 
       error "Tracker Protocol unimplemented"
 

-getTrackerType :: String -> TrackerProtocol
-getTrackerType url | isPrefixOf "http://" url = Http
-                   | isPrefixOf "udp://" url  = Udp
-                   | otherwise                = UnknownProtocol
-
-

 msgHandler :: MsgChannel -> StateT TState IO ()
 msgHandler c = forever $ do
   st <- get
 msgHandler :: MsgChannel -> StateT TState IO ()
 msgHandler c = forever $ do
   st <- get

diff --git a/src/FuncTorrent/Tracker/Types.hs b/src/FuncTorrent/Tracker/Types.hs
index c79fceffe8ad1885bbadcbb2052656b11d58cfde..2165b08261d1229d49dfa0ce1751fbad53cb82d7 100644 (file)
--- a/src/FuncTorrent/Tracker/Types.hs
+++ b/src/FuncTorrent/Tracker/Types.hs
@@ -39,7 +39,7 @@ data TrackerProtocol = Http
 data TrackerEventState = None
                        | Started
                        | Completed
 data TrackerEventState = None
                        | Started
                        | Completed

-                       | Error ByteString
+                       | Stopped

                        deriving (Show, Eq)
 
 data TrackerMsg = GetStatusMsg TrackerEventState
                        deriving (Show, Eq)
 
 data TrackerMsg = GetStatusMsg TrackerEventState

diff --git a/src/FuncTorrent/Tracker/Udp.hs b/src/FuncTorrent/Tracker/Udp.hs
index e24944a994a5d322b4cf8283c3c4a55474c1854e..4e541a932b2e17c5c20a8cb20cc48b7065689889 100644 (file)
--- a/src/FuncTorrent/Tracker/Udp.hs
+++ b/src/FuncTorrent/Tracker/Udp.hs
@@ -19,10 +19,12 @@
 
 {-# LANGUAGE OverloadedStrings #-}
 module FuncTorrent.Tracker.Udp
 
 {-# LANGUAGE OverloadedStrings #-}
 module FuncTorrent.Tracker.Udp

-       (
+       (trackerLoop

        ) where
 
 import Control.Applicative (liftA2)
        ) where
 
 import Control.Applicative (liftA2)

+import Control.Monad (liftM)
+import Control.Concurrent.MVar (readMVar)

 import Control.Monad.Reader (ReaderT, runReaderT, ask, liftIO)
 import Data.Binary (Binary(..), encode, decode)
 import Data.Binary.Get (Get, isEmpty, getWord32be, getByteString)
 import Control.Monad.Reader (ReaderT, runReaderT, ask, liftIO)
 import Data.Binary (Binary(..), encode, decode)
 import Data.Binary.Get (Get, isEmpty, getWord32be, getByteString)


@@ -30,13 +32,15 @@ import Data.Binary.Put (putWord16be, putWord64be, putWord32be, putByteString)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as BC
 import Data.ByteString.Lazy (fromStrict, toStrict)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as BC
 import Data.ByteString.Lazy (fromStrict, toStrict)

-import Data.Word (Word32, Word64)
-import Network.Socket (Socket, Family( AF_INET ), SocketType( Datagram ), defaultProtocol, SockAddr(..), socket, inet_addr, close)
+import Data.Word (Word16, Word32, Word64)
+import Network.Socket (Socket, Family( AF_INET ), SocketType( Datagram ), defaultProtocol, SockAddr(..), socket, inet_addr, close, getAddrInfo, addrAddress, SockAddr(..))

 import Network.Socket.ByteString (sendTo, recvFrom)
 import System.Random (randomIO)
 
 import FuncTorrent.Tracker.Types (TrackerEventState(..))
 import FuncTorrent.Utils (IP, Port, toIP, toPort)
 import Network.Socket.ByteString (sendTo, recvFrom)
 import System.Random (randomIO)
 
 import FuncTorrent.Tracker.Types (TrackerEventState(..))
 import FuncTorrent.Utils (IP, Port, toIP, toPort)

+import qualified FuncTorrent.FileSystem as FS (MsgChannel, Stats(..), getStats)
+import FuncTorrent.Tracker.Types(TState(..))

 
 -- UDP tracker: http://bittorrent.org/beps/bep_0015.html
 data Action = Connect
 
 -- UDP tracker: http://bittorrent.org/beps/bep_0015.html
 data Action = Connect


@@ -45,12 +49,12 @@ data Action = Connect
             deriving (Show, Eq)
 
 data UDPRequest = ConnectReq Word32
             deriving (Show, Eq)
 
 data UDPRequest = ConnectReq Word32

-                | AnnounceReq Integer Integer ByteString String Integer Integer Integer TrackerEventState Integer
+                | AnnounceReq Word64 Word32 ByteString String Word64 Word64 Word64 TrackerEventState Word16

                 | ScrapeReq Integer Integer ByteString
                 deriving (Show, Eq)
 
 data UDPResponse = ConnectResp Word32 Word64 -- transaction_id connection_id
                 | ScrapeReq Integer Integer ByteString
                 deriving (Show, Eq)
 
 data UDPResponse = ConnectResp Word32 Word64 -- transaction_id connection_id

-                 | AnnounceResp Integer Integer Integer Integer [(IP, Port)] -- transaction_id interval leechers seeders [(ip, port)]
+                 | AnnounceResp Word32 Word32 Word32 Word32 [(IP, Port)] -- transaction_id interval leechers seeders [(ip, port)]

                  | ScrapeResp Integer Integer Integer Integer
                  | ErrorResp Integer String
                  deriving (Show, Eq)
                  | ScrapeResp Integer Integer Integer Integer
                  | ErrorResp Integer String
                  deriving (Show, Eq)


@@ -74,6 +78,7 @@ eventToInteger :: TrackerEventState -> Integer
 eventToInteger None = 0
 eventToInteger Completed = 1
 eventToInteger Started = 2
 eventToInteger None = 0
 eventToInteger Completed = 1
 eventToInteger Started = 2

+eventToInteger Stopped = 3

 
 instance Binary UDPRequest where
   put (ConnectReq transId) = do
 
 instance Binary UDPRequest where
   put (ConnectReq transId) = do


@@ -106,10 +111,10 @@ instance Binary UDPResponse where
       1 -> do
         tid <- fromIntegral <$> getWord32be
         interval' <- fromIntegral <$> getWord32be
       1 -> do
         tid <- fromIntegral <$> getWord32be
         interval' <- fromIntegral <$> getWord32be

-        _ <- getWord32be -- leechers
-        _ <- getWord32be -- seeders
+        l <- getWord32be -- leechers
+        s <- getWord32be -- seeders

         ipportpairs <- getIPPortPairs -- [(ip, port)]
         ipportpairs <- getIPPortPairs -- [(ip, port)]

-        return $ AnnounceResp tid interval' 0 0 ipportpairs
+        return $ AnnounceResp tid interval' l s ipportpairs

       2 -> do
         tid <- fromIntegral <$> getWord32be
         _ <- getWord32be
       2 -> do
         tid <- fromIntegral <$> getWord32be
         _ <- getWord32be


@@ -130,23 +135,59 @@ sendRequest h req = do
 
 recvResponse :: UDPTrackerHandle -> IO UDPResponse
 recvResponse h = do
 
 recvResponse :: UDPTrackerHandle -> IO UDPResponse
 recvResponse h = do

-  (bs, saddr) <- recvFrom (sock h) 32
+  (bs, saddr) <- recvFrom (sock h) (16*1024)

   return $ decode $ fromStrict bs
 
   return $ decode $ fromStrict bs
 

-connectRequest :: ReaderT UDPTrackerHandle IO ()
+connectRequest :: ReaderT UDPTrackerHandle IO Word32

 connectRequest = do
   h <- ask
 connectRequest = do
   h <- ask

-  let pkt = encode $ ConnectReq (tid h)
+  tidi <- liftIO randomIO
+  let pkt = encode $ ConnectReq tidi

   liftIO $ sendRequest h (toStrict pkt)
   liftIO $ sendRequest h (toStrict pkt)

+  return tidi

 
 

-connectResponse :: Word32 -> ReaderT UDPTrackerHandle IO Bool
-connectResponse itid = do
+connectResponse :: Word32 -> ReaderT UDPTrackerHandle IO Word64
+connectResponse tid = do

   h <- ask
   resp <- liftIO $ recvResponse h
   -- check if nbytes is at least 16 bytes long
   case resp of
   h <- ask
   resp <- liftIO $ recvResponse h
   -- check if nbytes is at least 16 bytes long
   case resp of

-    (ConnectResp tid cid) -> return $ tid == itid
-    _                     -> return False
+    (ConnectResp tidr cid) ->
+      if tidr == tid
+      then do
+        liftIO $ putStrLn "connect succeeded"
+        return cid
+      else
+        return 0
+    _                      -> return 0
+
+announceRequest :: Word64 -> ByteString -> Word64 -> Word64 -> Word64 -> Word16 -> ReaderT UDPTrackerHandle IO Word32
+announceRequest cid infohash up down left port = do
+  h <- ask
+  tidi <- liftIO randomIO
+  -- connId transId infohash peerId down left up event port)
+  let pkt = encode $ AnnounceReq cid tidi infohash "foo" down left up None port
+  liftIO $ sendRequest h (toStrict pkt)
+  return tidi
+
+data PeerStats = PeerStats { leechers :: Word32
+                           , seeders :: Word32
+                           , peers :: [(IP, Port)]
+                           } deriving (Show)
+
+announceResponse :: Word32 -> ReaderT UDPTrackerHandle IO PeerStats
+announceResponse tid = do
+  h <- ask
+  resp <- liftIO $ recvResponse h
+  case resp of
+    (AnnounceResp tidr interval ss ls xs) ->
+      if tidr == tid
+      then do
+        liftIO $ putStrLn "announce succeeded"
+        return $ PeerStats ls ss xs
+      else
+        return $ PeerStats 0 0 []
+    _ -> return $ PeerStats 0 0 []

 
 getIPPortPairs :: Get [(IP, Port)]
 getIPPortPairs = do
 
 getIPPortPairs :: Get [(IP, Port)]
 getIPPortPairs = do


@@ -159,15 +200,29 @@ getIPPortPairs = do
     ipportpairs <- getIPPortPairs
     return $ (ip, port) : ipportpairs
 
     ipportpairs <- getIPPortPairs
     return $ (ip, port) : ipportpairs
 

-startSession :: IP -> Port -> IO UDPTrackerHandle
-startSession ip port = do
+startSession :: String -> Port -> IO UDPTrackerHandle
+startSession host port = do

   s <- socket AF_INET Datagram defaultProtocol
   s <- socket AF_INET Datagram defaultProtocol

-  hostAddr <- inet_addr ip
+  addrinfos <- getAddrInfo Nothing (Just host) (Just (show port))
+  let (SockAddrInet p ip) = addrAddress $ head addrinfos
+  hostAddr <- inet_addr (show ip)

   putStrLn "connected to tracker"
   putStrLn "connected to tracker"

-  r <- randomIO

   return $ UDPTrackerHandle { sock = s
   return $ UDPTrackerHandle { sock = s

-                            , tid = r

                             , addr = (SockAddrInet (fromIntegral port) hostAddr) }
   
 closeSession :: UDPTrackerHandle -> IO ()
 closeSession (UDPTrackerHandle s _ _) = close s
                             , addr = (SockAddrInet (fromIntegral port) hostAddr) }
   
 closeSession :: UDPTrackerHandle -> IO ()
 closeSession (UDPTrackerHandle s _ _) = close s

+
+trackerLoop :: String -> Port -> String -> ByteString -> FS.MsgChannel -> TState -> IO ()
+trackerLoop host port peerId infohash fschan tstate = do
+  st' <- FS.getStats fschan
+  st <- readMVar st'
+  let up = FS.bytesRead st
+      down = FS.bytesWritten st
+  handle <- startSession host 2710
+  flip runReaderT handle $ do
+    t1 <- connectRequest
+    cid <- connectResponse t1
+    t2 <- announceRequest cid infohash (fromIntegral up) (fromIntegral down) (fromIntegral (left tstate)) (fromIntegral port)
+    stats <- announceResponse t2
+    liftIO $ print stats