summaryrefslogtreecommitdiff
path: root/src/Network
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network')
-rw-r--r--src/Network/BitTorrent/Tracker/Message.hs45
-rw-r--r--src/Network/BitTorrent/Tracker/RPC/HTTP.hs20
2 files changed, 34 insertions, 31 deletions
diff --git a/src/Network/BitTorrent/Tracker/Message.hs b/src/Network/BitTorrent/Tracker/Message.hs
index de12a1fa..edafdaba 100644
--- a/src/Network/BitTorrent/Tracker/Message.hs
+++ b/src/Network/BitTorrent/Tracker/Message.hs
@@ -59,11 +59,12 @@ module Network.BitTorrent.Tracker.Message
59 , defaultAnnouncePath 59 , defaultAnnouncePath
60 , defaultScrapePath 60 , defaultScrapePath
61 61
62 -- ** Request 62 -- ** Preferences
63 , AnnounceQueryExt (..) 63 , AnnouncePrefs (..)
64 , renderAnnounceQueryExt 64 , renderAnnouncePrefs
65 , parseAnnounceQueryExt 65 , parseAnnouncePrefs
66 66
67 -- ** Request
67 , AnnounceRequest (..) 68 , AnnounceRequest (..)
68 , parseAnnounceRequest 69 , parseAnnounceRequest
69 , renderAnnounceRequest 70 , renderAnnounceRequest
@@ -654,8 +655,10 @@ type ScrapeInfo = [(InfoHash, ScrapeEntry)]
654-- HTTP specific 655-- HTTP specific
655-----------------------------------------------------------------------} 656-----------------------------------------------------------------------}
656 657
657-- | Extensions for HTTP tracker protocol. 658-- | Some HTTP trackers allow to choose prefered representation of the
658data AnnounceQueryExt = AnnounceQueryExt 659-- 'AnnounceInfo'. It's optional for trackers to honor any of this
660-- options.
661data AnnouncePrefs = AnnouncePrefs
659 { -- | If specified, "compact" parameter is used to advise the 662 { -- | If specified, "compact" parameter is used to advise the
660 -- tracker to send peer id list as: 663 -- tracker to send peer id list as:
661 -- 664 --
@@ -680,11 +683,11 @@ data AnnounceQueryExt = AnnounceQueryExt
680 , extNoPeerId :: !(Maybe Bool) 683 , extNoPeerId :: !(Maybe Bool)
681 } deriving (Show, Eq, Typeable) 684 } deriving (Show, Eq, Typeable)
682 685
683instance Default AnnounceQueryExt where 686instance Default AnnouncePrefs where
684 def = AnnounceQueryExt Nothing Nothing 687 def = AnnouncePrefs Nothing Nothing
685 688
686instance QueryLike AnnounceQueryExt where 689instance QueryLike AnnouncePrefs where
687 toQuery AnnounceQueryExt {..} = 690 toQuery AnnouncePrefs {..} =
688 [ ("compact", toQueryFlag <$> extCompact) -- TODO use 'paramName' 691 [ ("compact", toQueryFlag <$> extCompact) -- TODO use 'paramName'
689 , ("no_peer_id", toQueryFlag <$> extNoPeerId) 692 , ("no_peer_id", toQueryFlag <$> extNoPeerId)
690 ] 693 ]
@@ -693,32 +696,32 @@ instance QueryLike AnnounceQueryExt where
693 toQueryFlag True = "1" 696 toQueryFlag True = "1"
694 697
695-- | Parse announce query extended part from query string. 698-- | Parse announce query extended part from query string.
696parseAnnounceQueryExt :: SimpleQuery -> AnnounceQueryExt 699parseAnnouncePrefs :: SimpleQuery -> AnnouncePrefs
697parseAnnounceQueryExt params = either (const def) id $ 700parseAnnouncePrefs params = either (const def) id $
698 AnnounceQueryExt 701 AnnouncePrefs
699 <$> optParam ParamCompact params 702 <$> optParam ParamCompact params
700 <*> optParam ParamNoPeerId params 703 <*> optParam ParamNoPeerId params
701 704
702-- | Render announce query extended part to query string. 705-- | Render announce preferences to query string.
703renderAnnounceQueryExt :: AnnounceQueryExt -> SimpleQuery 706renderAnnouncePrefs :: AnnouncePrefs -> SimpleQuery
704renderAnnounceQueryExt = queryToSimpleQuery . toQuery 707renderAnnouncePrefs = queryToSimpleQuery . toQuery
705 708
706-- | HTTP tracker request with extensions. 709-- | HTTP tracker request with preferences.
707data AnnounceRequest = AnnounceRequest 710data AnnounceRequest = AnnounceRequest
708 { announceQuery :: AnnounceQuery -- ^ Request query params. 711 { announceQuery :: AnnounceQuery -- ^ Request query params.
709 , announceAdvises :: AnnounceQueryExt -- ^ Optional advises to the tracker. 712 , announcePrefs :: AnnouncePrefs -- ^ Optional advises to the tracker.
710 } deriving (Show, Eq, Typeable) 713 } deriving (Show, Eq, Typeable)
711 714
712instance QueryLike AnnounceRequest where 715instance QueryLike AnnounceRequest where
713 toQuery AnnounceRequest{..} = 716 toQuery AnnounceRequest{..} =
714 toQuery announceAdvises <> 717 toQuery announcePrefs <>
715 toQuery announceQuery 718 toQuery announceQuery
716 719
717-- | Parse announce request from query string. 720-- | Parse announce request from query string.
718parseAnnounceRequest :: SimpleQuery -> ParseResult AnnounceRequest 721parseAnnounceRequest :: SimpleQuery -> ParseResult AnnounceRequest
719parseAnnounceRequest params = AnnounceRequest 722parseAnnounceRequest params = AnnounceRequest
720 <$> parseAnnounceQuery params 723 <$> parseAnnounceQuery params
721 <*> pure (parseAnnounceQueryExt params) 724 <*> pure (parseAnnouncePrefs params)
722 725
723-- | Render announce request to query string. 726-- | Render announce request to query string.
724renderAnnounceRequest :: AnnounceRequest -> SimpleQuery 727renderAnnounceRequest :: AnnounceRequest -> SimpleQuery
diff --git a/src/Network/BitTorrent/Tracker/RPC/HTTP.hs b/src/Network/BitTorrent/Tracker/RPC/HTTP.hs
index 81199921..cc5bd318 100644
--- a/src/Network/BitTorrent/Tracker/RPC/HTTP.hs
+++ b/src/Network/BitTorrent/Tracker/RPC/HTTP.hs
@@ -74,24 +74,24 @@ packHttpException m = try m >>= either (throwIO . RequestFailed) return
74-- | HTTP tracker specific RPC options. 74-- | HTTP tracker specific RPC options.
75data Options = Options 75data Options = Options
76 { -- | Global HTTP announce query preferences. 76 { -- | Global HTTP announce query preferences.
77 optAnnounceExt :: !AnnounceQueryExt 77 optAnnouncePrefs :: !AnnouncePrefs
78 78
79 -- | Whether to use HTTP proxy for HTTP tracker requests. 79 -- | Whether to use HTTP proxy for HTTP tracker requests.
80 , optHttpProxy :: !(Maybe Proxy) 80 , optHttpProxy :: !(Maybe Proxy)
81 81
82 -- | Value to put in HTTP user agent header. 82 -- | Value to put in HTTP user agent header.
83 , optUserAgent :: !BS.ByteString 83 , optUserAgent :: !BS.ByteString
84 84
85 -- | HTTP manager options. 85 -- | HTTP manager options.
86 , optHttpOptions :: !ManagerSettings 86 , optHttpOptions :: !ManagerSettings
87 } 87 }
88 88
89instance Default Options where 89instance Default Options where
90 def = Options 90 def = Options
91 { optAnnounceExt = def 91 { optAnnouncePrefs = def
92 , optHttpProxy = Nothing 92 , optHttpProxy = Nothing
93 , optUserAgent = BC.pack libUserAgent 93 , optUserAgent = BC.pack libUserAgent
94 , optHttpOptions = defaultManagerSettings 94 , optHttpOptions = defaultManagerSettings
95 } 95 }
96 96
97-- | HTTP tracker manager. 97-- | HTTP tracker manager.
@@ -148,8 +148,8 @@ announce :: Manager -> URI -> AnnounceQuery -> IO AnnounceInfo
148announce mgr uri q = httpTracker mgr uri (renderAnnounceRequest uriQ) 148announce mgr uri q = httpTracker mgr uri (renderAnnounceRequest uriQ)
149 where 149 where
150 uriQ = AnnounceRequest 150 uriQ = AnnounceRequest
151 { announceQuery = q 151 { announceQuery = q
152 , announceAdvises = optAnnounceExt (options mgr) 152 , announcePrefs = optAnnouncePrefs (options mgr)
153 } 153 }
154 154
155-- | Trying to convert /announce/ URL to /scrape/ URL. If 'scrapeURL' 155-- | Trying to convert /announce/ URL to /scrape/ URL. If 'scrapeURL'