commit be92ae00b21041ff9033d8e2a83dd8610f8dc2d2
Author: David Kaloper <david(a)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(a)(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(a)(E.DynException d)
- | Just (_ :: SocksError) <- fromDynamic d = Just e
- clientExceptions e(a)(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'
