Tracker: refactor into http, udp and types modules

diff --git a/functorrent.cabal b/functorrent.cabal
index c4da29dc1adce981bf64705131d98cfa3a10275d..95196fb8badbfbeb2fcb5a3dc6b62ff919255516 100644 (file)
--- a/functorrent.cabal
+++ b/functorrent.cabal
@@ -26,6 +26,8 @@ library
                        FuncTorrent.PieceManager,
                        FuncTorrent.Server,
                        FuncTorrent.Tracker,
+                       FuncTorrent.Tracker.Http,
+                       FuncTorrent.Tracker.Types,
                        FuncTorrent.Utils
 
   other-extensions:    OverloadedStrings

diff --git a/src/FuncTorrent/Tracker.hs b/src/FuncTorrent/Tracker.hs
index dd66c12dac0dc7ff6cc40c679241995648ef0b86..64a2ce9d3e8c96a5a29c5176bd770be0ba05bb52 100644 (file)
--- a/src/FuncTorrent/Tracker.hs
+++ b/src/FuncTorrent/Tracker.hs
@@ -2,158 +2,14 @@
 module FuncTorrent.Tracker
     (TState(..),
      initialTrackerState,
-     trackerLoop,
-     udpTrackerLoop
+     trackerLoop
     ) where
 
-import Prelude hiding (lookup, splitAt)
+import Control.Concurrent.MVar (newEmptyMVar, newMVar)
+import Data.List (isPrefixOf)
 
-
-import Control.Applicative (liftA2)
-import Control.Concurrent (threadDelay)
-import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, readMVar, putMVar)
-import Data.Binary (Binary(..), encode, decode)
-import Data.Binary.Put (putWord16be, putWord32be, putWord64be, putByteString)
-import Data.Binary.Get (Get, isEmpty, getByteString, getWord16be, getWord32be)
-import Data.ByteString (ByteString, hGet, hPut)
-import Data.ByteString.Char8 as BC (pack, unpack, splitAt)
-import Data.ByteString.Lazy (fromStrict, toStrict)
-import Data.Char (chr)
-import Data.List (intercalate, isPrefixOf)
-import Data.Map as M (lookup)
-import Network (connectTo, PortID(..), PortNumber, Socket)
-import Network.Socket (defaultProtocol, SocketType( Datagram ), Family( AF_INET ), SockAddr( SockAddrInet ), inet_addr, socket)
-import Network.Socket.ByteString (sendTo, recv)
-import Network.HTTP.Base (urlEncode)
-import qualified Data.ByteString.Base16 as B16 (encode)
-
-import FuncTorrent.Bencode (BVal(..))
-import qualified FuncTorrent.Bencode as Benc
-import FuncTorrent.Metainfo (Info(..), Metainfo(..))
-import FuncTorrent.Network (sendGetRequest)
-import FuncTorrent.Peer (Peer(..))
-import FuncTorrent.Utils (splitN)
-
-data TrackerProtocol = Http
-                     | Udp
-                     | UnknownProtocol
-                     deriving (Show)
-
--- | Tracker response
-data TrackerResponse = TrackerResponse {
-  interval :: Integer
-  , peers :: [Peer]
-  , complete :: Maybe Integer
-  , incomplete :: Maybe Integer
-  } deriving (Show, Eq)
-
-data TrackerEventState = None
-                       | Started
-                       | Stopped
-                       | Completed
-                       deriving (Show, Eq)
-
-data TState = TState {
-    uploaded :: MVar Integer
-  , downloaded :: MVar Integer
-  , left :: Integer
-  , currentState :: TrackerEventState
-  , 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
-                 | ErrorResp Integer String
-                 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
-      3 -> do -- error response
-        tid <- fromIntegral <$> getWord32be
-        bs  <- getByteString 4
-        return $ ErrorResp tid $ unpack bs
-      _ -> 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
+import FuncTorrent.Tracker.Http(trackerLoop)
+import FuncTorrent.Tracker.Types(TState(..), TrackerEventState(..), TrackerProtocol(..))
 
 initialTrackerState :: Integer -> IO TState
 initialTrackerState sz = do
@@ -166,113 +22,8 @@ initialTrackerState sz = do
                   , downloaded = down
                   , left = sz }
 
--- | Deserialize HTTP tracker response
-parseTrackerResponse :: BVal -> Either ByteString TrackerResponse
-parseTrackerResponse resp =
-    case lookup "failure reason" body of
-      Just (Bstr err) -> Left err
-      Just _ -> Left "Unknown failure"
-      Nothing ->
-          let (Just (Bint i)) = lookup "interval" body
-              (Just (Bstr peersBS)) = lookup "peers" body
-              pl = map makePeer (splitN 6 peersBS)
-          in Right TrackerResponse {
-                   interval = i
-                 , peers = pl
-                 , complete = Nothing
-                 , incomplete = Nothing
-                 }
-    where
-      (Bdict body) = resp
-
-toInt :: String -> Integer
-toInt = read
-
-makePeer :: ByteString -> Peer
-makePeer peer = Peer "" (toIP ip') (toPort port')
-  where (ip', port') = splitAt 4 peer
-
-toPort :: ByteString -> Port
-toPort = read . ("0x" ++) . unpack . B16.encode
-
-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
---- REVIEW: Why is this not written in terms of `Network.HTTP.Base.urlEncode` or
---- equivalent library function?
-urlEncodeHash :: ByteString -> String
-urlEncodeHash bs = concatMap (encode' . unpack) (splitN 2 bs)
-  where encode' b@[c1, c2] = let c =  chr (read ("0x" ++ b))
-                            in escape c c1 c2
-        encode' _ = ""
-        escape i c1 c2 | i `elem` nonSpecialChars = [i]
-                       | otherwise = "%" ++ [c1] ++ [c2]
-
-        nonSpecialChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_.~"
-
--- | Make arguments that should be posted to tracker.
--- This is a separate pure function for testability.
-mkArgs :: PortNumber -> String -> Integer -> Integer -> Metainfo -> [(String, ByteString)]
-mkArgs port peer_id up down m =
-  let fileSize = lengthInBytes $ info m
-      bytesLeft = fileSize - down
-  in
-    [("info_hash", pack . urlEncodeHash . B16.encode . infoHash $ m),
-     ("peer_id", pack . urlEncode $ peer_id),
-     ("port", pack $ show port),
-     ("uploaded", pack $ show up),
-     ("downloaded", pack $ show down),
-     ("left", pack $ show bytesLeft),
-     ("compact", "1"),
-     ("event", "started")]
-
-trackerLoop :: PortNumber -> String -> Metainfo -> TState -> IO ByteString
-trackerLoop port peerId m st = do
-  up <- readMVar $ uploaded st
-  down <- readMVar $ downloaded st
-  resp <- sendGetRequest (head . announceList $ m) $ mkArgs port peerId up down m
-  case Benc.decode resp of
-    Left e -> return $ pack (show e)
-    Right trackerInfo ->
-      case parseTrackerResponse trackerInfo of
-        Left e -> return e
-        Right tresp -> do
-          _ <- threadDelay $ fromIntegral (interval tresp)
-          _ <- putMVar (connectedPeers st) (peers tresp)
-          trackerLoop port peerId m st
-
--- udp tracker
-getResponse :: Socket -> IO UDPResponse
-getResponse s = do
-  -- connect packet is 16 bytes long
-  -- announce packet is atleast 20 bytes long
-  bs <- recv s (16*1024)
-  return $ decode $ fromStrict bs
-
-sendRequest :: Socket -> String -> PortNumber -> UDPRequest -> IO ()
-sendRequest s ip port req = do
-  hostaddr <- inet_addr ip
-  _ <- sendTo s bsReq $ SockAddrInet (fromIntegral port) hostaddr
-  return ()
-    where bsReq = toStrict $ encode req
-
 getTrackerType :: String -> TrackerProtocol
 getTrackerType url | isPrefixOf "http://" url = Http
                    | isPrefixOf "udp://" url  = Udp
                    | otherwise                = UnknownProtocol
 
-udpTrackerLoop :: PortNumber -> String -> Metainfo -> TState -> IO String
-udpTrackerLoop port peerId m st = do
-  -- h <- connectTo "exodus.desync.com" (PortNumber 6969)
-  s <- socket AF_INET Datagram defaultProtocol
-  hostAddr <- inet_addr "185.37.101.229"
-  putStrLn "connected to tracker"
-  _ <- sendTo s (toStrict $ encode (ConnectReq 42)) (SockAddrInet 2710 hostAddr)
-  putStrLn "--> sent ConnectReq to tracker"
-  resp <- recv s 16
-  putStrLn "<-- recv ConnectResp from tracker"
-  return $ show resp

diff --git a/src/FuncTorrent/Tracker/Http.hs b/src/FuncTorrent/Tracker/Http.hs
new file mode 100644 (file)
index 0000000..dacadbf
--- /dev/null
+++ b/src/FuncTorrent/Tracker/Http.hs
@@ -0,0 +1,104 @@
+{-# LANGUAGE OverloadedStrings #-}
+module FuncTorrent.Tracker.Http
+       ( trackerLoop
+       ) where
+
+import Prelude hiding (lookup, splitAt)
+
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.MVar (readMVar, putMVar)
+import qualified Data.ByteString.Base16 as B16 (encode)
+import Data.ByteString (ByteString)
+import Data.ByteString.Char8 as BC (pack, unpack, splitAt)
+import Data.Char (chr)
+import Data.List (intercalate)
+import Data.Map as M (lookup)
+import Network (PortNumber)
+import Network.HTTP.Base (urlEncode)
+
+import qualified FuncTorrent.Bencode as Benc
+import FuncTorrent.Bencode (BVal(..))
+import FuncTorrent.Metainfo (Info(..), Metainfo(..))
+import FuncTorrent.Network (sendGetRequest)
+import FuncTorrent.Peer (Peer(..))
+import FuncTorrent.Utils (splitN)
+import FuncTorrent.Tracker.Types(TState(..), TrackerResponse(..), Port, IP)
+
+
+--- | URL encode hash as per RFC1738
+--- TODO: Add tests
+--- REVIEW: Why is this not written in terms of `Network.HTTP.Base.urlEncode` or
+--- equivalent library function?
+urlEncodeHash :: ByteString -> String
+urlEncodeHash bs = concatMap (encode' . unpack) (splitN 2 bs)
+  where encode' b@[c1, c2] = let c =  chr (read ("0x" ++ b))
+                            in escape c c1 c2
+        encode' _ = ""
+        escape i c1 c2 | i `elem` nonSpecialChars = [i]
+                       | otherwise = "%" ++ [c1] ++ [c2]
+
+        nonSpecialChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_.~"
+
+-- | Make arguments that should be posted to tracker.
+-- This is a separate pure function for testability.
+mkArgs :: PortNumber -> String -> Integer -> Integer -> Metainfo -> [(String, ByteString)]
+mkArgs port peer_id up down m =
+  let fileSize = lengthInBytes $ info m
+      bytesLeft = fileSize - down
+  in
+    [("info_hash", pack . urlEncodeHash . B16.encode . infoHash $ m),
+     ("peer_id", pack . urlEncode $ peer_id),
+     ("port", pack $ show port),
+     ("uploaded", pack $ show up),
+     ("downloaded", pack $ show down),
+     ("left", pack $ show bytesLeft),
+     ("compact", "1"),
+     ("event", "started")]
+
+trackerLoop :: PortNumber -> String -> Metainfo -> TState -> IO ByteString
+trackerLoop port peerId m st = do
+  up <- readMVar $ uploaded st
+  down <- readMVar $ downloaded st
+  resp <- sendGetRequest (head . announceList $ m) $ mkArgs port peerId up down m
+  case Benc.decode resp of
+    Left e -> return $ pack (show e)
+    Right trackerInfo ->
+      case parseTrackerResponse trackerInfo of
+        Left e -> return e
+        Right tresp -> do
+          _ <- threadDelay $ fromIntegral (interval tresp)
+          _ <- putMVar (connectedPeers st) (peers tresp)
+          trackerLoop port peerId m st
+
+parseTrackerResponse :: BVal -> Either ByteString TrackerResponse
+parseTrackerResponse resp =
+    case lookup "failure reason" body of
+      Just (Bstr err) -> Left err
+      Just _ -> Left "Unknown failure"
+      Nothing ->
+          let (Just (Bint i)) = lookup "interval" body
+              (Just (Bstr peersBS)) = lookup "peers" body
+              pl = map makePeer (splitN 6 peersBS)
+          in Right TrackerResponse {
+                   interval = i
+                 , peers = pl
+                 , complete = Nothing
+                 , incomplete = Nothing
+                 }
+    where
+      (Bdict body) = resp
+
+makePeer :: ByteString -> Peer
+makePeer peer = Peer "" (toIP ip') (toPort port')
+  where (ip', port') = splitAt 4 peer
+
+toPort :: ByteString -> Port
+toPort = read . ("0x" ++) . unpack . B16.encode
+
+toIP :: ByteString -> IP
+toIP = Data.List.intercalate "." .
+       map (show . toInt . ("0x" ++) . unpack) .
+       splitN 2 . B16.encode
+
+toInt :: String -> Integer
+toInt = read

diff --git a/src/FuncTorrent/Tracker/Types.hs b/src/FuncTorrent/Tracker/Types.hs
new file mode 100644 (file)
index 0000000..6ca5ddb
--- /dev/null
+++ b/src/FuncTorrent/Tracker/Types.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE OverloadedStrings #-}
+module FuncTorrent.Tracker.Types
+       ( TrackerProtocol(..)
+       , TrackerResponse(..)
+       , TrackerEventState(..)
+       , TState(..)
+       , IP
+       , Port
+       ) where
+
+import Control.Concurrent.MVar (MVar)
+
+import FuncTorrent.Peer (Peer(..))
+
+type IP = String
+type Port = Integer
+
+data TrackerProtocol = Http
+                     | Udp
+                     | UnknownProtocol
+                     deriving (Show)
+
+data TrackerEventState = None
+                       | Started
+                       | Stopped
+                       | Completed
+                       deriving (Show, Eq)
+
+data TState = TState {
+    uploaded :: MVar Integer
+  , downloaded :: MVar Integer
+  , left :: Integer
+  , currentState :: TrackerEventState
+  , connectedPeers :: MVar [Peer]
+  }
+
+-- | Tracker response
+data TrackerResponse = TrackerResponse {
+  interval :: Integer
+  , peers :: [Peer]
+  , complete :: Maybe Integer
+  , incomplete :: Maybe Integer
+  } deriving (Show, Eq)

diff --git a/src/main/Main.hs b/src/main/Main.hs
index 623fe318e6ea6c8f856d79136edaa6b4ed84400e..268e9a4e7c509ffc0c2edbbdcab1fce95d54101a 100644 (file)
--- a/src/main/Main.hs
+++ b/src/main/Main.hs
@@ -12,7 +12,7 @@ import           FuncTorrent.Metainfo (Info(..), Metainfo(..), torrentToMetainfo
 import           FuncTorrent.Peer (handlePeerMsgs)
 import           FuncTorrent.PieceManager (initPieceMap)
 import qualified FuncTorrent.Server as Server
-import           FuncTorrent.Tracker (connectedPeers, initialTrackerState, trackerLoop, udpTrackerLoop)
+import           FuncTorrent.Tracker (connectedPeers, initialTrackerState, trackerLoop)
 import           Network (PortID (PortNumber))
 import           System.IO (withFile, IOMode (ReadWriteMode))
 import           System.Directory (doesFileExist)