From 2b0904572760fb7f3940168d6be5d1628854b009 Mon Sep 17 00:00:00 2001 From: Sam T Date: Sat, 20 Jul 2013 19:52:08 +0400 Subject: ~ Give more reasonable name for tracker messages. Announce request/response is not only request/response types! Moreover we can unify and reuse UDP and HTTP tracker messages. --- src/Network/BitTorrent/Tracker.hs | 14 ++++----- src/Network/BitTorrent/Tracker/Protocol.hs | 49 +++++++++++++++--------------- 2 files changed, 31 insertions(+), 32 deletions(-) (limited to 'src') diff --git a/src/Network/BitTorrent/Tracker.hs b/src/Network/BitTorrent/Tracker.hs index 25d2c358..7a43fb23 100644 --- a/src/Network/BitTorrent/Tracker.hs +++ b/src/Network/BitTorrent/Tracker.hs @@ -88,8 +88,8 @@ tconnection t = TConnection (tAnnounce t) (tInfoHash t) -- | used to avoid boilerplate; do NOT export me -genericReq :: TConnection -> Progress -> TRequest -genericReq ses pr = TRequest { +genericReq :: TConnection -> Progress -> AnnounceQuery +genericReq ses pr = AnnounceQuery { reqInfoHash = tconnInfoHash ses , reqPeerId = tconnPeerId ses , reqPort = tconnPort ses @@ -107,7 +107,7 @@ genericReq ses pr = TRequest { -- | The first request to the tracker that should be created is -- 'startedReq'. It includes necessary 'Started' event field. -- -startedReq :: TConnection -> Progress -> TRequest +startedReq :: TConnection -> Progress -> AnnounceQuery startedReq ses pr = (genericReq ses pr) { reqIP = Nothing , reqNumWant = Just defaultNumWant @@ -118,7 +118,7 @@ startedReq ses pr = (genericReq ses pr) { -- notify tracker about current state of the client -- so new peers could connect to the client. -- -regularReq :: Int -> TConnection -> Progress -> TRequest +regularReq :: Int -> TConnection -> Progress -> AnnounceQuery regularReq numWant ses pr = (genericReq ses pr) { reqIP = Nothing , reqNumWant = Just numWant @@ -128,7 +128,7 @@ regularReq numWant ses pr = (genericReq ses pr) { -- | Must be sent to the tracker if the client is shutting down -- gracefully. -- -stoppedReq :: TConnection -> Progress -> TRequest +stoppedReq :: TConnection -> Progress -> AnnounceQuery stoppedReq ses pr = (genericReq ses pr) { reqIP = Nothing , reqNumWant = Nothing @@ -139,7 +139,7 @@ stoppedReq ses pr = (genericReq ses pr) { -- However, must not be sent if the download was already 100% -- complete. -- -completedReq :: TConnection -> Progress -> TRequest +completedReq :: TConnection -> Progress -> AnnounceQuery completedReq ses pr = (genericReq ses pr) { reqIP = Nothing , reqNumWant = Nothing @@ -233,7 +233,7 @@ withTracker initProgress conn action = bracket start end (action . fst) resp <- tryJust isIOException $ do askTracker (tconnAnnounce conn) (regularReq defaultNumWant conn pr) case resp of - Right (OK {..}) -> do + Right (AnnounceInfo {..}) -> do writeIORef seInterval respInterval -- we rely on the fact that union on lists is not diff --git a/src/Network/BitTorrent/Tracker/Protocol.hs b/src/Network/BitTorrent/Tracker/Protocol.hs index e844f8b8..95d82b36 100644 --- a/src/Network/BitTorrent/Tracker/Protocol.hs +++ b/src/Network/BitTorrent/Tracker/Protocol.hs @@ -22,9 +22,8 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} --- TODO: add "compact" field to TRequest module Network.BitTorrent.Tracker.Protocol - ( Event(..), TRequest(..), TResponse(..) + ( Event(..), AnnounceQuery(..), AnnounceInfo(..) , askTracker, leaveTracker -- * Defaults @@ -55,7 +54,7 @@ import Network.URI import Network.BitTorrent.Peer {----------------------------------------------------------------------- - Tracker messages + Tracker Announce -----------------------------------------------------------------------} -- | Events used to specify which kind of tracker request is performed. @@ -73,7 +72,7 @@ data Event = Started -- the torrent. The most important, requests are used by the tracker -- to keep track lists of active peer for a particular torrent. -- -data TRequest = TRequest { -- TODO peer here +data AnnounceQuery = AnnounceQuery { reqInfoHash :: !InfoHash -- ^ Hash of info part of the torrent usually obtained from -- 'Torrent'. @@ -112,9 +111,9 @@ data TRequest = TRequest { -- TODO peer here -- participate in the torrent. The most important is 'respPeer' list -- used to join the swarm. -- -data TResponse = +data AnnounceInfo = Failure Text -- ^ Failure reason in human readable form. - | OK { -- TODO rename to anounce + | AnnounceInfo { respWarning :: Maybe Text -- ^ Human readable warning. @@ -138,12 +137,12 @@ data TResponse = } deriving Show {----------------------------------------------------------------------- - HTTP Tracker encoding + HTTP Announce -----------------------------------------------------------------------} -instance BEncodable TResponse where - toBEncode (Failure t) = fromAssocs ["failure reason" --> t] - toBEncode (OK {..}) = fromAssocs +instance BEncodable AnnounceInfo where + toBEncode (Failure t) = fromAssocs ["failure reason" --> t] + toBEncode AnnounceInfo {..} = fromAssocs [ "interval" --> respInterval , "min interval" -->? respMinInterval , "complete" -->? respComplete @@ -153,7 +152,8 @@ instance BEncodable TResponse where fromBEncode (BDict d) | Just t <- M.lookup "failure reason" d = Failure <$> fromBEncode t - | otherwise = OK <$> d >--? "warning message" + | otherwise = AnnounceInfo + <$> d >--? "warning message" <*> d >-- "interval" <*> d >--? "min interval" <*> d >--? "complete" @@ -165,7 +165,7 @@ instance BEncodable TResponse where getPeers (Just (BString s)) = runGet getCompactPeerList s getPeers _ = decodingError "Peers" - fromBEncode _ = decodingError "TResponse" + fromBEncode _ = decodingError "AnnounceInfo" instance URLShow PortNumber where urlShow = urlShow . fromEnum @@ -179,8 +179,8 @@ instance URLShow Event where -- INVARIANT: this is always nonempty list (x : xs) = show e -instance URLEncode TRequest where - urlEncode TRequest {..} = mconcat +instance URLEncode AnnounceQuery where + urlEncode AnnounceQuery {..} = mconcat [ s "peer_id" %= reqPeerId , s "port" %= reqPort , s "uploaded" %= reqUploaded @@ -192,13 +192,13 @@ instance URLEncode TRequest where ] where s :: String -> String; s = id; {-# INLINE s #-} -encodeRequest :: URI -> TRequest -> URI +encodeRequest :: URI -> AnnounceQuery -> URI encodeRequest announce req = URL.urlEncode req `addToURI` announce `addHashToURI` reqInfoHash req {----------------------------------------------------------------------- - UDP tracker encoding + UDP announce -----------------------------------------------------------------------} type EventId = Word32 @@ -223,8 +223,8 @@ getEvent = do 3 -> return $ Just Stopped _ -> fail "unknown event id" -instance Serialize TRequest where - put TRequest {..} = do +instance Serialize AnnounceQuery where + put AnnounceQuery {..} = do put reqInfoHash put reqPeerId @@ -254,7 +254,7 @@ instance Serialize TRequest where port <- get - return $ TRequest { + return $ AnnounceQuery { reqInfoHash = ih , reqPeerId = pid , reqPort = port @@ -266,9 +266,9 @@ instance Serialize TRequest where , reqEvent = ev } -instance Serialize TResponse where +instance Serialize AnnounceInfo where put (Failure msg) = put $ encodeUtf8 msg - put OK {..} = do + put AnnounceInfo {..} = do putWord32be $ fromIntegral respInterval putWord32be $ fromIntegral $ fromMaybe 0 respIncomplete putWord32be $ fromIntegral $ fromMaybe 0 respComplete @@ -280,7 +280,7 @@ instance Serialize TResponse where seeders <- getWord32be peers <- many get - return $ OK { + return $ AnnounceInfo { respWarning = Nothing , respInterval = fromIntegral interval , respMinInterval = Nothing @@ -289,7 +289,6 @@ instance Serialize TResponse where , respPeers = peers } - {----------------------------------------------------------------------- Tracker -----------------------------------------------------------------------} @@ -316,7 +315,7 @@ mkHTTPRequest uri = Request uri GET [] "" -- announce list. This function throws 'IOException' if it couldn't -- send request or receive response or decode response. -- -askTracker :: URI -> TRequest -> IO TResponse +askTracker :: URI -> AnnounceQuery -> IO AnnounceInfo askTracker announce req = do let r = mkHTTPRequest (encodeRequest announce req) @@ -333,7 +332,7 @@ askTracker announce req = do -- | The same as the 'askTracker' but ignore response. Used in -- conjunction with 'Stopped'. -leaveTracker :: URI -> TRequest -> IO () +leaveTracker :: URI -> AnnounceQuery -> IO () leaveTracker announce req = do let r = mkHTTPRequest (encodeRequest announce req) void $ simpleHTTP r >>= getResponseBody -- cgit v1.2.3