I’m attaching three patches. For an explanation regarding the ‘FlexibleInstances’ extension see [1,2].
As always, I’ve only fixed critical things. Deprecation warnings can
wait.
Perhaps, I’ll combine all similar patches (like those that deal with
exceptions) later.
I’ve noticed that the author decided to use ‘Dynamic’-related functions
to raise many (all?) exceptions. If you raise an exception of type
‘Dynamic’, you won’t get a meaningful message. Consider the following:
{-# LANGUAGE DeriveDataTypeable #-}
import qualified Control.Exception as E
import Data.Dynamic (toDyn)
import Data.Typeable (Typeable)
-- | An exception related to links or monitors.
data LinkException = NonexistentThread -- ^
deriving (Eq, Typeable)
instance Show LinkException where
show NonexistentThread = "Attempt to link to nonexistent thread"
test1 = E.throw . toDyn $ NonexistentThread
instance E.Exception LinkException where
test2 = E.throw NonexistentThread
In GHCi:
*Main> test1
*** Exception: <<LinkException>>
*Main> test2
*** Exception: Attempt to link to nonexistent thread
Note that the first argument of ‘E.throw’ must be an instance of
‘E.Exception’:
E.throw :: E.Exception e => e -> a
‘LinkException’ is not an instance of ‘E.Exception’ in
‘TorDNSEL.Control.Concurrent.Link.Internals’. It should be easy to
change that.
Later, I’d also like to inspect ‘withLinksDo’, ‘linkTogether’, and
replace ‘$’ with ‘.’ in a couple of places.
The previous set of patches is here [3].
[1] http://www.haskell.org/haskellwiki/List_instance
[2]
http://www.haskell.org/ghc/docs/6.8-latest/html/users_guide/type-class-extensions.html#instance-rules
[3] https://lists.torproject.org/pipermail/tor-dev/2013-July/005157.html
From e7a064af8ff914a54d9c0eaf1ef7c17c84ed621e Mon Sep 17 00:00:00 2001 From: Nikita Karetnikov <[email protected]> Date: Sat, 3 Aug 2013 12:53:52 +0000 Subject: [PATCH 1/3] Replace 'TorDNSEL.Compat.Exception' with 'Control.Exception'. --- src/TorDNSEL/Control/Concurrent/Link/Internals.hs | 89 ++++++++++++--------- src/TorDNSEL/Control/Concurrent/Util.hs | 6 +- 2 files changed, 54 insertions(+), 41 deletions(-) diff --git a/src/TorDNSEL/Control/Concurrent/Link/Internals.hs b/src/TorDNSEL/Control/Concurrent/Link/Internals.hs index 8f8988e..14b2248 100644 --- a/src/TorDNSEL/Control/Concurrent/Link/Internals.hs +++ b/src/TorDNSEL/Control/Concurrent/Link/Internals.hs @@ -28,7 +28,8 @@ module TorDNSEL.Control.Concurrent.Link.Internals where import qualified Control.Concurrent as C import Control.Concurrent.MVar (MVar, newMVar, withMVar, modifyMVar, modifyMVar_) -import qualified TorDNSEL.Compat.Exception as E +import GHC.Conc.Sync (setUncaughtExceptionHandler) +import qualified Control.Exception as E import Control.Monad (unless) import qualified Data.Foldable as F import qualified Data.Map as M @@ -38,7 +39,7 @@ import Data.List (nub) import Data.Unique (Unique, newUnique) import System.IO (hPutStrLn, hFlush, stderr) import System.IO.Unsafe (unsafePerformIO) - +import System.Exit (ExitCode) import TorDNSEL.Util -- | An abstract type representing a handle to a linkable thread. Holding a @@ -75,11 +76,17 @@ threadMap :: MVar ThreadMap {-# NOINLINE threadMap #-} threadMap = unsafePerformIO . newMVar $ ThreadMap M.empty M.empty +-- | A predicate that matches assertions. +assertions :: E.SomeException -> Maybe String +assertions e = case E.fromException e :: Maybe E.AssertionFailed of + Nothing -> Nothing + Just e' -> Just (show e') + -- | Assert various invariants of the global link and monitor state, printing a -- message to stdout if any assertions fail. assertThreadMap :: ThreadMap -> IO () assertThreadMap tm = - E.handleJust E.assertions (putStr . ("assertThreadMap: " ++)) $ + E.handleJust assertions (putStr . ("assertThreadMap: " ++)) $ E.assert (M.size (ids tm) > 0) $ E.assert (M.size (ids tm) == M.size (state tm)) $ E.assert (M.elems (ids tm) == nub (M.elems (ids tm))) $ @@ -106,31 +113,37 @@ data ExitSignal = ExitSignal !ThreadId !ExitReason -- | Extract the 'ExitReason' from an 'ExitSignal' contained within a -- dynamically-typed exception. If the exception doesn't contain an -- 'ExitSignal', tag it with 'Just'. -extractReason :: E.Exception -> ExitReason -extractReason (E.DynException dyn) - | Just (ExitSignal _ e) <- fromDynamic dyn = e -extractReason e = Just e - --- | Extract an exit signal from an 'E.Exception' if it has the right type. -fromExitSignal :: Typeable a => E.Exception -> Maybe (ThreadId, a) -fromExitSignal (E.DynException d) - | Just (ExitSignal tid (Just (E.DynException d'))) <- fromDynamic d +extractReason :: E.SomeException -> ExitReason +extractReason e + | Just dyn <- E.fromException e :: Maybe Dynamic + , Just (ExitSignal _ e') <- fromDynamic dyn + = e' + | otherwise = Just e + +-- | Extract an exit signal from 'E.SomeException' if it has the right +-- type. +fromExitSignal :: Typeable a => E.SomeException -> Maybe (ThreadId, a) +fromExitSignal e + | Just d <- E.fromException e :: Maybe Dynamic + , Just (ExitSignal tid (Just e')) <- fromDynamic d + , Just d' <- E.fromException e' :: Maybe Dynamic = (,) tid `fmap` fromDynamic d' -fromExitSignal _ = Nothing + | otherwise = Nothing -- | The default action used to signal a thread. Abnormal 'ExitReason's are -- sent to the thread and normal exits are ignored. defaultSignal :: C.ThreadId -> ThreadId -> ExitReason -> IO () -defaultSignal dst src e@(Just _) = E.throwDynTo dst $ ExitSignal src e +defaultSignal dst src e@(Just _) = + E.throwTo dst $ E.toException $ toDyn $ ExitSignal src e defaultSignal _ _ Nothing = return () -- | Initialize the state supporting links and monitors. Use the given function -- to display an uncaught exception. It is an error to call this function -- outside the main thread, or to call any other functions in this module -- outside this function. -withLinksDo :: (E.Exception -> String) -> IO a -> IO () -withLinksDo showE io = E.block $ do - E.setUncaughtExceptionHandler . const . return $ () +withLinksDo :: (E.SomeException -> String) -> IO a -> IO () +withLinksDo showE io = E.mask $ \restore -> do + setUncaughtExceptionHandler . const . return $ () main <- C.myThreadId mainId <- Tid `fmap` newUnique let initialState = ThreadState @@ -140,21 +153,22 @@ withLinksDo showE io = E.block $ do , monitors = M.empty , ownedMons = S.empty } modifyMVar_ threadMap $ \tm -> - E.assert (M.size (ids tm) == 0) $ - E.assert (M.size (state tm) == 0) $ + E.assert (M.null (ids tm)) $ + E.assert (M.null (state tm)) $ return $! initialState `seq` tm { ids = M.insert mainId main (ids tm) , state = M.insert main initialState (state tm) } -- Don't bother propagating signals from the main thread -- since it's about to exit. - (E.unblock io >> return ()) `E.catch` \e -> + (restore io >> return ()) `E.catch` \e -> case extractReason e of - Nothing -> return () - Just e'@(E.ExitException _) -> E.throwIO e' - Just e' -> do - hPutStrLn stderr ("*** Exception: " ++ showE e') - hFlush stderr - E.throwIO e' + Nothing -> return () + Just e' -> case E.fromException e' :: Maybe ExitCode of + Just _ -> E.throwIO e' + Nothing -> do + hPutStrLn stderr ("*** Exception: " ++ showE e') + hFlush stderr + E.throwIO e' -- | Evaluate the given 'IO' action in a new thread, returning its 'ThreadId'. forkIO :: IO a -> IO ThreadId @@ -216,7 +230,7 @@ forkLinkIO' shouldLink io = E.block $ do return childId where forkHandler = C.forkIO . ignore . (>> return ()) . E.block - ignore = E.handle . const . return $ () + ignore = E.handle (const . return $ () :: E.SomeException -> IO ()) -- | Establish a bidirectional link between the calling thread and a given -- thread. If either thread terminates, an exit signal will be sent to the other @@ -234,8 +248,8 @@ linkThread tid = do in tm' `seq` return (tm', Nothing) Nothing -> let s = state tm M.! me - in return (tm, Just . signal s tid . Just . E.DynException . - toDyn $ NonexistentThread) + in return (tm, Just . signal s tid . Just . E.toException + . toDyn $ NonexistentThread) whenJust mbSignalSelf id where linkTogether x y = (x `linkTo` y) . (y `linkTo` x) @@ -261,7 +275,7 @@ data Monitor = Monitor !ThreadId !Unique -- | The reason a thread was terminated. @Nothing@ means the thread exited -- normally. @Just exception@ contains the reason for an abnormal exit. -type ExitReason = Maybe E.Exception +type ExitReason = Maybe E.SomeException -- | Start monitoring the given thread, invoking an 'IO' action with the -- 'ExitReason' when the thread dies. Return a handle to the monitor, which can @@ -285,7 +299,7 @@ monitorThread tid notify = do adjust' (addOwned tid') me $ state tm } in tm' `seq` return (tm', True) unless exists $ - notify . Just . E.DynException . toDyn $ NonexistentThread + notify . Just . E.toException . toDyn $ NonexistentThread return mon -- | Cancel a monitor, if it is currently active. @@ -311,7 +325,7 @@ withMonitor tid notify = -- | Terminate the calling thread with the given 'ExitReason'. exit :: ExitReason -> IO a -exit e = E.throwDyn . flip ExitSignal e =<< myThreadId +exit e = E.throw . toDyn . flip ExitSignal e =<< myThreadId -- | Send an exit signal with an 'ExitReason' to a thread. If the 'ExitReason' -- is 'Nothing', the signal will be ignored unless the target thread is trapping @@ -325,7 +339,7 @@ throwTo tid e = do let me' = ident (state tm M.! me) in if tid == me' -- special case: an exception thrown to oneself is untrappable - then E.throwDyn $ ExitSignal me' e + then E.throw . toDyn $ ExitSignal me' e else return $ do tid' <- M.lookup tid (ids tm) return $ signal (state tm M.! tid') me' -- since signal can block, we don't want to hold a lock on threadMap @@ -333,7 +347,7 @@ throwTo tid e = do -- | A variant of 'throwTo' for dynamically typed 'ExitReason's. throwDynTo :: Typeable a => ThreadId -> a -> IO () -throwDynTo tid = throwTo tid . Just . E.DynException . toDyn +throwDynTo tid = throwTo tid . Just . E.toException . toDyn -- | Send an untrappable exit signal to a thread, if it exists. killThread :: ThreadId -> IO () @@ -341,9 +355,8 @@ killThread tid = do me <- C.myThreadId mbSignal <- withMVar threadMap $ \tm -> return $ do tid' <- M.lookup tid (ids tm) - return . - E.throwDynTo tid' $ ExitSignal (ident (state tm M.! me)) - (Just (E.AsyncException E.ThreadKilled)) + return . E.throwTo tid' . toDyn . ExitSignal (ident (state tm M.! me)) + . Just $ E.toException E.ThreadKilled whenJust mbSignal id -- | Redirect exit signals destined for the calling thread to the given 'IO' @@ -362,7 +375,7 @@ unsetTrapExit :: IO () unsetTrapExit = setTrapExit . defaultSignal =<< C.myThreadId -- | An exception related to links or monitors. -data LinkException = NonexistentThread -- ^ +data LinkException = NonexistentThread -- ^ deriving (Eq, Typeable) instance Show LinkException where diff --git a/src/TorDNSEL/Control/Concurrent/Util.hs b/src/TorDNSEL/Control/Concurrent/Util.hs index b502f4b..395a7fd 100644 --- a/src/TorDNSEL/Control/Concurrent/Util.hs +++ b/src/TorDNSEL/Control/Concurrent/Util.hs @@ -12,9 +12,9 @@ ----------------------------------------------------------------------------- module TorDNSEL.Control.Concurrent.Util where -import qualified TorDNSEL.Compat.Exception as E +import qualified Control.Exception as E import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar, tryPutMVar) -import Data.Dynamic (Dynamic) +import Data.Dynamic (Dynamic, toDyn) import Data.Maybe (isJust) import TorDNSEL.Control.Concurrent.Link @@ -67,7 +67,7 @@ call sendMsg tid = do sendMsg $ putResponse . Right response <- takeMVar mv case response of - Left Nothing -> E.throwDyn NonexistentThread + Left Nothing -> E.throw . toDyn $ NonexistentThread Left (Just e) -> E.throwIO e Right r -> return r -- 1.7.9.5
From 5fee61b3961d078c30e69fe70404f08b38690fcb Mon Sep 17 00:00:00 2001 From: Nikita Karetnikov <[email protected]> Date: Sat, 3 Aug 2013 13:05:17 +0000 Subject: [PATCH 2/3] Import the 'CInt' constructor properly. --- src/TorDNSEL/Log/Internals.hsc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/TorDNSEL/Log/Internals.hsc b/src/TorDNSEL/Log/Internals.hsc index 5e7854e..53f5cba 100644 --- a/src/TorDNSEL/Log/Internals.hsc +++ b/src/TorDNSEL/Log/Internals.hsc @@ -33,7 +33,7 @@ import Data.Bits ((.|.)) import qualified Data.ByteString.Char8 as B import Data.List (foldl') import Data.Time (UTCTime, getCurrentTime) -import Foreign.C (CString, CInt, withCString) +import Foreign.C (CString, CInt(..), withCString) import System.IO (Handle, stdout, stderr, openFile, IOMode(AppendMode), hFlush, hClose) import System.IO.Unsafe (unsafePerformIO) -- 1.7.9.5
From 32f473eb33f6e52a384ca8164c6b4bd94df50994 Mon Sep 17 00:00:00 2001 From: Nikita Karetnikov <[email protected]> Date: Sat, 3 Aug 2013 13:20:10 +0000 Subject: [PATCH 3/3] Add the 'FlexibleInstances' extension. --- src/TorDNSEL/Directory/Internals.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/TorDNSEL/Directory/Internals.hs b/src/TorDNSEL/Directory/Internals.hs index ace1f68..f6dacfe 100644 --- a/src/TorDNSEL/Directory/Internals.hs +++ b/src/TorDNSEL/Directory/Internals.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE PatternGuards, TypeSynonymInstances, FlexibleContexts #-} +{-# LANGUAGE PatternGuards, TypeSynonymInstances, FlexibleContexts, + FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- 1.7.9.5
pgp_rptOXfGPL.pgp
Description: PGP signature
_______________________________________________ tor-dev mailing list [email protected] https://lists.torproject.org/cgi-bin/mailman/listinfo/tor-dev
