commit a52e0fe72ae2f9a9f4c0ce0ec7b8092c5ad15d40 Author: David Kaloper david@numm.org Date: Wed Aug 21 02:55:54 2013 +0200
start centralizing sync/async exn classification
For now, isolate the code that tries to catch-all-exceptions-except-asynchronous-ones into common combinators, to have it in one place.
The problem with this idea is that mere classification of exceptions is not an indicator of how they were thrown, therefore such logic is not entirely correct. Code that relies on that should move to expecting specific exception types instead. See, for example, http://www.haskell.org/pipermail/haskell-cafe/2013-July/107694.html.
Still, a workable band-aid to make it compile. --- src/TorDNSEL/NetworkState/Internals.hs | 11 +++--- src/TorDNSEL/TorControl/Internals.hs | 37 ++++++++---------- src/TorDNSEL/Util.hsc | 68 +++++++++++++++++++++++++++++----- 3 files changed, 79 insertions(+), 37 deletions(-)
diff --git a/src/TorDNSEL/NetworkState/Internals.hs b/src/TorDNSEL/NetworkState/Internals.hs index c42cae7..cb3ae46 100644 --- a/src/TorDNSEL/NetworkState/Internals.hs +++ b/src/TorDNSEL/NetworkState/Internals.hs @@ -448,13 +448,12 @@ startTorController startTorController net conf mbDelay = liftIO $ do log Info "Starting Tor controller." (r,tid) <- tryForkLinkIO $ do - E.bracketOnError (socket AF_INET Stream tcpProtoNum) - (ignoreJust syncExceptions . sClose) $ \sock -> do + E.bracketOnError' (socket AF_INET Stream tcpProtoNum) sClose $ \sock -> do connect sock $ nsmcfTorControlAddr conf - E.bracketOnError - (do handle <- socketToHandle sock ReadWriteMode - openConnection handle $ nsmcfTorControlPasswd conf) - (ignoreJust syncExceptions . closeConnection) $ \conn -> do + E.bracketOnError' + ( socketToHandle sock ReadWriteMode >>= + (`openConnection` nsmcfTorControlPasswd conf) ) + closeConnection $ \conn -> do setConfWithRollback fetchUselessDescriptors (Just True) conn when (torVersion (protocolInfo conn) >= TorVersion 0 2 0 13 B.empty) $ setConfWithRollback fetchDirInfoEarly (Just True) conn diff --git a/src/TorDNSEL/TorControl/Internals.hs b/src/TorDNSEL/TorControl/Internals.hs index 95fbbd0..7c0e972 100644 --- a/src/TorDNSEL/TorControl/Internals.hs +++ b/src/TorDNSEL/TorControl/Internals.hs @@ -162,6 +162,7 @@ import TorDNSEL.Control.Concurrent.Util import TorDNSEL.Directory import TorDNSEL.Document import TorDNSEL.Util +improt qualified TorDNSEL.Util ( bracket', finally' )
-------------------------------------------------------------------------------- -- Connections @@ -193,15 +194,8 @@ data ConfSetting = forall a b. (ConfVal b, SameConfVal a b) => -- 'IO' action. If an exception interrupts execution, close the connection -- gracefully before re-throwing the exception. withConnection :: Handle -> Maybe ByteString -> (Connection -> IO a) -> IO a -withConnection handle mbPasswd io = - E.block $ do - conn <- openConnection handle mbPasswd - r <- E.catch (E.unblock $ io conn) $ \e -> do - -- so the original exception isn't lost - ignoreJust syncExceptions (closeConnection conn) - E.throwIO e - closeConnection conn - return r +withConnection handle mbPasswd = + bracket' (openConnection handle mbPasswd) closeConnection
-- | Open a connection with a handle and an optional password. Throw a -- 'TorControlError' or 'IOError' if initializing the connection fails. @@ -211,19 +205,18 @@ openConnection handle mbPasswd = do conn@(tellIOManager,ioManagerTid) <- startIOManager handle confSettings <- newMVar []
- E.handle - (\e -> do ignoreJust syncExceptions (closeConnection' conn confSettings) - E.throwIO e) $ do - let protInfoCommand = Command (B.pack "protocolinfo") [B.pack "1"] [] - rs@(r:_) <- sendCommand' protInfoCommand False Nothing conn - throwIfNotPositive protInfoCommand r - protInfo <- either (protocolError protInfoCommand) return - (parseProtocolInfo rs) - - let conn' = Conn tellIOManager ioManagerTid protInfo confSettings - authenticate mbPasswd conn' - useFeature [VerboseNames] conn' - return conn' + ( do let protInfoCommand = Command (B.pack "protocolinfo") [B.pack "1"] [] + rs@(r:_) <- sendCommand' protInfoCommand False Nothing conn + throwIfNotPositive protInfoCommand r + protInfo <- either (protocolError protInfoCommand) return + (parseProtocolInfo rs) + + let conn' = Conn tellIOManager ioManagerTid protInfo confSettings + authenticate mbPasswd conn' + useFeature [VerboseNames] conn' + putStrLn "*X MRMLJ" + return conn' + ) `onException'` closeConnection' conn confSettings
-- | Close a connection gracefully, blocking the current thread until the -- connection has terminated. diff --git a/src/TorDNSEL/Util.hsc b/src/TorDNSEL/Util.hsc index 13303ac..4329e68 100644 --- a/src/TorDNSEL/Util.hsc +++ b/src/TorDNSEL/Util.hsc @@ -51,13 +51,17 @@ module TorDNSEL.Util ( , split , ignoreJust , syncExceptions + , bracket' + , finally' + , bracketOnError' + , onException' , exitUsage + , trySync , inBoundsOf , htonl , ntohl , hGetLine , splitByDelimiter - , showException , showUTCTime
-- * Network functions @@ -98,6 +102,7 @@ module TorDNSEL.Util ( ) where
import Control.Arrow ((&&&), first, second) +import Control.Applicative import qualified Control.Exception as E import Control.Monad.Error (Error(..), MonadError(..), MonadTrans(..), MonadIO(..)) @@ -318,14 +323,59 @@ encodeBase16 = B.pack . concat . B.foldr ((:) . toBase16 . B.c2w) [] split :: Int -> ByteString -> [ByteString] split x = takeWhile (not . B.null) . map (B.take x) . iterate (B.drop x)
+ +-- | Try an action, catching -- roughly -- "synchronous" exceptions. +-- +-- XXX This is a remnant of the original code base; it's actually impossible to +-- determine if an exception was thrown synchronously just by its type. Usage of +-- this and derived combinators should be pruned in favour of only handling +-- per-use-site expected exceptions. +-- +trySync :: IO a -> IO (Either E.SomeException a) +trySync = E.tryJust $ \e -> + case E.fromException (e :: E.SomeException) of + Just (_ :: E.AsyncException) -> Nothing + _ -> Just e + +-- | Like 'E.bracket', but if cleanup re-throws while handling a throw, don't +-- eat the original exception. +bracket' :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c +bracket' before after act = + E.mask $ \restore -> do + a <- before + r <- restore (act a) `E.onException` trySync (after a) + _ <- after a + return r + +-- | Like 'E.finally', but if cleanup re-throws while handling a throw, don't +-- eat the original exception. +finally' :: IO a -> IO b -> IO a +finally' act after = bracket' (return ()) (const after) (const act) + +-- | Like 'E.bracketOnError', but if cleanup re-throws while handling a throw, +-- don't eat the original exception. +bracketOnError' :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c +bracketOnError' before after act = + E.mask $ \restore -> do + a <- before + restore (act a) `E.onException` trySync (after a) + +-- | Like 'E.onException' +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 -> Maybe a) -> IO () -> IO () +ignoreJust :: (E.Exception e) => (e -> Maybe a) -> IO () -> IO () ignoreJust p = E.handleJust p . const . return $ ()
-- | A predicate matching synchronous exceptions. -syncExceptions :: E.Exception -> Maybe E.Exception -syncExceptions (E.AsyncException _) = Nothing -syncExceptions e = Just e +-- XXX This is a bad idea. The exn itself conveys no info on how it was thrown. +syncExceptions :: E.SomeException -> Maybe E.SomeException +syncExceptions e + | show e == "<<timeout>>" = Nothing + | Just (_ :: E.AsyncException) <- E.fromException e = Nothing + | otherwise = Just e
-- | Print a usage message to the given handle and exit with the given code. exitUsage :: Handle -> ExitCode -> IO a @@ -477,10 +527,10 @@ splitByDelimiter delimiter bs = subst (-len : B.findSubstrings delimiter bs)
-- | 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 +-- 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