[tor-commits] [tordnsel/master] start centralizing sync/async exn classification

[arlo at torproject.org]

commit a52e0fe72ae2f9a9f4c0ce0ec7b8092c5ad15d40
Author: David Kaloper <david at 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