From f138b7d6444b2de6f1ceab115b07011131b477d3 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 6 Feb 2014 05:32:31 +0400 Subject: Add UDP tracker RpcExceptions --- src/Network/BitTorrent/Tracker/RPC/UDP.hs | 76 +++++++++++++++++++++++++++---- 1 file changed, 66 insertions(+), 10 deletions(-) (limited to 'src/Network/BitTorrent/Tracker') diff --git a/src/Network/BitTorrent/Tracker/RPC/UDP.hs b/src/Network/BitTorrent/Tracker/RPC/UDP.hs index a835dc23..bc4f9dd0 100644 --- a/src/Network/BitTorrent/Tracker/RPC/UDP.hs +++ b/src/Network/BitTorrent/Tracker/RPC/UDP.hs @@ -12,6 +12,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeFamilies #-} module Network.BitTorrent.Tracker.RPC.UDP ( -- * Manager @@ -22,6 +23,7 @@ module Network.BitTorrent.Tracker.RPC.UDP , withManager -- * RPC + , RpcException (..) , announce , scrape ) where @@ -41,6 +43,7 @@ import Data.Text as T import Data.Text.Encoding import Data.Time import Data.Time.Clock.POSIX +import Data.Typeable import Data.Word import Text.Read (readMaybe) import Network.Socket hiding (Connected, connect) @@ -71,7 +74,11 @@ defMaxPacketSize = 98 data Options = Options { optMaxPacketSize :: {-# UNPACK #-} !Int + + -- | in seconds. , optMinTimeout :: {-# UNPACK #-} !Int + + -- | in seconds. , optMaxTimeout :: {-# UNPACK #-} !Int } deriving (Show, Eq) @@ -101,6 +108,47 @@ closeManager Manager {..} = close sock withManager :: Options -> (Manager -> IO a) -> IO a withManager opts = bracket (newManager opts) closeManager +{----------------------------------------------------------------------- +-- Exceptions +-----------------------------------------------------------------------} + +data RpcException + -- | Unable to lookup hostname; + = HostUnknown + + -- | Unable to lookup hostname; + | HostLookupFailed + + -- | Tracker exists but not responding for specific number of seconds. + | TrackerNotResponding Int + + -- | Source\/destination socket address mismatch. + -- + -- WARNING: This is a BUG and will be fixed! + -- + | UnexpectedSource + + -- | Source\/destination transaction id mismatch. + -- + -- WARNING: This is a BUG and will be fixed! + -- + | TransactionFailed + + -- | Unable to decode tracker response; + | ParserFailure String + + -- | Tracker respond with unexpected message type. + | UnexpectedResponse + { expectedMsg :: String + , actualMsg :: String + } + + -- | RPC succeed, but tracker respond with error code. + | QueryFailed Text + deriving (Show, Typeable) + +instance Exception RpcException + {----------------------------------------------------------------------- -- Host Addr resolution -----------------------------------------------------------------------} @@ -116,8 +164,8 @@ resolveURI URI { uriAuthority = Just (URIAuth {..}) } = do let port = fromMaybe 0 (readMaybe (L.drop 1 uriPort) :: Maybe Int) case infos of AddrInfo {..} : _ -> return $ setPort (fromIntegral port) addrAddress - _ -> fail "getTrackerAddr: unable to lookup host addr" -resolveURI _ = fail "getTrackerAddr: hostname unknown" + _ -> throwIO HostLookupFailed +resolveURI _ = throwIO HostUnknown -- TODO caching? getTrackerAddr :: Manager -> URI -> IO SockAddr @@ -170,6 +218,12 @@ data Response = Connected ConnectionId | Failed Text deriving Show +responseName :: Response -> String +responseName (Connected _) = "connected" +responseName (Announced _) = "announced" +responseName (Scraped _) = "scraped" +responseName (Failed _) = "failed" + data family Transaction a data instance Transaction Request = TransactionQ { connIdQ :: {-# UNPACK #-} !ConnectionId @@ -297,7 +351,7 @@ call Manager {..} addr arg = do BS.sendAllTo sock arg addr (res, addr') <- BS.recvFrom sock (optMaxPacketSize options) unless (addr' == addr) $ do - throwIO $ userError "address mismatch" + throwIO $ UnexpectedSource return res transaction :: Manager -> SockAddr -> Connection -> Request -> IO Response @@ -308,8 +362,8 @@ transaction m addr conn request = do case decode res of Right (TransactionR {..}) | tid == transIdR -> return response - | otherwise -> throwIO $ userError "transaction id mismatch" - Left msg -> throwIO $ userError msg + | otherwise -> throwIO $ TransactionFailed + Left msg -> throwIO $ ParserFailure msg {----------------------------------------------------------------------- -- Connection cache @@ -320,8 +374,8 @@ connect m addr conn = do resp <- transaction m addr conn Connect case resp of Connected cid -> return cid - Failed msg -> throwIO $ userError $ T.unpack msg - _ -> throwIO $ userError "connect: response type mismatch" + Failed msg -> throwIO $ QueryFailed msg + _ -> throwIO $ UnexpectedResponse "connected" (responseName resp) newConnection :: Manager -> SockAddr -> IO Connection newConnection m addr = do @@ -358,7 +412,7 @@ retransmission :: Options -> IO a -> IO a retransmission Options {..} action = go optMinTimeout where go curTimeout - | curTimeout > optMaxTimeout = throwIO $ userError "tracker down" + | curTimeout > optMaxTimeout = throwIO $ TrackerNotResponding curTimeout | otherwise = do r <- timeout curTimeout action maybe (go (2 * curTimeout)) return r @@ -370,16 +424,18 @@ queryTracker mgr uri req = do conn <- getConnection mgr addr transaction mgr addr conn req +-- | This function can throw 'RpcException'. announce :: Manager -> URI -> AnnounceQuery -> IO AnnounceInfo announce mgr uri q = do resp <- queryTracker mgr uri (Announce q) case resp of Announced info -> return info - _ -> fail "announce: response type mismatch" + _ -> throwIO $ UnexpectedResponse "announce" (responseName resp) +-- | This function can throw 'RpcException'. scrape :: Manager -> URI -> ScrapeQuery -> IO ScrapeInfo scrape mgr uri ihs = do resp <- queryTracker mgr uri (Scrape ihs) case resp of Scraped info -> return $ L.zip ihs info - _ -> fail "scrape: response type mismatch" + _ -> throwIO $ UnexpectedResponse "scrape" (responseName resp) -- cgit v1.2.3