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/Protocol.hs | 49 +++++++++++++++--------------- 1 file changed, 24 insertions(+), 25 deletions(-) (limited to 'src/Network/BitTorrent/Tracker') 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