commit be92ae00b21041ff9033d8e2a83dd8610f8dc2d2 Author: David Kaloper david@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'