diff options
-rw-r--r-- | src/Network/BitTorrent/Tracker/Message.hs | 45 | ||||
-rw-r--r-- | src/Network/BitTorrent/Tracker/RPC/HTTP.hs | 20 |
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 |
658 | data AnnounceQueryExt = AnnounceQueryExt | 659 | -- 'AnnounceInfo'. It's optional for trackers to honor any of this |
660 | -- options. | ||
661 | data 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 | ||
683 | instance Default AnnounceQueryExt where | 686 | instance Default AnnouncePrefs where |
684 | def = AnnounceQueryExt Nothing Nothing | 687 | def = AnnouncePrefs Nothing Nothing |
685 | 688 | ||
686 | instance QueryLike AnnounceQueryExt where | 689 | instance 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. |
696 | parseAnnounceQueryExt :: SimpleQuery -> AnnounceQueryExt | 699 | parseAnnouncePrefs :: SimpleQuery -> AnnouncePrefs |
697 | parseAnnounceQueryExt params = either (const def) id $ | 700 | parseAnnouncePrefs 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. |
703 | renderAnnounceQueryExt :: AnnounceQueryExt -> SimpleQuery | 706 | renderAnnouncePrefs :: AnnouncePrefs -> SimpleQuery |
704 | renderAnnounceQueryExt = queryToSimpleQuery . toQuery | 707 | renderAnnouncePrefs = queryToSimpleQuery . toQuery |
705 | 708 | ||
706 | -- | HTTP tracker request with extensions. | 709 | -- | HTTP tracker request with preferences. |
707 | data AnnounceRequest = AnnounceRequest | 710 | data 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 | ||
712 | instance QueryLike AnnounceRequest where | 715 | instance 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. |
718 | parseAnnounceRequest :: SimpleQuery -> ParseResult AnnounceRequest | 721 | parseAnnounceRequest :: SimpleQuery -> ParseResult AnnounceRequest |
719 | parseAnnounceRequest params = AnnounceRequest | 722 | parseAnnounceRequest 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. |
724 | renderAnnounceRequest :: AnnounceRequest -> SimpleQuery | 727 | renderAnnounceRequest :: 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. |
75 | data Options = Options | 75 | data 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 | ||
89 | instance Default Options where | 89 | instance 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 | |||
148 | announce mgr uri q = httpTracker mgr uri (renderAnnounceRequest uriQ) | 148 | announce 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' |