summaryrefslogtreecommitdiff
path: root/src/Network/BitTorrent/Tracker/Message.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network/BitTorrent/Tracker/Message.hs')
-rw-r--r--src/Network/BitTorrent/Tracker/Message.hs20
1 files changed, 11 insertions, 9 deletions
diff --git a/src/Network/BitTorrent/Tracker/Message.hs b/src/Network/BitTorrent/Tracker/Message.hs
index 9ce2e67b..046f7e57 100644
--- a/src/Network/BitTorrent/Tracker/Message.hs
+++ b/src/Network/BitTorrent/Tracker/Message.hs
@@ -46,11 +46,10 @@ module Network.BitTorrent.Tracker.Message
46 where 46 where
47 47
48import Control.Applicative 48import Control.Applicative
49import Control.Exception
50import Control.Monad 49import Control.Monad
51import Data.Aeson (ToJSON(..), FromJSON(..)) 50import Data.Aeson (ToJSON(..), FromJSON(..))
52import Data.Aeson.TH 51import Data.Aeson.TH
53import Data.BEncode as BE 52import Data.BEncode as BE hiding (Result)
54import Data.BEncode.BDict as BE 53import Data.BEncode.BDict as BE
55import Data.ByteString as BS 54import Data.ByteString as BS
56import Data.ByteString.Char8 as BC 55import Data.ByteString.Char8 as BC
@@ -59,7 +58,6 @@ import Data.Convertible
59import Data.List as L 58import Data.List as L
60import Data.Map as M 59import Data.Map as M
61import Data.Maybe 60import Data.Maybe
62import Data.Monoid
63import Data.Serialize as S hiding (Result) 61import Data.Serialize as S hiding (Result)
64import Data.Text (Text) 62import Data.Text (Text)
65import Data.Text.Encoding 63import Data.Text.Encoding
@@ -70,7 +68,6 @@ import Network.HTTP.Types.QueryLike
70import Network.HTTP.Types.URI hiding (urlEncode) 68import Network.HTTP.Types.URI hiding (urlEncode)
71import Network.HTTP.Types.Status 69import Network.HTTP.Types.Status
72import Network.Socket 70import Network.Socket
73import Network.URI
74import Text.Read (readMaybe) 71import Text.Read (readMaybe)
75 72
76import Data.Torrent.InfoHash 73import Data.Torrent.InfoHash
@@ -232,7 +229,7 @@ renderAnnounceQuery = filterMaybes . toQuery
232 filterMaybes :: [(a, Maybe b)] -> [(a, b)] 229 filterMaybes :: [(a, Maybe b)] -> [(a, b)]
233 filterMaybes = catMaybes . L.map f 230 filterMaybes = catMaybes . L.map f
234 where 231 where
235 f (a, Nothing) = Nothing 232 f (_, Nothing) = Nothing
236 f (a, Just b ) = Just (a, b) 233 f (a, Just b ) = Just (a, b)
237 234
238data QueryParam 235data QueryParam
@@ -289,18 +286,23 @@ instance FromParam Event where
289 Nothing -> Nothing 286 Nothing -> Nothing
290 Just (x, xs) -> readMaybe $ BC.unpack $ BC.cons (Char.toUpper x) xs 287 Just (x, xs) -> readMaybe $ BC.unpack $ BC.cons (Char.toUpper x) xs
291 288
289type Result = Either ParamParseFailure
290
291withError :: ParamParseFailure -> Maybe a -> Result a
292withError e = maybe (Left e) Right 292withError e = maybe (Left e) Right
293 293
294reqParam :: FromParam a => QueryParam -> SimpleQuery -> Result a
294reqParam param xs = do 295reqParam param xs = do
295 val <- withError (Missing param) $ L.lookup (paramName param) xs 296 val <- withError (Missing param) $ L.lookup (paramName param) xs
296 withError (Invalid param val) (fromParam val) 297 withError (Invalid param val) (fromParam val)
297 298
299optParam :: FromParam a => QueryParam -> SimpleQuery -> Result (Maybe a)
298optParam param ps 300optParam param ps
299 | Just x <- L.lookup (paramName param) ps 301 | Just x <- L.lookup (paramName param) ps
300 = pure <$> withError (Invalid param x) (fromParam x) 302 = pure <$> withError (Invalid param x) (fromParam x)
301 | otherwise = pure Nothing 303 | otherwise = pure Nothing
302 304
303parseProgress :: SimpleQuery -> Either ParamParseFailure Progress 305parseProgress :: SimpleQuery -> Result Progress
304parseProgress params = Progress 306parseProgress params = Progress
305 <$> reqParam ParamDownloaded params 307 <$> reqParam ParamDownloaded params
306 <*> reqParam ParamLeft params 308 <*> reqParam ParamLeft params
@@ -318,7 +320,7 @@ parseAnnounceQuery params = AnnounceQuery
318 <*> optParam ParamEvent params 320 <*> optParam ParamEvent params
319 321
320-- TODO add extension datatype 322-- TODO add extension datatype
321type AnnounceRequest = () 323--type AnnounceRequest = ()
322 324
323{----------------------------------------------------------------------- 325{-----------------------------------------------------------------------
324-- Announce response 326-- Announce response
@@ -471,8 +473,8 @@ parseFailureMessage e = BS.concat $ case e of
471parseFailureStatus :: ParamParseFailure -> Status 473parseFailureStatus :: ParamParseFailure -> Status
472parseFailureStatus = mkStatus <$> parseFailureCode <*> parseFailureMessage 474parseFailureStatus = mkStatus <$> parseFailureCode <*> parseFailureMessage
473 475
474type AnnounceResponse = Either Status AnnounceInfo -- TODO 476--type AnnounceResponse = Either Status AnnounceInfo -- TODO
475type TrackerResponse = () -- TODO 477--type TrackerResponse = () -- TODO
476 478
477{----------------------------------------------------------------------- 479{-----------------------------------------------------------------------
478 Scrape message 480 Scrape message