Yet another patch that (hopefully) fixes exceptions. If you apply it on top of the previous set [1], you should be able to build 24 out of 38 modules. [1] https://lists.torproject.org/pipermail/tor-dev/2013-August/005219.html
From fd515bf11f085ed4f9f561cad6d1898aa7eab586 Mon Sep 17 00:00:00 2001
From: Nikita Karetnikov <nikita@xxxxxxxxxxxxxx>
Date: Sun, 11 Aug 2013 15:49:38 +0000
Subject: [PATCH] Replace 'TorDNSEL.Compat.Exception' with
'Control.Exception'.
---
src/TorDNSEL/ExitTest/Server/Internals.hs | 16 +++----
src/TorDNSEL/NetworkState/Storage/Internals.hs | 6 +--
src/TorDNSEL/Socks/Internals.hs | 8 ++--
src/TorDNSEL/TorControl/Internals.hs | 59 ++++++++++++++----------
src/TorDNSEL/Util.hsc | 6 +++
5 files changed, 55 insertions(+), 40 deletions(-)
diff --git a/src/TorDNSEL/ExitTest/Server/Internals.hs b/src/TorDNSEL/ExitTest/Server/Internals.hs
index 6f7eb42..627ffcc 100644
--- a/src/TorDNSEL/ExitTest/Server/Internals.hs
+++ b/src/TorDNSEL/ExitTest/Server/Internals.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE PatternGuards, BangPatterns #-}
+{-# LANGUAGE PatternGuards, BangPatterns, ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
-----------------------------------------------------------------------------
@@ -24,7 +24,7 @@ module TorDNSEL.ExitTest.Server.Internals where
import Prelude hiding (log)
import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan, isEmptyChan)
import Control.Concurrent.QSemN (QSemN, newQSemN, waitQSemN, signalQSemN)
-import qualified TorDNSEL.Compat.Exception as E
+import qualified Control.Exception as E
import Control.Monad (when, forM, foldM)
import Control.Monad.Fix (fix)
import Control.Monad.Trans (lift)
@@ -137,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'
@@ -158,7 +158,7 @@ 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.tryJust ioErrors $ bindListeningTCPSocket addr
case r of
Left e -> do
log Warn "Opening exit test listener on " addr " failed: " e "; \
@@ -168,9 +168,9 @@ reopenSocketIfClosed addr mbSock = MaybeT $ do
log Info "Opened exit test listener on " addr '.'
return $ Just sock
where
- isListeningSocketOpen Nothing = return False
- isListeningSocketOpen (Just sock) =
- getSocketName sock >> return True `catch` const (return False)
+ isListeningSocketOpen Nothing = return False
+ isListeningSocketOpen (Just s) = E.catchJust ioErrors
+ (getSocketName s >> return True) (const $ return False)
-- | Process a 'ServerMessage' and return the new config and state, given the
-- current config and state.
@@ -179,7 +179,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.tryJust ioErrors $ do
r <- runMaybeT $ getRequest client
case r of
Just cookie -> do
diff --git a/src/TorDNSEL/NetworkState/Storage/Internals.hs b/src/TorDNSEL/NetworkState/Storage/Internals.hs
index e0d610c..f8abf43 100644
--- a/src/TorDNSEL/NetworkState/Storage/Internals.hs
+++ b/src/TorDNSEL/NetworkState/Storage/Internals.hs
@@ -22,7 +22,7 @@ module TorDNSEL.NetworkState.Storage.Internals where
import Prelude hiding (log)
import Control.Arrow (second)
import Control.Concurrent.Chan (newChan, readChan, writeChan)
-import qualified TorDNSEL.Compat.Exception as E
+import qualified Control.Exception as E
import Control.Monad (liftM2, when, forM)
import Control.Monad.Error (MonadError(throwError))
import Control.Monad.Fix (fix)
@@ -138,7 +138,7 @@ startStorageManager initConf = do
return (s { exitAddrLen = addrLen, journalLen = 0 }, nullSignal)
getFileSize fp =
- E.catchJust E.ioErrors
+ E.catchJust ioErrors
((fromIntegral . fileSize) `fmap` getFileStatus fp)
(\e -> if isDoesNotExistError e then return 0 else ioError e)
@@ -242,7 +242,7 @@ 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.catchJust ioErrors
(B.readFile path)
(\e -> if isDoesNotExistError e then return B.empty else ioError e)
addrs <- forM (parseSubDocs (B.pack "ExitNode") parseExitAddress .
diff --git a/src/TorDNSEL/Socks/Internals.hs b/src/TorDNSEL/Socks/Internals.hs
index 719e367..23f5633 100644
--- a/src/TorDNSEL/Socks/Internals.hs
+++ b/src/TorDNSEL/Socks/Internals.hs
@@ -40,11 +40,11 @@ module TorDNSEL.Socks.Internals (
, showSocksError
) where
-import qualified TorDNSEL.Compat.Exception as E
+import qualified Control.Exception as E
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as L
import Data.ByteString (ByteString)
-import Data.Dynamic (Dynamic, fromDynamic)
+import Data.Dynamic (Dynamic, fromDynamic, toDyn)
import Data.Typeable (Typeable)
import Network.Socket (HostAddress)
import System.IO (Handle, BufferMode(NoBuffering), hClose, hSetBuffering)
@@ -69,8 +69,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.throw . toDyn $ SocksError result
+ _ -> E.throw $ toDyn SocksProtocolError
--------------------------------------------------------------------------------
-- Data types
diff --git a/src/TorDNSEL/TorControl/Internals.hs b/src/TorDNSEL/TorControl/Internals.hs
index e9e4c1a..c3480da 100644
--- a/src/TorDNSEL/TorControl/Internals.hs
+++ b/src/TorDNSEL/TorControl/Internals.hs
@@ -145,7 +145,7 @@ import Control.Arrow (first, second)
import Control.Concurrent.Chan (newChan, readChan, writeChan)
import Control.Concurrent.MVar
(MVar, newMVar, newEmptyMVar, takeMVar, tryPutMVar, withMVar, modifyMVar_)
-import qualified TorDNSEL.Compat.Exception as E
+import qualified Control.Exception as E
import Control.Monad (when, unless, liftM, mzero, mplus)
import Control.Monad.Error (MonadError(..))
import Control.Monad.Fix (fix)
@@ -153,7 +153,7 @@ import Control.Monad.State (StateT(StateT), get, put, lift, evalStateT)
import qualified Data.ByteString.Char8 as B
import Data.ByteString (ByteString)
import Data.Char (isSpace, isAlphaNum, isDigit, isAlpha, toLower)
-import Data.Dynamic (Dynamic, fromDynamic)
+import Data.Dynamic (Dynamic, fromDynamic, toDyn)
import Data.List (find)
import qualified Data.Map as M
import Data.Maybe (fromMaybe, maybeToList, listToMaybe, isNothing, isJust)
@@ -204,7 +204,7 @@ 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
+ r <- E.catch (E.unblock $ io conn) $ \(e :: E.SomeException) -> do
-- so the original exception isn't lost
ignoreJust syncExceptions (closeConnection conn)
E.throwIO e
@@ -220,8 +220,9 @@ openConnection handle mbPasswd = do
confSettings <- newMVar []
E.handle
- (\e -> do ignoreJust syncExceptions (closeConnection' conn confSettings)
- E.throwIO e) $ do
+ (\(e :: E.SomeException) -> 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
@@ -356,7 +357,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.throw . toDyn $ toTCError command reply
where command = Command (B.pack "getinfo") [key] []
maxRepLen = 64
@@ -387,7 +388,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.throw . toDyn $ toTCError command reply
where command = Command (B.pack "getinfo") [key] []
check f = either (parseError command) (return . f)
maxRepLen = 64
@@ -420,7 +421,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.throw . toDyn $ toTCError command reply
where
command = Command (B.pack "extendcircuit") args []
args = add purpose [cid, B.intercalate (B.pack ",") $ map encodeBase16RouterID path]
@@ -537,12 +538,15 @@ sendCommand' command isQuit mbEvHandlers (tellIOManager,ioManagerTid) = do
withMonitor ioManagerTid (putResponse . Left) $ do
tellIOManager $ SendCommand command isQuit mbEvHandlers (putResponse.Right)
response <- takeMVar mv
+ let throwClosed = E.throw $ toDyn ConnectionClosed
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
+ Right replies -> return replies
+ Left Nothing -> throwClosed
+ Left (Just e)
+ | Just NonexistentThread
+ <- fromDynamic =<< (E.fromException e :: Maybe Dynamic)
+ -> throwClosed
+ | otherwise -> E.throwIO e
--------------------------------------------------------------------------------
-- Config variables
@@ -652,7 +656,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.throw . toDyn . ParseError
maxVarLen = 64
--------------------------------------------------------------------------------
@@ -678,8 +682,11 @@ newDescriptorsEvent ::
([TorControlError] -> [Descriptor] -> IO ()) -> Connection -> EventHandler
newDescriptorsEvent handler conn = EventHandler (B.pack "NEWDESC") handleNewDesc
where
- safeGetDescriptor rid = Right `fmap` getDescriptor rid conn
- `E.catchDyn` \(e :: TorControlError) -> return (Left e)
+ safeGetDescriptor rid =
+ Right `fmap` getDescriptor rid conn `E.catch` \e ->
+ case fromDynamic e :: Maybe TorControlError of
+ Just e' -> return (Left e')
+ Nothing -> E.throwIO e
handleNewDesc (Reply _ text _:_) = do
-- pipeline descriptor requests
(es',ds) <- fmap partitionEither . mapM resolve
@@ -782,8 +789,9 @@ startIOManager handle = do
loop s { evHandlerTid = newEvHandlerTid }
| isNothing reason -> loop s
| tid == socketReaderTid
- , Just (E.IOException e) <- reason, isEOFError e
- , quitSent s, S.null (responds s) -> kill $ evHandlerTid s
+ , Just e <- E.fromException =<< reason :: Maybe E.IOException
+ , isEOFError e, quitSent s, S.null (responds s)
+ -> kill $ evHandlerTid s
| otherwise -> exit reason
CloseConnection -> mapM_ kill [socketReaderTid, evHandlerTid s]
@@ -822,7 +830,7 @@ startIOManager handle = do
Right event -> event >> loop
kill tid = terminateThread Nothing tid . throwTo tid . Just $
- E.AsyncException E.ThreadKilled
+ E.toException E.ThreadKilled
renderCommand (Command key args []) =
B.intercalate (B.pack " ") (key : args) `B.append` B.pack "\r\n"
@@ -853,7 +861,7 @@ startSocketReader handle sendRepliesToIOManager =
LastReply reply -> return [reply]
parseReplyLine line =
- either (E.throwDyn . ProtocolError) (parseReplyLine' typ text)
+ either (E.throw . toDyn . ProtocolError) (parseReplyLine' typ text)
(parseReplyCode code)
where (code,(typ,text)) = B.splitAt 1 `second` B.splitAt 3 line
@@ -861,8 +869,8 @@ 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 $
- cat "Malformed reply line type " (esc 1 typ) '.'
+ | otherwise = E.throw . toDyn . ProtocolError $
+ cat "Malformed reply line type " (esc 1 typ) '.'
readData = do
line <- hGetLineN handle (B.pack "\n") maxLineLength
@@ -1143,11 +1151,12 @@ 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.throw . toDyn . 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.throw . toDyn . ParseError . cat $ commandFailed command
-- | Convert a command and negative reply to a 'TorControlError'.
toTCError :: Command -> Reply -> TorControlError
@@ -1164,7 +1173,7 @@ parseReplyCode bs
throwIfNotPositive :: Command -> Reply -> IO ()
throwIfNotPositive command reply =
unless (isPositive $ repCode reply) $
- E.throwDyn $ toTCError command reply
+ E.throw . toDyn $ toTCError command reply
-- | Is a reply successful?
isPositive :: ReplyCode -> Bool
diff --git a/src/TorDNSEL/Util.hsc b/src/TorDNSEL/Util.hsc
index f71cf99..78556f4 100644
--- a/src/TorDNSEL/Util.hsc
+++ b/src/TorDNSEL/Util.hsc
@@ -59,6 +59,7 @@ module TorDNSEL.Util (
, hGetLineN
, showException
, showUTCTime
+ , ioErrors
-- * Network functions
, bindUDPSocket
@@ -393,6 +394,11 @@ showUTCTime time = printf "%s %02d:%02d:%s" date hours mins secStr'
secStr = printf "%02.4f" (secs :: Double)
secStr' = (if length secStr < 7 then ('0':) else id) secStr
+-- | Predicate that matches 'E.IOException's, which can be used with
+-- 'E.catchJust' and similar functions.
+ioErrors :: E.SomeException -> Maybe E.IOException
+ioErrors = E.fromException
+
--------------------------------------------------------------------------------
-- Network functions
--
1.7.9.5
Attachment:
pgpEgWsoH8icb.pgp
Description: PGP signature
_______________________________________________ tor-dev mailing list tor-dev@xxxxxxxxxxxxxxxxxxxx https://lists.torproject.org/cgi-bin/mailman/listinfo/tor-dev