From 285a01b62a2cf42d3548a0af6235f7ae2e3d1603 Mon Sep 17 00:00:00 2001
From: Sam Truzjan <pxqr.sta@gmail.com>
Date: Thu, 6 Feb 2014 05:34:31 +0400
Subject: Add unified tracker RpcExceptions

---
 src/Network/BitTorrent/Tracker/RPC.hs | 29 +++++++++++++++++++++++------
 1 file changed, 23 insertions(+), 6 deletions(-)

diff --git a/src/Network/BitTorrent/Tracker/RPC.hs b/src/Network/BitTorrent/Tracker/RPC.hs
index bd8da02b..48048964 100644
--- a/src/Network/BitTorrent/Tracker/RPC.hs
+++ b/src/Network/BitTorrent/Tracker/RPC.hs
@@ -7,6 +7,7 @@
 --
 --   Protocol independent bittorrent tracker API.
 --
+{-# LANGUAGE DeriveDataTypeable #-}
 module Network.BitTorrent.Tracker.RPC
        ( PeerInfo (..)
 
@@ -19,12 +20,14 @@ module Network.BitTorrent.Tracker.RPC
 
          -- * RPC
        , SAnnounceQuery (..)
+       , RpcException (..)
        , announce
        , scrape
        ) where
 
 import Control.Exception
 import Data.Default
+import Data.Typeable
 import Network
 import Network.URI
 import Network.Socket (HostAddress)
@@ -113,18 +116,32 @@ closeManager Manager {..} = do
 withManager :: Options -> PeerInfo -> (Manager -> IO a) -> IO a
 withManager opts info = bracket (newManager opts info) closeManager
 
+{-----------------------------------------------------------------------
+--  Exceptions
+-----------------------------------------------------------------------}
+-- TODO Catch IO exceptions on rpc calls (?)
+
+data RpcException
+  = UdpException    UDP.RpcException  -- ^
+  | HttpException   HTTP.RpcException -- ^
+  | UnknownProtocol String            -- ^ unknown tracker protocol scheme
+    deriving (Show, Typeable)
+
+instance Exception RpcException
+
+packException :: Exception e => (e -> RpcException) -> IO a -> IO a
+packException f m = try m >>= either (throwIO . f) return
+{-# INLINE packException #-}
+
 {-----------------------------------------------------------------------
 --  RPC calls
 -----------------------------------------------------------------------}
--- TODO Catch IO exceptions on rpc calls.
 
 dispatch :: URI -> IO a -> IO a -> IO a
 dispatch URI {..} http udp
-  | uriScheme == "http:" = http
-  | uriScheme == "udp:"  = udp
-  |       otherwise      = throwIO $ userError msg
-  where
-    msg  = "unknown tracker protocol scheme: " ++ show uriScheme
+  | uriScheme == "http:" = packException HttpException http
+  | uriScheme == "udp:"  = packException UdpException  udp
+  |       otherwise      = throwIO $ UnknownProtocol uriScheme
 
 announce :: Manager -> URI -> SAnnounceQuery -> IO AnnounceInfo
 announce Manager {..} uri simpleQuery
-- 
cgit v1.2.3