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 <nikita@xxxxxxxxxxxxxx>
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 <nikita@xxxxxxxxxxxxxx> 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 <nikita@xxxxxxxxxxxxxx>
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
Attachment:
pgpfoLxeDNrTX.pgp
Description: PGP signature
_______________________________________________ tor-dev mailing list tor-dev@xxxxxxxxxxxxxxxxxxxx https://lists.torproject.org/cgi-bin/mailman/listinfo/tor-dev