[tor-commits] [tordnsel/master] fix exceptions

arlo at torproject.org arlo at torproject.org
Sat Apr 16 06:08:43 UTC 2016


commit be92ae00b21041ff9033d8e2a83dd8610f8dc2d2
Author: David Kaloper <david at numm.org>
Date:   Tue Sep 3 20:45:12 2013 +0200

    fix exceptions
---
 src/TorDNSEL/Config/Internals.hs               | 18 ++---
 src/TorDNSEL/DNS/Server/Internals.hs           | 15 ++--
 src/TorDNSEL/ExitTest/Initiator/Internals.hs   | 44 ++++++------
 src/TorDNSEL/ExitTest/Server/Internals.hs      | 66 ++++++++++--------
 src/TorDNSEL/Log/Internals.hsc                 |  2 +-
 src/TorDNSEL/Main.hsc                          | 97 ++++++++++++++------------
 src/TorDNSEL/NetworkState/Internals.hs         | 24 ++++---
 src/TorDNSEL/NetworkState/Storage/Internals.hs | 10 +--
 src/TorDNSEL/Socks.hs                          |  1 -
 src/TorDNSEL/Socks/Internals.hs                |  9 +--
 src/TorDNSEL/Statistics/Internals.hs           | 11 +--
 src/TorDNSEL/TorControl.hs                     |  1 -
 src/TorDNSEL/TorControl/Internals.hs           | 56 +++++++--------
 src/TorDNSEL/Util.hsc                          | 12 ----
 14 files changed, 183 insertions(+), 183 deletions(-)

diff --git a/src/TorDNSEL/Config/Internals.hs b/src/TorDNSEL/Config/Internals.hs
index c8aa790..d93da96 100644
--- a/src/TorDNSEL/Config/Internals.hs
+++ b/src/TorDNSEL/Config/Internals.hs
@@ -52,7 +52,7 @@ import Control.Monad (liftM, liftM2, ap)
 import Control.Monad.Error (MonadError(..))
 import Control.Monad.Fix (fix)
 import Data.Char (isSpace, toLower)
-import Data.Maybe (catMaybes, isJust)
+import Data.Maybe (catMaybes)
 import qualified Data.ByteString.Char8 as B
 import Data.ByteString (ByteString)
 import qualified Data.Map as M
@@ -422,7 +422,7 @@ Otherwise, the server runs with the new configuration and closes the connection:
 startReconfigServer
   :: Socket -> (Config -> (Maybe String -> IO ()) -> IO ()) -> IO ReconfigServer
 startReconfigServer sock sendConfig = do
-  log Info "Starting reconfigure server."
+  log Info "Starting reconfigure server." :: IO ()
   chan <- newChan
   tid <- forkLinkIO $ do
     setTrapExit $ (writeChan chan .) . Exit
@@ -433,13 +433,13 @@ startReconfigServer sock sendConfig = do
 
 handleMessage :: State -> ReconfigMessage -> IO State
 handleMessage s (NewClient client signal) = do
-  E.handleJust E.ioErrors
-    (log Warn "Reading config from reconfigure socket failed: ") $
+  E.handle
+    (\(e :: E.IOException) -> log Warn "Reading config from reconfigure socket failed: " e) $
     E.bracket (socketToHandle client ReadWriteMode) hClose $ \handle -> do
       str <- B.hGetContents handle
       case parseConfigFile str >>= makeConfig of
         Left e -> do
-          hCat handle "Parse error: " e "\r\n"
+          hCat handle "Parse error: " e "\r\n" :: IO ()
           log Warn "Parsing config from reconfigure socket failed: " e
         Right config -> do
           mv <- newEmptyMVar
@@ -451,7 +451,7 @@ handleMessage s (NewClient client signal) = do
   return s
 
 handleMessage s (Terminate reason) = do
-  log Info "Terminating reconfigure server."
+  log Info "Terminating reconfigure server." :: IO ()
   terminateThread Nothing (listenerTid s) (killThread $ listenerTid s)
   msgs <- untilM (isEmptyChan $ reconfigChan s) (readChan $ reconfigChan s)
   sequence_ [sClose client | NewClient client _ <- msgs]
@@ -460,10 +460,10 @@ handleMessage s (Terminate reason) = do
 handleMessage s (Exit tid reason)
   | tid == listenerTid s = do
       log Warn "The reconfigure listener thread exited unexpectedly: "
-               (showExitReason [] reason) "; restarting."
+               (show reason) "; restarting." :: IO ()
       newListenerTid <- forkListener (listenSock s) (writeChan $ reconfigChan s)
       return s { listenerTid = newListenerTid }
-  | isJust reason = exit reason
+  | isAbnormal reason = exit reason
   | otherwise = return s
 
 -- | Fork the listener thread.
@@ -481,4 +481,4 @@ forkListener sock send =
 -- exit signal will be sent.
 terminateReconfigServer :: Maybe Int -> ReconfigServer -> IO ()
 terminateReconfigServer mbWait (ReconfigServer tid send) =
-  terminateThread mbWait tid (send $ Terminate Nothing)
+  terminateThread mbWait tid (send $ Terminate NormalExit)
diff --git a/src/TorDNSEL/DNS/Server/Internals.hs b/src/TorDNSEL/DNS/Server/Internals.hs
index 268ca8d..9bc8fc3 100644
--- a/src/TorDNSEL/DNS/Server/Internals.hs
+++ b/src/TorDNSEL/DNS/Server/Internals.hs
@@ -81,11 +81,18 @@ data DNSMessage
   | Terminate ExitReason -- ^ Terminate the DNS server gracefully
   deriving Typeable
 
+-- This is to please the Exception instance.
+instance Show DNSMessage where
+  showsPrec _ (Terminate a)     = ("Terminate " ++) . shows a
+  showsPrec _ (Reconfigure _ _) = ("Reconfigure" ++)
+
+instance E.Exception DNSMessage
+
 -- | Given an initial 'DNSConfig', start the DNS server and return a handle to
 -- it. Link the DNS server to the calling thread.
 startDNSServer :: DNSConfig -> IO DNSServer
 startDNSServer initConf = do
-  log Info "Starting DNS server."
+  log Info "Starting DNS server." :: IO ()
   fmap DNSServer . forkLinkIO . E.block . loop $ initConf
   where
     loop conf = do
@@ -101,7 +108,7 @@ startDNSServer initConf = do
           signal
           loop newConf
         Left (_,Terminate reason) -> do
-          log Info "Terminating DNS server."
+          log Info "Terminating DNS server." :: IO ()
           exit reason
         Right _ -> loop conf -- impossible
 
@@ -110,7 +117,7 @@ startDNSServer initConf = do
 -- the calling thread.
 reconfigureDNSServer :: (DNSConfig -> DNSConfig) -> DNSServer -> IO ()
 reconfigureDNSServer reconf (DNSServer tid) =
-  sendSyncMessage (throwDynTo tid . Reconfigure reconf) tid
+  sendSyncMessage (throwTo tid . exitReason . Reconfigure reconf) tid
 
 -- | Terminate the DNS server gracefully. The optional parameter specifies the
 -- amount of time in microseconds to wait for the thread to terminate. If the
@@ -118,7 +125,7 @@ reconfigureDNSServer reconf (DNSServer tid) =
 -- sent.
 terminateDNSServer :: Maybe Int -> DNSServer -> IO ()
 terminateDNSServer mbWait (DNSServer tid) =
-  terminateThread mbWait tid (throwDynTo tid $ Terminate Nothing)
+  terminateThread mbWait tid (throwTo tid $ exitReason $ Terminate NormalExit)
 
 -- | A stateful wrapper for 'dnsResponse'.
 dnsHandler :: DNSConfig -> Message -> IO (Maybe Message)
diff --git a/src/TorDNSEL/ExitTest/Initiator/Internals.hs b/src/TorDNSEL/ExitTest/Initiator/Internals.hs
index d4538df..4605c15 100644
--- a/src/TorDNSEL/ExitTest/Initiator/Internals.hs
+++ b/src/TorDNSEL/ExitTest/Initiator/Internals.hs
@@ -63,7 +63,7 @@ import qualified Data.Foldable as F
 import Data.List (foldl', unfoldr, mapAccumL)
 import qualified Data.Map as M
 import Data.Map (Map)
-import Data.Maybe (mapMaybe, isJust)
+import Data.Maybe (mapMaybe )
 import qualified Data.Sequence as Seq
 import Data.Sequence (Seq, ViewL((:<)), viewl, (<|), (|>), ViewR((:>)), viewr)
 import qualified Data.Set as Set
@@ -153,7 +153,7 @@ data TestStatus
 -- thread.
 startExitTestInitiator :: ExitTestInitiatorConfig -> IO ExitTestInitiator
 startExitTestInitiator initConf = do
-  log Info "Starting exit test initiator."
+  log Info "Starting exit test initiator." :: IO ()
   chan <- newChan
   initiatorTid <- forkLinkIO $ do
     setTrapExit ((writeChan chan .) . Exit)
@@ -172,15 +172,15 @@ startExitTestInitiator initConf = do
       | TestWaiting rid ports published <- testStatus s
       , canRunExitTest conf s ports = do
           log Info "Forking exit test clients for router " rid
-                   " ports " ports '.'
+                   " ports " ports '.' :: IO ()
           newClients <- mapM (forkTestClient conf rid published) ports
           let newRunningClients = foldl' (flip Set.insert) (runningClients s)
                                          newClients
           log Info "Exit test clients currently running: "
-                   (Set.size newRunningClients) '.'
+                   (Set.size newRunningClients) '.' :: IO ()
           if Q.length (pendingTests s) == 0
             then do
-              log Info "Pending exit tests: 0."
+              log Info "Pending exit tests: 0." :: IO ()
               loop conf s { runningClients = newRunningClients
                           , testStatus = NoTestsPending }
             else do
@@ -201,7 +201,7 @@ handleMessage
 handleMessage conf s (NewDirInfo routers)
   | nRouterTests == 0 = return (conf, s)
   | otherwise = do
-      log Info "Scheduling exit tests for " nRouterTests " routers."
+      log Info "Scheduling exit tests for " nRouterTests " routers." :: IO ()
       now <- getCurrentTime
       let newS = s { pendingTests = newPendingTests
                    , testHistory = appendTestsToHistory now nRouterTests .
@@ -237,7 +237,7 @@ handleMessage conf s (Reconfigure reconf signal) = do
   return (newConf, s)
 
 handleMessage _ s (Terminate reason) = do
-  log Info "Terminating exit test initiator."
+  log Info "Terminating exit test initiator." :: IO ()
   F.forM_ (runningClients s) $ \client ->
     terminateThread Nothing client (killThread client)
   exit reason
@@ -251,13 +251,13 @@ handleMessage conf s (Exit tid reason)
       routers <- nsRouters `fmap` eticfGetNetworkState conf
       case testsToExecute conf routers (pendingTests s) of
         Nothing -> do
-          log Info "Pending exit tests: 0."
+          log Info "Pending exit tests: 0." :: IO ()
           return (conf, s { pendingTests = Q.empty
                           , testStatus = NoTestsPending })
         Just (rid,ports,published,newPendingTests) -> do
-          log Info "Pending exit tests: " (Q.length newPendingTests + 1) '.'
+          log Info "Pending exit tests: " (Q.length newPendingTests + 1) '.' :: IO ()
           log Debug "Waiting to run exit test for router " rid
-                    " ports " ports '.'
+                    " ports " ports '.' :: IO ()
           return (conf, s { pendingTests = newPendingTests
                           , testStatus = TestWaiting rid ports published })
   -- Periodically, add every eligible router to the exit test queue. This should
@@ -267,7 +267,7 @@ handleMessage conf s (Exit tid reason)
                     =<< eticfGetNetworkState conf
       newTid <- forkPeriodicTestTimer
       return (conf, newS { periodicTestTimer = newTid })
-  | isJust reason = exit reason
+  | isAbnormal reason = exit reason
   | otherwise = return (conf, s)
 
 -- | Notify the exit test initiator of new directory information.
@@ -295,7 +295,7 @@ reconfigureExitTestInitiator reconf (ExitTestInitiator send tid) =
 -- exit signal will be sent.
 terminateExitTestInitiator :: Maybe Int -> ExitTestInitiator -> IO ()
 terminateExitTestInitiator mbWait (ExitTestInitiator send tid) =
-  terminateThread mbWait tid (send $ Terminate Nothing)
+  terminateThread mbWait tid (send $ Terminate NormalExit)
 
 --------------------------------------------------------------------------------
 -- Scheduling exit tests
@@ -362,7 +362,7 @@ forkTestClient
   :: ExitTestInitiatorConfig -> RouterID -> UTCTime -> Port -> IO ThreadId
 forkTestClient conf rid published port =
   forkLinkIO $ do
-    r <- E.tryJust clientExceptions .
+    r <- E.try .
       eticfWithCookie conf rid published port $ \cookie ->
         timeout connectionTimeout .
           E.bracket connectToSocksServer hClose $ \handle ->
@@ -371,15 +371,16 @@ forkTestClient conf rid published port =
               B.hGet handle 1024 -- ignore response
               return ()
     case r of
-      Left e@(E.DynException d) | Just (e' :: SocksError) <- fromDynamic d -> do
-        log Info "Exit test for router " rid " port " port " failed: " e'
+      Left (E.fromException -> Just (e :: SocksError)) -> do
+        log Info "Exit test for router " rid " port " port " failed: " e :: IO ()
         E.throwIO e
-      Left e -> do
+      Left (E.fromException -> Just (e :: E.IOException)) -> do
         log Warn "Exit test for router " rid " port " port " failed : " e
                  ". This might indicate a problem with making application \
                  \connections through Tor. Is Tor running? Is its SocksPort \
-                 \listening on " (eticfSocksServer conf) '?'
+                 \listening on " (eticfSocksServer conf) '?' :: IO ()
         E.throwIO e
+      Left e -> E.throwIO e
       Right Nothing ->
         log Info "Exit test for router " rid " port " port " timed out."
       _ ->
@@ -394,11 +395,6 @@ forkTestClient conf rid published port =
         connect sock (eticfSocksServer conf)
         socketToHandle sock ReadWriteMode
 
-    clientExceptions e@(E.DynException d)
-      | Just (_ :: SocksError) <- fromDynamic d = Just e
-    clientExceptions e@(E.IOException _)        = Just e
-    clientExceptions _                          = Nothing
-
     connectionTimeout = 120 * 10^6
 
 -- | Fork a timer thread for the next exit test, returning its 'ThreadId'.
@@ -406,8 +402,8 @@ forkTestTimer :: InitiatorState -> IO ThreadId
 forkTestTimer s = forkLinkIO $ do
   log Debug "Total routers scheduled in exit test history: "
             (nTotalRouters $ testHistory s) ". "
-            (show . F.toList . historySeq $ testHistory s)
-  log Info "Running next exit test in " currentInterval " microseconds."
+            (show . F.toList . historySeq $ testHistory s) :: IO ()
+  log Info "Running next exit test in " currentInterval " microseconds." :: IO ()
   threadDelay $ fromIntegral currentInterval
   where
     currentInterval = currentTestInterval nPending (testHistory s)
diff --git a/src/TorDNSEL/ExitTest/Server/Internals.hs b/src/TorDNSEL/ExitTest/Server/Internals.hs
index 97d1f8e..0d43db3 100644
--- a/src/TorDNSEL/ExitTest/Server/Internals.hs
+++ b/src/TorDNSEL/ExitTest/Server/Internals.hs
@@ -27,6 +27,7 @@ import qualified Control.Exception as E
 import Control.Monad (when, forM, foldM)
 import Control.Monad.Fix (fix)
 import Control.Monad.Trans (lift)
+import Control.Applicative
 import qualified Data.ByteString.Char8 as B
 import qualified Data.Foldable as F
 import qualified Data.Map as M
@@ -136,7 +137,7 @@ startListenerThread notifyServerNewClient sem owner listener addr =
   forkLinkIO . E.block . finallyCloseSocket . forever $ do
     waitQSemN sem 1
     (client,SockAddrInet _ clientAddr) <- E.unblock (accept listener)
-      `E.catch` \e -> signalQSemN sem 1 >> E.throwIO e
+      `E.catch` \(e :: E.SomeException) -> signalQSemN sem 1 >> E.throwIO e
     let clientAddr' = ntohl clientAddr
     log Debug "Accepted exit test client from " (inet_htoa clientAddr') '.'
     notifyServerNewClient client clientAddr'
@@ -157,9 +158,9 @@ reopenSocketIfClosed addr mbSock = MaybeT $ do
     else do
       whenJust mbSock sClose
       log Notice "Opening exit test listener on " addr '.'
-      r <- E.tryJust E.ioErrors $ bindListeningTCPSocket addr
+      r <- E.try $ bindListeningTCPSocket addr
       case r of
-        Left e -> do
+        Left (e :: E.IOException ) -> do
           log Warn "Opening exit test listener on " addr " failed: " e "; \
                    \skipping listener."
           return Nothing
@@ -169,7 +170,8 @@ reopenSocketIfClosed addr mbSock = MaybeT $ do
   where
     isListeningSocketOpen Nothing = return False
     isListeningSocketOpen (Just sock) =
-      getSocketName sock >> return True `catch` const (return False)
+      (True <$ getSocketName sock)
+        `E.catch` \(_ :: E.SomeException) -> return False
 
 -- | Process a 'ServerMessage' and return the new config and state, given the
 -- current config and state.
@@ -178,7 +180,7 @@ handleMessage :: ExitTestServerConfig -> ServerState -> ServerMessage
 handleMessage conf s (NewClient sock addr) = do
   tid <- forkLinkIO . (`E.finally` signalQSemN (handlerSem s) 1) .
     E.bracket (socketToHandle sock ReadWriteMode) hClose $ \client -> do
-      r <- timeout readTimeout . E.tryJust E.ioErrors $ do
+      r <- timeout readTimeout . E.try $ do
         r <- runMaybeT $ getRequest client
         case r of
           Just cookie -> do
@@ -251,32 +253,34 @@ handleMessage _conf s (Terminate reason) = do
 
 handleMessage conf s (Exit tid reason)
   | tid `S.member` handlers s = do
-      whenJust reason $
-        log Warn "Bug: An exit test client handler exited abnormally: "
-      return (conf, s { handlers = S.delete tid (handlers s) })
-  | tid `S.member` deadListeners s
-  = return (conf, s { deadListeners = S.delete tid (deadListeners s) })
+    case reason of
+        AbnormalExit _ -> log Warn "Bug: An exit test client handler exited abnormally: "
+        NormalExit     -> return ()
+    return (conf, s { handlers = S.delete tid (handlers s) })
+  | tid `S.member` deadListeners s =
+    return (conf, s { deadListeners = S.delete tid (deadListeners s) })
   | Just (Listener addr sock owner) <- tid `M.lookup` listenerThreads s = do
-      log Warn "An exit test listener thread for " addr " exited unexpectedly: "
-               (fromJust reason) "; restarting."
-      mbSock <- runMaybeT $ reopenSocketIfClosed addr (Just sock)
-      case mbSock of
-        -- The socket couldn't be reopened, so drop the listener.
-        Nothing ->
-          return ( conf { etscfListenAddrs =
-                            S.delete addr (etscfListenAddrs conf) }
-                 , s { listenerThreads = M.delete tid (listenerThreads s) } )
-        Just sock' -> do
-          -- If the socket was reopened, we own it now.
-          let owner' | sock /= sock' = ExitTestServerOwned
-                     | otherwise     = owner
-              listener' = Listener addr sock' owner'
-          tid' <- startListenerThread ((writeChan (serverChan s) .) . NewClient)
-                                      (handlerSem s) owner sock addr
-          listener' `seq` return
-            (conf, s { listenerThreads = M.insert tid' listener' .
-                                           M.delete tid $ listenerThreads s })
-  | isJust reason = exit reason
+
+    log Warn "An exit test listener thread for " addr " exited unexpectedly: "
+              reason "; restarting."
+    mbSock <- runMaybeT $ reopenSocketIfClosed addr (Just sock)
+    case mbSock of
+      -- The socket couldn't be reopened, so drop the listener.
+      Nothing ->
+        return ( conf { etscfListenAddrs =
+                          S.delete addr (etscfListenAddrs conf) }
+                , s { listenerThreads = M.delete tid (listenerThreads s) } )
+      Just sock' -> do
+        -- If the socket was reopened, we own it now.
+        let owner' | sock /= sock' = ExitTestServerOwned
+                    | otherwise     = owner
+            listener' = Listener addr sock' owner'
+        tid' <- startListenerThread ((writeChan (serverChan s) .) . NewClient)
+                                    (handlerSem s) owner sock addr
+        listener' `seq` return
+          (conf, s { listenerThreads = M.insert tid' listener' .
+                                       M.delete tid $ listenerThreads s })
+  | isAbnormal reason = exit reason
   | otherwise = return (conf, s)
 
 -- | Reconfigure the exit test server synchronously with the given function. If
@@ -293,4 +297,4 @@ reconfigureExitTestServer reconf (ExitTestServer send tid) =
 -- be sent.
 terminateExitTestServer :: Maybe Int -> ExitTestServer -> IO ()
 terminateExitTestServer mbWait (ExitTestServer send tid) =
-  terminateThread mbWait tid (send $ Terminate Nothing)
+  terminateThread mbWait tid (send $ Terminate NormalExit)
diff --git a/src/TorDNSEL/Log/Internals.hsc b/src/TorDNSEL/Log/Internals.hsc
index 0b26873..6c64f9f 100644
--- a/src/TorDNSEL/Log/Internals.hsc
+++ b/src/TorDNSEL/Log/Internals.hsc
@@ -173,7 +173,7 @@ reconfigureLogger reconf =
 terminateLogger :: Maybe Int -> IO ()
 terminateLogger mbWait =
   withLogger $ \tid logChan ->
-    terminateThread mbWait tid (writeChan logChan $ Terminate Nothing)
+    terminateThread mbWait tid (writeChan logChan $ Terminate NormalExit)
 
 --------------------------------------------------------------------------------
 -- System logger
diff --git a/src/TorDNSEL/Main.hsc b/src/TorDNSEL/Main.hsc
index e612de0..e9a145a 100644
--- a/src/TorDNSEL/Main.hsc
+++ b/src/TorDNSEL/Main.hsc
@@ -197,10 +197,10 @@ main = do
           verifyConfig args
     ["--reconfigure",runtimeDir] -> do
       sock <- connectToReconfigSocket runtimeDir
-        `E.catch` \e -> do
+        `E.catch` \(e :: E.SomeException) -> do
           hCat stderr "Connecting to reconfigure socket failed: " e '\n'
           exitWith $ fromSysExitCode Unavailable
-      r <- E.handleJust E.ioErrors (\e -> do
+      r <- E.handle (\(e :: E.IOException) -> do
              hCat stderr "An I/O error occurred while reconfiguring: " e '\n'
              exitWith $ fromSysExitCode IOError) $
         E.bracket (socketToHandle sock ReadWriteMode) hClose $ \handle -> do
@@ -221,7 +221,7 @@ main = do
     conf <- exitLeft Usage $ parseConfigArgs args
     case B.pack "configfile" `M.lookup` conf of
       Just fp -> do
-        file <- E.catchJust E.ioErrors (B.readFile $ B.unpack fp)
+        file <- catchIO (B.readFile $ B.unpack fp)
           (exitPrint NoInput . cat "Opening config file failed: ")
         exitLeft DataError $ makeConfig . M.union conf =<< parseConfigFile file
       Nothing -> exitLeft Usage $ makeConfig conf
@@ -237,33 +237,33 @@ main = do
         euid /= 0) $
     exitPrint NoPermission ("You must be root to drop privileges or chroot." ++)
 
-  ids <- E.catchJust E.ioErrors
+  ids <- catchIO
     (getIDs (cfUser conf) (cfGroup conf))
     (exitPrint OSFile . cat "Looking up uid/gid failed: ")
 
-  E.catchJust E.ioErrors
+  catchIO
     (checkDirectory (fst ids) (cfChangeRootDirectory conf)
                     (cfStateDirectory conf))
     (exitPrint Can'tCreate . cat "Preparing state directory failed: ")
 
-  E.catchJust E.ioErrors
+  catchIO
     (checkDirectory Nothing Nothing (cfRuntimeDirectory conf))
     (exitPrint Can'tCreate . cat "Preparing runtime directory failed: ")
 
-  statsSock <- E.catchJust E.ioErrors
+  statsSock <- catchIO
     (bindStatsSocket $ cfRuntimeDirectory conf)
     (exitPrint Can'tCreate . cat "Opening statistics listener failed: ")
 
-  reconfigSock <- E.catchJust E.ioErrors
+  reconfigSock <- catchIO
     (bindReconfigSocket (cfRuntimeDirectory conf) (fst ids))
     (exitPrint Can'tCreate . cat "Opening reconfigure listener failed: ")
 
-  pidHandle <- E.catchJust E.ioErrors
+  pidHandle <- catchIO
     (flip openFile WriteMode `liftMb` cfPIDFile conf)
     (exitPrint Can'tCreate . cat "Opening PID file failed: ")
 
   log Notice "Opening DNS listener on " (cfDNSListenAddress conf) '.'
-  dnsSock <- E.catchJust E.ioErrors
+  dnsSock <- catchIO
     (bindUDPSocket $ cfDNSListenAddress conf)
     (\e -> exitPrint (bindErrorCode e) $
              cat "Opening DNS listener on " (cfDNSListenAddress conf)
@@ -276,7 +276,7 @@ main = do
         let sockAddr = SockAddrInet (fromIntegral port)
                                    (htonl . fst $ tcfTestListenAddress testConf)
         log Notice "Opening exit test listener on " sockAddr '.'
-        sock <- E.catchJust E.ioErrors
+        sock <- catchIO
          (bindListeningTCPSocket sockAddr)
          (\e -> exitPrint (bindErrorCode e) $
                   cat "Opening exit test listener on " sockAddr " failed: " e)
@@ -285,7 +285,7 @@ main = do
   -- We lose any other running threads when we 'forkProcess', so don't 'forkIO'
   -- before this point.
   (if cfRunAsDaemon conf then daemonize else id) .
-    withLinksDo (showException [showLinkException]) $ do
+    withLinksDo $ do
 
     whenJust pidHandle $ \handle -> do
       hPutStrLn handle . show =<< getProcessID
@@ -311,7 +311,7 @@ verifyConfig args =
     Right conf ->
       case B.pack "configfile" `M.lookup` conf of
         Just fp -> do
-          file <- E.catchJust E.ioErrors (B.readFile $ B.unpack fp) $ \e -> do
+          file <- catchIO (B.readFile $ B.unpack fp) $ \e -> do
             hCat stderr "Opening config file failed: " e '\n'
             exitWith $ fromSysExitCode NoInput
           check DataError $ parseConfigFile file >>= makeConfig . M.union conf
@@ -334,10 +334,13 @@ runMainThread static initTestListeners initDNSListener initConf = do
   installHandler sigHUP (Catch hupHandler) Nothing
   installHandler sigINT (Catch $ termHandler sigINT) Nothing
 
-  initState <- E.handle (\e -> do log Error "Starting failed: " e
-                                  terminateLogger Nothing
-                                  closeSystemLogger
-                                  exitWith $ fromSysExitCode ConfigError) $ do
+  initState <-
+    E.handle (\(e :: E.SomeException) -> do
+      log Error "Starting failed: " e
+      terminateLogger Nothing
+      closeSystemLogger
+      exitWith $ fromSysExitCode ConfigError) $ do
+
     initLogger <- initializeLogger initConf
     whenJust (cfChangeRootDirectory initConf) $ \dir ->
       log Notice "Chrooted in " (esc 256 $ B.pack dir) '.'
@@ -347,12 +350,11 @@ runMainThread static initTestListeners initDNSListener initConf = do
     initReconfig <- startReconfigServer (reconfigSocket static)
                       (((writeChan mainChan . Reconfigure) .) . curry Just)
     let cleanup = terminateReconfigServer Nothing initReconfig
-    stats <- startStatsServer (statsSocket static)
-      `E.catch` \e -> cleanup >> E.throwIO e
+    stats <- startStatsServer (statsSocket static) `E.onException` cleanup
     let cleanup' = cleanup >> terminateStatsServer Nothing stats
     netState <- initializeNetworkStateManager
                   (mkExitTestConfig static initTestListeners initConf) initConf
-      `E.catch` \e -> cleanup' >> E.throwIO e
+      `E.onException` cleanup'
     dns <- startDNSServer (mkDNSServerConfig initDNSListener initConf)
     return $ State (Just initLogger) (Just initReconfig) (Just stats) netState
                    dns initTestListeners initDNSListener S.empty
@@ -374,9 +376,9 @@ handleMessage _ static conf s (Reconfigure reconf) = flip runStateT s $ do
     Nothing
       | Just configFile <- cfConfigFile conf -> do
           log Notice "Caught SIGHUP. Reloading config file."
-          r <- liftIO . E.tryJust E.ioErrors $ B.readFile configFile
+          r <- liftIO . E.try $ B.readFile configFile
           case r of
-            Left e -> do
+            Left (e :: E.IOException) -> do
               -- If we're chrooted, it's not suprising that we can't read our
               -- config file.
               when (isNothing $ cfChangeRootDirectory conf) $
@@ -412,7 +414,7 @@ handleMessage _ static conf s (Reconfigure reconf) = flip runStateT s $ do
 
       when (cfStateDirectory conf /= cfStateDirectory newConf') $
         liftIO $ checkDirectory Nothing Nothing (cfStateDirectory newConf')
-          `E.catch` \e -> do
+          `catchIO` \e -> do
             errorRespond $ cat "Preparing new state directory failed: " e
                                "; exiting gracefully."
             terminateProcess Can'tCreate static s Nothing
@@ -442,30 +444,30 @@ handleMessage mainChan static conf s (Exit tid reason)
         Left _ -> return Nothing
         Right newLogger -> do
           log Warn "The logger thread exited unexpectedly: "
-                   (showExitReason [] reason) "; restarted."
+                   (show reason) "; restarted."
           return $ Just newLogger
       return (conf, s { logger = mbNewLogger
                       , deadThreads = S.insert dead (deadThreads s) })
   | deadThreadIs reconfigServer = do
       log Warn "The reconfigure server thread exited unexpectedly: "
-               (showExitReason [] reason) "; restarting."
+               (show reason) "; restarting."
       (r,dead) <- tryForkLinkIO $ startReconfigServer (reconfigSocket static)
                            (((writeChan mainChan . Reconfigure) .) . curry Just)
       mbNewReconfigServer <- case r of
         Left e -> do
           log Warn "Restarting reconfigure server failed: "
-                   (showExitReason [] e) "; disabling reconfigure server."
+                   (show e) "; disabling reconfigure server."
           return Nothing
         Right newReconfigServer -> return $ Just newReconfigServer
       return (conf, s { reconfigServer = mbNewReconfigServer
                       , deadThreads = S.insert dead (deadThreads s) })
   | deadThreadIs statsServer = do
       log Warn "The statistics server thread exited unexpectedly: "
-               (showExitReason [] reason) "; restarting."
+               (show reason) "; restarting."
       (r,dead) <- tryForkLinkIO . startStatsServer $ statsSocket static
       mbNewStatsServer <- case r of
         Left e -> do
-          log Warn "Restarting statistics server failed: " (showExitReason [] e)
+          log Warn "Restarting statistics server failed: " (show e)
                    "; disabling statistics server."
           return Nothing
         Right newStatsServer -> return $ Just newStatsServer
@@ -473,24 +475,24 @@ handleMessage mainChan static conf s (Exit tid reason)
                       , deadThreads = S.insert dead (deadThreads s) })
   | tid == threadId (networkStateManager s) = do
       log Warn "The network state manager thread exited unexpectedly: "
-               (showExitReason [] reason) "; restarting."
+               (show reason) "; restarting."
       newManager <- initializeNetworkStateManager
                       (mkExitTestConfig static (exitTestListeners s) conf) conf
-        `E.catch` \e -> do
+        `E.catch` \(e :: E.SomeException) -> do
           log Error "Restarting network state manager failed: " e
                     "; exiting gracefully."
           terminateProcess Internal static s Nothing
       return (conf, s { networkStateManager = newManager })
   | tid == threadId (dnsServer s) = do
       log Warn "The DNS server thread exited unexpectedly: "
-               (showExitReason [] reason) "; restarting."
+               (show reason) "; restarting."
       newDNSServer <- startDNSServer $ mkDNSServerConfig (dnsListener s) conf
       return (conf, s { dnsServer = newDNSServer })
   | tid `S.member` deadThreads s
   = return (conf, s { deadThreads = S.delete tid (deadThreads s) })
   | otherwise = do
       log Warn "Bug: Received unexpected exit signal: "
-               (showExitReason [] reason)
+               (show reason)
       return (conf, s)
   where deadThreadIs thr = ((tid ==) . threadId) `fmap` thr s == Just True
 
@@ -615,10 +617,9 @@ reconfigureDNSListenerAndServer
 reconfigureDNSListenerAndServer static oldConf newConf errorRespond = do
   when (cfDNSListenAddress oldConf /= cfDNSListenAddress newConf) $ do
     log Notice "Opening DNS listener on " (cfDNSListenAddress newConf) '.'
-    r <- liftIO . E.tryJust E.ioErrors $
-           bindUDPSocket $ cfDNSListenAddress newConf
+    r <- liftIO . E.try $ bindUDPSocket $ cfDNSListenAddress newConf
     case r of
-      Left e -> do
+      Left (e :: E.IOException) -> do
         errorRespond $
           cat "Opening DNS listener on " (cfDNSListenAddress newConf)
               " failed: " e "; exiting gracefully."
@@ -649,18 +650,20 @@ terminateProcess status static s mbWait = do
   forM_ (M.assocs $ exitTestListeners s) $ \(addr,mbSock) ->
     whenJust mbSock $ \sock -> do
       log Info "Closing exit test listener on " addr '.'
-      ignoreJust E.ioErrors $ sClose sock
+      ignoreIOExn $ sClose sock
   log Info "Closing DNS listener."
-  ignoreJust E.ioErrors . sClose $ dnsListener s
+  ignoreIOExn . sClose $ dnsListener s
   log Info "Closing statistics listener."
-  ignoreJust E.ioErrors . sClose $ statsSocket static
+  ignoreIOExn . sClose $ statsSocket static
   log Info "Closing reconfigure listener."
-  ignoreJust E.ioErrors . sClose $ reconfigSocket static
-  ignoreJust E.ioErrors . hClose $ randomHandle static
+  ignoreIOExn . sClose $ reconfigSocket static
+  ignoreIOExn . hClose $ randomHandle static
   log Notice "All subsystems have terminated. Exiting now."
   terminateLogger mbWait
   closeSystemLogger
   exitWith $ fromSysExitCode status
+  where
+    ignoreIOExn = (`catchIO` \_ -> return ())
 
 --------------------------------------------------------------------------------
 -- Daemon operations
@@ -732,7 +735,7 @@ setMaxOpenFiles lowerLimit cap = do
       unResourceLimit (ResourceLimit n) = n
       unResourceLimit _ = error "unResourceLimit: bug"
 
-  fmap unResourceLimit $ E.catchJust E.ioErrors
+  fmap unResourceLimit $ catchIO
     (setResourceLimit ResourceOpenFiles (newLimits most) >> return most) $ \e ->
     do
 #ifdef OPEN_MAX
@@ -743,7 +746,7 @@ setMaxOpenFiles lowerLimit cap = do
                 return openMax
         else E.throwIO (E.IOException e)
 #else
-      E.throwIO (E.IOException e)
+      E.throwIO e
 #endif
 
 instance Ord ResourceLimit where
@@ -777,10 +780,8 @@ checkDirectory uid newRoot path = do
 -- return 'ToStdOut'.
 checkLogTarget :: LogTarget -> IO LogTarget
 checkLogTarget target@(ToFile logPath) =
-  E.catchJust E.ioErrors
-    (do E.bracket (openFile logPath AppendMode) hClose (const $ return ())
-        return target)
-    (const $ return ToStdOut)
+  E.bracket (openFile logPath AppendMode) hClose (\_ -> return target)
+    `catchIO` (\_ -> return ToStdOut)
 checkLogTarget target = return target
 
 -- | System exit status codes from sysexits.h.
@@ -845,5 +846,9 @@ liftMb f = maybe (return Nothing) (liftM Just . f)
 
 infixr 8 `liftMb`
 
+-- | Specialization of 'E.catch' for 'E.IOException'.
+catchIO :: IO a -> (E.IOException -> IO a) -> IO a
+catchIO = E.catch
+
 foreign import ccall unsafe "unistd.h chroot"
   c_chroot :: CString -> IO CInt
diff --git a/src/TorDNSEL/NetworkState/Internals.hs b/src/TorDNSEL/NetworkState/Internals.hs
index cb3ae46..c4c6b4d 100644
--- a/src/TorDNSEL/NetworkState/Internals.hs
+++ b/src/TorDNSEL/NetworkState/Internals.hs
@@ -187,7 +187,7 @@ startNetworkStateManager initConf = do
       Just testConf | Right conn <- controller ->
         execStateT (initializeExitTests net (nsmcfStateDir initConf) testConf)
                    emptyState
-          `E.catch` \e -> closeConnection conn >> E.throwIO e
+          `E.onException` closeConnection conn
       _ -> return emptyState
     swapMVar networkStateMV $! networkState initState
     signal
@@ -213,7 +213,7 @@ reconfigureNetworkStateManager reconf (NetworkStateManager send tid) =
 -- exit signal will be sent.
 terminateNetworkStateManager :: Maybe Int -> NetworkStateManager -> IO ()
 terminateNetworkStateManager mbWait (NetworkStateManager send tid) =
-  terminateThread mbWait tid (send $ Terminate Nothing)
+  terminateThread mbWait tid (send $ Terminate NormalExit)
 
 -- | Process a 'ManagerMessage' and return the new config and state, given the
 -- current config and state.
@@ -361,7 +361,7 @@ handleMessage net conf (Exit tid reason) = get >>= handleExit where
         return conf
     | Right conn <- torControlConn s, tid == threadId conn = do
         log Warn "The Tor controller thread exited unexpectedly: "
-                 (showExitReason [showTorControlError] reason) "; restarting."
+                 (show reason) "; restarting."
         (controller,deadTid) <- startTorController net conf Nothing
         put $! s { torControlConn = controller
                  , deadThreads = S.insert deadTid (deadThreads s) }
@@ -378,7 +378,7 @@ handleMessage net conf (Exit tid reason) = get >>= handleExit where
         Just (testConf,testState)
           | tid == toTid storageManager -> do
               log Warn "The storage manager thread exited unexpectedly: "
-                      (showExitReason [] reason) "; restarting."
+                      (show reason) "; restarting."
               storage <- liftIO . startStorageManager . StorageConfig $
                            nsmcfStateDir conf
               liftIO $ rebuildExitAddressStorage (nsRouters $ networkState s)
@@ -387,7 +387,7 @@ handleMessage net conf (Exit tid reason) = get >>= handleExit where
               return conf
           | tid == toTid exitTestServer -> do
               log Warn "The exit test server thread exited unexpectedly: "
-                       (showExitReason [] reason) "; restarting."
+                       (show reason) "; restarting."
               server <- liftIO $ startExitTestServer
                                    (M.assocs $ etcfListeners testConf)
                                    (initExitTestServerConfig net testConf)
@@ -395,7 +395,7 @@ handleMessage net conf (Exit tid reason) = get >>= handleExit where
               return conf
           | tid == toTid exitTestInitiator -> do
               log Warn "The exit test initiator thread exited unexpectedly: "
-                       (showExitReason [] reason) "; restarting."
+                       (show reason) "; restarting."
               initiator <- liftIO $ startExitTestInitiator
                                       (initExitTestInitiatorConfig net testConf)
               putTestState testState { exitTestInitiator = initiator }
@@ -403,7 +403,7 @@ handleMessage net conf (Exit tid reason) = get >>= handleExit where
           where
             toTid f = threadId $ f testState
             putTestState x = put $! s { exitTestState = Just $! x}
-        _ | isJust reason -> liftIO $ exit reason
+        _ | isAbnormal reason -> liftIO $ exit reason
           | otherwise -> return conf
 
 -- | Register a mapping from cookie to router identifier, descriptor published
@@ -448,9 +448,9 @@ startTorController
 startTorController net conf mbDelay = liftIO $ do
   log Info "Starting Tor controller."
   (r,tid) <- tryForkLinkIO $ do
-    E.bracketOnError' (socket AF_INET Stream tcpProtoNum) sClose $ \sock -> do
+    bracketOnError' (socket AF_INET Stream tcpProtoNum) sClose $ \sock -> do
       connect sock $ nsmcfTorControlAddr conf
-      E.bracketOnError'
+      bracketOnError'
         ( socketToHandle sock ReadWriteMode >>=
             (`openConnection` nsmcfTorControlPasswd conf) )
         closeConnection $ \conn -> do
@@ -473,7 +473,7 @@ startTorController net conf mbDelay = liftIO $ do
   case r of
     Left reason -> do
       log Warn "Initializing Tor controller connection failed: "
-                (showExitReason [showTorControlError] reason)
+                (show reason)
                 "; I'll try again in " delay " seconds."
       timerTid <- forkLinkIO $ threadDelay (delay * 10^6)
       return (Left (timerTid, nextDelay), tid)
@@ -481,8 +481,12 @@ startTorController net conf mbDelay = liftIO $ do
       log Info "Successfully initialized Tor controller connection."
       return (Right conn, tid)
   where
+    logTorControlErrors :: (CatArg a) => String -> [a] -> IO ()
     logTorControlErrors event = mapM_ (log Warn "Error in " event " event: ")
+
+    logParseErrors :: (CatArg b) => ([a], [b]) -> IO [a]
     logParseErrors (xs,errors) = mapM_ (log Warn) errors >> return xs
+
     updateDescriptors (NetworkStateManager send _) = send . NewDescriptors
     updateNetworkStatus (NetworkStateManager send _) = send . NewNetworkStatus
     nextDelay | delay' < maxDelay = delay'
diff --git a/src/TorDNSEL/NetworkState/Storage/Internals.hs b/src/TorDNSEL/NetworkState/Storage/Internals.hs
index 0f79cf8..532ae2d 100644
--- a/src/TorDNSEL/NetworkState/Storage/Internals.hs
+++ b/src/TorDNSEL/NetworkState/Storage/Internals.hs
@@ -137,9 +137,9 @@ startStorageManager initConf = do
       return (s { exitAddrLen = addrLen, journalLen = 0 }, nullSignal)
 
     getFileSize fp =
-      E.catchJust E.ioErrors
+      E.catch
         ((fromIntegral . fileSize) `fmap` getFileStatus fp)
-        (\e -> if isDoesNotExistError e then return 0 else ioError e)
+        (\e -> if isDoesNotExistError e then return 0 else E.throwIO e)
 
     nullSignal = return ()
 
@@ -179,7 +179,7 @@ reconfigureStorageManager reconf (StorageManager tellStorageManager tid)
 -- be sent.
 terminateStorageManager :: Maybe Int -> StorageManager -> IO ()
 terminateStorageManager mbWait (StorageManager tellStorageManager tid) =
-  terminateThread mbWait tid (tellStorageManager $ Terminate Nothing)
+  terminateThread mbWait tid (tellStorageManager $ Terminate NormalExit)
 
 -- | An exit address entry stored in our state directory. The design here is the
 -- same as Tor uses for storing router descriptors.
@@ -241,9 +241,9 @@ readExitAddresses stateDir =
     merge new old = new { eaAddresses = (M.union `on` eaAddresses) new old }
     parseFile fp = do
       let path = stateDir ++ fp
-      file <- E.catchJust E.ioErrors
+      file <- E.catch
         (B.readFile path)
-        (\e -> if isDoesNotExistError e then return B.empty else ioError e)
+        (\e -> if isDoesNotExistError e then return B.empty else E.throwIO e)
       addrs <- forM (parseSubDocs (B.pack "ExitNode") parseExitAddress .
                        parseDocument . B.lines $ file) $ \exitAddr -> do
         case exitAddr of
diff --git a/src/TorDNSEL/Socks.hs b/src/TorDNSEL/Socks.hs
index f3d18f7..56de807 100644
--- a/src/TorDNSEL/Socks.hs
+++ b/src/TorDNSEL/Socks.hs
@@ -21,7 +21,6 @@ module TorDNSEL.Socks (
 
   -- * Errors
   , SocksError(..)
-  , showSocksError
   ) where
 
 import TorDNSEL.Socks.Internals
diff --git a/src/TorDNSEL/Socks/Internals.hs b/src/TorDNSEL/Socks/Internals.hs
index 7999b91..9f94b45 100644
--- a/src/TorDNSEL/Socks/Internals.hs
+++ b/src/TorDNSEL/Socks/Internals.hs
@@ -36,7 +36,6 @@ module TorDNSEL.Socks.Internals (
 
   -- * Errors
   , SocksError(..)
-  , showSocksError
   ) where
 
 import qualified Control.Exception as E
@@ -69,8 +68,8 @@ withSocksConnection handle addr port io = (`E.finally` hClose handle) $ do
   r <- decodeResponse =<< B.hGet handle 8
   case r of
     Just (Response Granted _ _) -> io
-    Just (Response result _ _)  -> E.throwDyn (SocksError result)
-    _                           -> E.throwDyn SocksProtocolError
+    Just (Response result _ _)  -> E.throwIO (SocksError result)
+    _                           -> E.throwIO SocksProtocolError
 
 --------------------------------------------------------------------------------
 -- Data types
@@ -176,6 +175,4 @@ instance Show SocksError where
   showsPrec _ (SocksError result) = cat "Socks error: " result
   showsPrec _ SocksProtocolError  = cat "Socks protocol error"
 
--- | Boilerplate conversion of a dynamically typed 'SocksError' to a string.
-showSocksError :: Dynamic -> Maybe String
-showSocksError = fmap (show :: SocksError -> String) . fromDynamic
+instance E.Exception SocksError
diff --git a/src/TorDNSEL/Statistics/Internals.hs b/src/TorDNSEL/Statistics/Internals.hs
index bb390eb..3932156 100644
--- a/src/TorDNSEL/Statistics/Internals.hs
+++ b/src/TorDNSEL/Statistics/Internals.hs
@@ -23,6 +23,7 @@ import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
 import Control.Concurrent.MVar (MVar, newMVar, modifyMVar_, readMVar)
 import Control.Concurrent.QSem (QSem, newQSem, waitQSem, signalQSem)
 import qualified Control.Exception as E
+import Control.Monad (when)
 import Control.Monad.Fix (fix)
 import qualified Data.ByteString.Char8 as B
 import Data.Maybe (isJust, isNothing)
@@ -107,19 +108,19 @@ startStatsServer listenSock = do
               if isNothing $ terminateReason s
                 then do
                   log Warn "The statistics listener thread exited unexpectedly:\
-                           \ " (showExitReason [] reason) "; restarting."
+                           \ " (show reason) "; restarting."
                   newListenerTid <- forkListener statsChan listenSock handlerQSem
                   loop s { listenerTid = newListenerTid }
                 else loop s
           | tid `S.member` handlers s -> do
-              whenJust reason $
+              when (isAbnormal reason) $
                 log Warn "Bug: A statistics client handler exited abnormally: "
               let newHandlers = S.delete tid (handlers s)
               case terminateReason s of
                 -- all the handlers have finished, so let's exit
                 Just exitReason | S.null newHandlers -> exit exitReason
                 _ -> loop s { handlers = newHandlers }
-          | isJust reason -> exit reason
+          | isAbnormal reason -> exit reason
           | otherwise -> loop s
 
   return $ StatsServer (writeChan statsChan) statsServerTid
@@ -133,7 +134,7 @@ forkListener statsChan listenSock sem =
   forkLinkIO . E.block . forever $ do
     waitQSem sem
     (client,_) <- E.unblock $ accept listenSock
-      `E.catch` \e -> signalQSem sem >> E.throwIO e
+      `E.onException` signalQSem sem
     writeChan statsChan $ NewClient client
 
 -- | Terminate the stats server gracefully. The optional parameter specifies the
@@ -142,7 +143,7 @@ forkListener statsChan listenSock sem =
 -- sent.
 terminateStatsServer :: Maybe Int -> StatsServer -> IO ()
 terminateStatsServer mbWait (StatsServer tellStatsServer statsServerTid) =
-  terminateThread mbWait statsServerTid (tellStatsServer $ Terminate Nothing)
+  terminateThread mbWait statsServerTid (tellStatsServer $ Terminate NormalExit)
 
 -- | Render 'Stats' to text as a sequence of CRLF-terminated lines.
 renderStats :: Stats -> B.ByteString
diff --git a/src/TorDNSEL/TorControl.hs b/src/TorDNSEL/TorControl.hs
index 3c42d12..872b938 100644
--- a/src/TorDNSEL/TorControl.hs
+++ b/src/TorDNSEL/TorControl.hs
@@ -79,7 +79,6 @@ module TorDNSEL.TorControl (
   -- * Errors
   , ReplyCode
   , TorControlError(..)
-  , showTorControlError
   ) where
 
 import TorDNSEL.TorControl.Internals
diff --git a/src/TorDNSEL/TorControl/Internals.hs b/src/TorDNSEL/TorControl/Internals.hs
index 7c0e972..39bb21f 100644
--- a/src/TorDNSEL/TorControl/Internals.hs
+++ b/src/TorDNSEL/TorControl/Internals.hs
@@ -126,7 +126,6 @@ module TorDNSEL.TorControl.Internals (
   , protocolError
   , parseError
   , TorControlError(..)
-  , showTorControlError
   , toTCError
   , parseReplyCode
   , throwIfNotPositive
@@ -162,7 +161,6 @@ import TorDNSEL.Control.Concurrent.Util
 import TorDNSEL.Directory
 import TorDNSEL.Document
 import TorDNSEL.Util
-improt qualified TorDNSEL.Util ( bracket', finally' )
 
 --------------------------------------------------------------------------------
 -- Connections
@@ -341,7 +339,7 @@ getDocument key parse conn = do
     Reply ('2','5','0') text doc
       | text == B.snoc key '=' -> return (parse $ parseDocument doc, command)
       | otherwise -> protocolError command $ cat "Got " (esc maxRepLen text) '.'
-    _             -> E.throwDyn $ toTCError command reply
+    _             -> E.throwIO $ toTCError command reply
   where command = Command (B.pack "getinfo") [key] []
         maxRepLen = 64
 
@@ -372,7 +370,7 @@ getStatus key parse conn = do
                                                       (esc maxRepLen text) '.'
       | null dataLines -> check (:[]) (parse $ B.drop (B.length key + 1) text)
       | otherwise      -> check id $ mapM parse dataLines
-    _                  -> E.throwDyn $ toTCError command reply
+    _                  -> E.throwIO $ toTCError command reply
   where command = Command (B.pack "getinfo") [key] []
         check f = either (parseError command) (return . f)
         maxRepLen = 64
@@ -405,7 +403,7 @@ extendCircuit' circuit path purpose conn = do
       | msg:cid':_ <- B.split ' ' text, msg == B.pack "EXTENDED"
       , maybe True (== CircId cid') circuit -> return $ CircId (B.copy cid')
       | otherwise -> protocolError command $ cat "Got " (esc maxRepLen text) '.'
-    _             -> E.throwDyn $ toTCError command reply
+    _             -> E.throwIO $ toTCError command reply
   where
     command = Command (B.pack "extendcircuit") args []
     args = add purpose [cid, B.intercalate (B.pack ",") $ map encodeBase16RouterID path]
@@ -523,11 +521,11 @@ sendCommand' command isQuit mbEvHandlers (tellIOManager,ioManagerTid) = do
     tellIOManager $ SendCommand command isQuit mbEvHandlers (putResponse.Right)
     response <- takeMVar mv
     case response of
-      Left Nothing                                -> E.throwDyn ConnectionClosed
-      Left (Just (E.DynException d))
-        | Just NonexistentThread <- fromDynamic d -> E.throwDyn ConnectionClosed
-      Left (Just e)                               -> E.throwIO e
-      Right replies                               -> return replies
+      Left NormalExit                               -> E.throwIO ConnectionClosed
+      Left (AbnormalExit (E.fromException -> Just NonexistentThread))
+                                                    -> E.throwIO ConnectionClosed
+      Left (AbnormalExit e)                         -> E.throwIO e
+      Right replies                                 -> return replies
 
 --------------------------------------------------------------------------------
 -- Config variables
@@ -637,7 +635,7 @@ boolVar var = ConfVar getc (setc setConf') (setc resetConf') where
             (esc maxVarLen key) ", expecting \"" var "\"."
         | otherwise                -> return val'
   setc f val = f [(var, fmap encodeConfVal val)]
-  psErr = E.throwDyn . ParseError
+  psErr = E.throwIO . ParseError
   maxVarLen = 64
 
 --------------------------------------------------------------------------------
@@ -664,7 +662,7 @@ newDescriptorsEvent ::
 newDescriptorsEvent handler conn = EventHandler (B.pack "NEWDESC") handleNewDesc
   where
     safeGetDescriptor rid = Right `fmap` getDescriptor rid conn
-      `E.catchDyn` \(e :: TorControlError) -> return (Left e)
+      `E.catch` \(e :: TorControlError) -> return (Left e)
     handleNewDesc (Reply _ text _:_) = do
       -- pipeline descriptor requests
       (es',ds) <- fmap partitionEither . mapM resolve
@@ -761,15 +759,20 @@ startIOManager handle = do
     runIOManager $ \loop s -> do
       message <- readChan ioChan
       case message of
-        Exit tid reason
+        Exit tid _
           | tid == evHandlerTid s -> do
               newEvHandlerTid <- startEventHandler eventChan
               loop s { evHandlerTid = newEvHandlerTid }
-          | isNothing reason -> loop s
+
+        Exit _ NormalExit         -> loop s
+
+        Exit tid (AbnormalExit (E.fromException -> Just e))
           | tid == socketReaderTid
-          , Just (E.IOException e) <- reason, isEOFError e
-          , quitSent s, S.null (responds s) -> kill $ evHandlerTid s
-          | otherwise -> exit reason
+          , isEOFError e
+          , quitSent s
+          , S.null (responds s)   -> kill $ evHandlerTid s
+
+        Exit _ reason             -> exit reason
 
         CloseConnection -> mapM_ kill [socketReaderTid, evHandlerTid s]
 
@@ -806,8 +809,8 @@ startIOManager handle = do
               | otherwise           -> loop
             Right event             -> event >> loop
 
-    kill tid = terminateThread Nothing tid . throwTo tid . Just $
-                 E.AsyncException E.ThreadKilled
+    kill tid = terminateThread Nothing tid . throwTo tid $
+                exitReason E.ThreadKilled
 
     renderCommand (Command key args []) =
       B.intercalate (B.pack " ") (key : args) `B.append` B.pack "\r\n"
@@ -838,7 +841,7 @@ startSocketReader handle sendRepliesToIOManager =
         LastReply reply -> return [reply]
 
     parseReplyLine line =
-      either (E.throwDyn . ProtocolError) (parseReplyLine' typ text)
+      either (E.throwIO . ProtocolError) (parseReplyLine' typ text)
              (parseReplyCode code)
       where (code,(typ,text)) = B.splitAt 1 `second` B.splitAt 3 line
 
@@ -846,7 +849,7 @@ startSocketReader handle sendRepliesToIOManager =
       | typ == B.pack "-" = return . MidReply $ Reply code text []
       | typ == B.pack "+" = (MidReply . Reply code text) `fmap` readData
       | typ == B.pack " " = return . LastReply $ Reply code text []
-      | otherwise = E.throwDyn . ProtocolError $
+      | otherwise = E.throwIO . ProtocolError $
                       cat "Malformed reply line type " (esc 1 typ) '.'
 
     readData = do
@@ -1117,10 +1120,7 @@ instance Show TorControlError where
   showsPrec _ (ProtocolError msg) = cat "Protocol error: " msg
   showsPrec _ ConnectionClosed = ("Connection is already closed" ++)
 
--- | Boilerplate conversion of a dynamically typed 'TorControlError' to a
--- string.
-showTorControlError :: Dynamic -> Maybe String
-showTorControlError = fmap (show :: TorControlError -> String) . fromDynamic
+instance E.Exception TorControlError
 
 -- | Given a command, return a \"command failed\" message.
 commandFailed :: Command -> ShowS
@@ -1129,11 +1129,11 @@ commandFailed (Command key args _) =
 
 -- | Throw a 'ProtocolError' given a command and error message.
 protocolError :: Command -> ShowS -> IO a
-protocolError command = E.throwDyn . ProtocolError . cat (commandFailed command)
+protocolError command = E.throwIO . ProtocolError . cat (commandFailed command)
 
 -- | Throw a 'ParseError' given a command and an error message.
 parseError :: Command -> ShowS -> IO a
-parseError command = E.throwDyn . ParseError . cat (commandFailed command)
+parseError command = E.throwIO . ParseError . cat (commandFailed command)
 
 -- | Convert a command and negative reply to a 'TorControlError'.
 toTCError :: Command -> Reply -> TorControlError
@@ -1150,7 +1150,7 @@ parseReplyCode bs
 throwIfNotPositive :: Command -> Reply -> IO ()
 throwIfNotPositive command reply =
   unless (isPositive $ repCode reply) $
-    E.throwDyn $ toTCError command reply
+    E.throwIO $ toTCError command reply
 
 -- | Is a reply successful?
 isPositive :: ReplyCode -> Bool
diff --git a/src/TorDNSEL/Util.hsc b/src/TorDNSEL/Util.hsc
index 4329e68..1cf59b2 100644
--- a/src/TorDNSEL/Util.hsc
+++ b/src/TorDNSEL/Util.hsc
@@ -49,7 +49,6 @@ module TorDNSEL.Util (
   , inet_htoa
   , encodeBase16
   , split
-  , ignoreJust
   , syncExceptions
   , bracket'
   , finally'
@@ -365,10 +364,6 @@ onException' :: IO a -> IO b -> IO a
 onException' io act = io `E.catch` \e ->
   trySync act >> E.throwIO (e :: E.SomeException)
 
--- | Catch and discard exceptions matching the predicate.
-ignoreJust :: (E.Exception e) => (e -> Maybe a) -> IO () -> IO ()
-ignoreJust p = E.handleJust p . const . return $ ()
-
 -- | A predicate matching synchronous exceptions.
 -- XXX This is a bad idea. The exn itself conveys no info on how it was thrown.
 syncExceptions :: E.SomeException -> Maybe E.SomeException
@@ -525,13 +520,6 @@ splitByDelimiter delimiter bs = subst (-len : B.findSubstrings delimiter bs)
     subst []           = error "splitByDelimiter: empty list"
     len = B.length delimiter
 
--- | Convert an exception to a string given a list of functions for displaying
--- dynamically typed exceptions.
--- showException :: [Dynamic -> Maybe String] -> E.Exception -> String
--- showException fs (E.DynException dyn)
---   | str:_ <- mapMaybe ($ dyn) fs = str
--- showException _ e                = show e
-
 -- | Convert a 'UTCTime' to a string in ISO 8601 format.
 showUTCTime :: UTCTime -> String
 showUTCTime time = printf "%s %02d:%02d:%s" date hours mins secStr'





More information about the tor-commits mailing list