April 2016 - tor-commits - lists.torproject.org

[tordnsel/master] fix a space leak when reading tor control messages
by arlo＠torproject.org 16 Apr '16

16 Apr '16

commit 5a70559f8ca976e51d830f6fafb12b045f577055 Author: David Kaloper <david(a)numm.org> Date: Tue Oct 29 04:43:52 2013 +0100 fix a space leak when reading tor control messages Data.Conduit.leftover considered harmful. --- src/TorDNSEL/ExitTest/Request.hs | 7 ++-- src/TorDNSEL/TorControl/Internals.hs | 5 +-- src/TorDNSEL/Util.hsc | 76 +++++++++++++++++++++--------------- 3 files changed, 49 insertions(+), 39 deletions(-) diff --git a/src/TorDNSEL/ExitTest/Request.hs b/src/TorDNSEL/ExitTest/Request.hs index 84f502a..affa6b8 100644 --- a/src/TorDNSEL/ExitTest/Request.hs +++ b/src/TorDNSEL/ExitTest/Request.hs @@ -68,17 +68,16 @@ createRequest host port cookie = getRequest :: Handle -> IO (Maybe Cookie) getRequest client = CB.sourceHandle client $= CB.isolate maxReqLen $$ do - reqline <- line + reqline <- c_line_crlf hs <- accHeaders [] case checkHeaders reqline hs of Nothing -> return Nothing - Just _ -> Just . Cookie <$> takeC cookieLen + Just _ -> Just . Cookie <$> c_take cookieLen where maxReqLen = 2048 + cookieLen - line = fromMaybe "" <$> frame "\r\n" - accHeaders hs = line >>= \ln -> + accHeaders hs = c_line_crlf >>= \ln -> do if ln == "" then return $ M.fromList hs else accHeaders (parseHeader ln : hs) diff --git a/src/TorDNSEL/TorControl/Internals.hs b/src/TorDNSEL/TorControl/Internals.hs index 0d299d6..43b6d19 100644 --- a/src/TorDNSEL/TorControl/Internals.hs +++ b/src/TorDNSEL/TorControl/Internals.hs @@ -834,8 +834,7 @@ startSocketReader handle sendRepliesToIOManager = -- | Stream decoded 'Reply' groups. c_replies :: Conduit B.ByteString IO [Reply] -c_replies = - frames (B.pack "\r\n") =$= line0 [] +c_replies = c_lines_any =$= line0 [] where line0 acc = await >>= return () `maybe` \line -> do @@ -855,7 +854,7 @@ c_replies = await >>= \mline -> case mline of Nothing -> return $ reverse acc Just line | B.null line -> rest acc - | line == B.pack "." -> return $ reverse (line:acc) + | line == B.pack "." -> return $ reverse acc | otherwise -> rest (line:acc) -------------------------------------------------------------------------------- diff --git a/src/TorDNSEL/Util.hsc b/src/TorDNSEL/Util.hsc index 2c57e0e..7397208 100644 --- a/src/TorDNSEL/Util.hsc +++ b/src/TorDNSEL/Util.hsc @@ -64,9 +64,10 @@ module TorDNSEL.Util ( , showUTCTime -- * Conduit utilities - , takeC - , frames - , frame + , c_take + , c_breakDelim + , c_line_crlf + , c_lines_any -- * Network functions , bindUDPSocket @@ -141,6 +142,7 @@ import Text.Printf (printf) import Data.Binary (Binary(..)) import qualified Data.Conduit as C +import qualified Data.Conduit.List as CL import qualified Data.Conduit.Binary as CB #include <netinet/in.h> @@ -414,49 +416,59 @@ instance Error e => MonadError e Maybe where foreign import ccall unsafe "htonl" htonl :: Word32 -> Word32 foreign import ccall unsafe "ntohl" ntohl :: Word32 -> Word32 -takeC :: Monad m => Int -> C.ConduitM ByteString o m ByteString -takeC = fmap (mconcat . BL.toChunks) . CB.take +-- | Convert a 'UTCTime' to a string in ISO 8601 format. +showUTCTime :: UTCTime -> String +showUTCTime time = printf "%s %02d:%02d:%s" date hours mins secStr' + where + date = show (utctDay time) + (n,d) = (numerator &&& denominator) (toRational $ utctDayTime time) + (seconds,frac) = n `divMod` d + (hours,(mins,sec)) = second (`divMod` 60) (seconds `divMod` (60^2)) + secs = fromRational (frac % d) + fromIntegral sec + secStr = printf "%02.4f" (secs :: Double) + secStr' = (if length secStr < 7 then ('0':) else id) secStr --- | Take a "frame" - delimited sequence - from the input. --- Returns 'Nothing' if the delimiter does not appear before the stream ends. -frame :: MonadIO m => ByteString -> C.ConduitM ByteString a m (Maybe ByteString) -frame delim = input $ B.pack "" +-------------------------------------------------------------------------------- +-- Conduit utilities + +-- | 'CB.take' for strict 'ByteString's. +c_take :: Monad m => Int -> C.ConduitM ByteString o m ByteString +c_take = fmap (mconcat . BL.toChunks) . CB.take + +-- | Read until the delimiter and return the parts before and after, not +-- including delimiter. +c_breakDelim :: Monad m + => ByteString + -> C.ConduitM ByteString o m (Maybe (ByteString, ByteString)) +c_breakDelim delim = wait_input $ B.empty where - input front = C.await >>= + wait_input front = C.await >>= (Nothing <$ C.leftover front) `maybe` \bs -> let (front', bs') = (<> bs) `second` B.splitAt (B.length front - d_len + 1) front in case B.breakSubstring delim bs' of - (part, rest) | B.null rest -> input (front' <> bs') - | otherwise -> do - leftover $ B.drop d_len rest - return $ Just $ front' <> part + (part, rest) | B.null rest -> wait_input $ front' <> bs' + | otherwise -> + return $ Just (front' <> part, B.drop d_len rest) d_len = B.length delim --- | Stream delimited chunks. -frames :: MonadIO m => ByteString -> C.Conduit ByteString m ByteString -frames delim = frame delim >>= - return () `maybe` ((>> frames delim) . C.yield) -leftover :: Monad m => ByteString -> C.Conduit ByteString m o -leftover bs | B.null bs = return () - | otherwise = C.leftover bs +-- | Take a CRLF-delimited line from the input. +c_line_crlf :: Monad m => C.ConduitM ByteString o m ByteString +c_line_crlf = + c_breakDelim (B.pack "\r\n") >>= + return B.empty `maybe` \(line, rest) -> line <$ C.leftover rest - --- | Convert a 'UTCTime' to a string in ISO 8601 format. -showUTCTime :: UTCTime -> String -showUTCTime time = printf "%s %02d:%02d:%s" date hours mins secStr' +-- | Stream lines delimited by either LF or CRLF. +c_lines_any :: Monad m => C.Conduit ByteString m ByteString +c_lines_any = CB.lines C.=$= CL.map strip where - date = show (utctDay time) - (n,d) = (numerator &&& denominator) (toRational $ utctDayTime time) - (seconds,frac) = n `divMod` d - (hours,(mins,sec)) = second (`divMod` 60) (seconds `divMod` (60^2)) - secs = fromRational (frac % d) + fromIntegral sec - secStr = printf "%02.4f" (secs :: Double) - secStr' = (if length secStr < 7 then ('0':) else id) secStr + strip bs = case unsnoc bs of + Just (bs', '\r') -> bs' + _ -> bs -------------------------------------------------------------------------------- -- Network functions

1 0

[tordnsel/master] deal with a bunch of (harmless) warnings
by arlo＠torproject.org 16 Apr '16

16 Apr '16

commit 1588f46aafe1fc238c6495a4c8e41e7aea3ba7c0 Author: David Kaloper <david(a)numm.org> Date: Fri Sep 27 20:12:31 2013 +0200 deal with a bunch of (harmless) warnings --- src/TorDNSEL/Config/Internals.hs | 8 +++---- src/TorDNSEL/Control/Concurrent/Link/Internals.hs | 6 ++--- src/TorDNSEL/Control/Concurrent/Util.hs | 2 -- src/TorDNSEL/DNS/Server/Internals.hs | 4 ++-- src/TorDNSEL/ExitTest/Initiator/Internals.hs | 27 +++++++++++------------ src/TorDNSEL/ExitTest/Request.hs | 4 +--- src/TorDNSEL/ExitTest/Server/Internals.hs | 2 +- src/TorDNSEL/NetworkState/Internals.hs | 2 +- src/TorDNSEL/Socks/Internals.hs | 1 - src/TorDNSEL/Statistics/Internals.hs | 4 ++-- src/TorDNSEL/TorControl/Internals.hs | 3 +-- src/TorDNSEL/Util.hsc | 13 +++-------- tordnsel.cabal | 2 +- 13 files changed, 32 insertions(+), 46 deletions(-) diff --git a/src/TorDNSEL/Config/Internals.hs b/src/TorDNSEL/Config/Internals.hs index 4b60db7..2830ab6 100644 --- a/src/TorDNSEL/Config/Internals.hs +++ b/src/TorDNSEL/Config/Internals.hs @@ -422,7 +422,7 @@ Otherwise, the server runs with the new configuration and closes the connection: startReconfigServer :: Socket -> (Config -> (Maybe String -> IO ()) -> IO ()) -> IO ReconfigServer startReconfigServer sock sendConfig = do - log Info "Starting reconfigure server." :: IO () + log Info "Starting reconfigure server." chan <- newChan tid <- forkLinkIO $ do setTrapExit $ (writeChan chan .) . Exit @@ -439,7 +439,7 @@ handleMessage s (NewClient client signal) = do str <- B.hGetContents handle case parseConfigFile str >>= makeConfig of Left e -> do - hCat handle "Parse error: " e "\r\n" :: IO () + hCat handle "Parse error: " e "\r\n" log Warn "Parsing config from reconfigure socket failed: " e Right config -> do mv <- newEmptyMVar @@ -451,7 +451,7 @@ handleMessage s (NewClient client signal) = do return s handleMessage s (Terminate reason) = do - log Info "Terminating reconfigure server." :: IO () + log Info "Terminating reconfigure server." terminateThread Nothing (listenerTid s) (killThread $ listenerTid s) msgs <- untilM (isEmptyChan $ reconfigChan s) (readChan $ reconfigChan s) sequence_ [sClose client | NewClient client _ <- msgs] @@ -460,7 +460,7 @@ handleMessage s (Terminate reason) = do handleMessage s (Exit tid reason) | tid == listenerTid s = do log Warn "The reconfigure listener thread exited unexpectedly: " - (show reason) "; restarting." :: IO () + (show reason) "; restarting." newListenerTid <- forkListener (listenSock s) (writeChan $ reconfigChan s) return s { listenerTid = newListenerTid } | isAbnormal reason = exit reason diff --git a/src/TorDNSEL/Control/Concurrent/Link/Internals.hs b/src/TorDNSEL/Control/Concurrent/Link/Internals.hs index 5c3f8b2..7479cbb 100644 --- a/src/TorDNSEL/Control/Concurrent/Link/Internals.hs +++ b/src/TorDNSEL/Control/Concurrent/Link/Internals.hs @@ -134,7 +134,7 @@ fromExitSignal _ = 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 NormalExit = return () +defaultSignal _ _ NormalExit = return () defaultSignal dst src e = E.throwTo dst $ ExitSignal src e -- | Initialize the state supporting links and monitors. It is an error to call @@ -239,8 +239,8 @@ forkLinkIO' shouldLink io = E.mask $ \restore -> do return childId where - forkHandler io = E.mask_ . C.forkIO $ - (() <$ io) `E.catch` \(e :: E.SomeException) -> return () + forkHandler a = E.mask_ . C.forkIO $ + (() <$ a) `E.catch` \(_ :: E.SomeException) -> return () -- | 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 diff --git a/src/TorDNSEL/Control/Concurrent/Util.hs b/src/TorDNSEL/Control/Concurrent/Util.hs index a7c2a65..bd9adff 100644 --- a/src/TorDNSEL/Control/Concurrent/Util.hs +++ b/src/TorDNSEL/Control/Concurrent/Util.hs @@ -15,12 +15,10 @@ module TorDNSEL.Control.Concurrent.Util where import qualified Control.Exception as E import Data.Functor ( (<$) ) import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar, tryPutMVar) -import Data.Dynamic (Dynamic) import Data.Maybe (isJust) import System.Timeout import TorDNSEL.Control.Concurrent.Link -import TorDNSEL.Util -- | A type representing a handle to a thread. class Thread a where diff --git a/src/TorDNSEL/DNS/Server/Internals.hs b/src/TorDNSEL/DNS/Server/Internals.hs index 9bc8fc3..5b0f821 100644 --- a/src/TorDNSEL/DNS/Server/Internals.hs +++ b/src/TorDNSEL/DNS/Server/Internals.hs @@ -92,7 +92,7 @@ instance E.Exception DNSMessage -- it. Link the DNS server to the calling thread. startDNSServer :: DNSConfig -> IO DNSServer startDNSServer initConf = do - log Info "Starting DNS server." :: IO () + log Info "Starting DNS server." fmap DNSServer . forkLinkIO . E.block . loop $ initConf where loop conf = do @@ -108,7 +108,7 @@ startDNSServer initConf = do signal loop newConf Left (_,Terminate reason) -> do - log Info "Terminating DNS server." :: IO () + log Info "Terminating DNS server." exit reason Right _ -> loop conf -- impossible diff --git a/src/TorDNSEL/ExitTest/Initiator/Internals.hs b/src/TorDNSEL/ExitTest/Initiator/Internals.hs index 4605c15..98a9fb6 100644 --- a/src/TorDNSEL/ExitTest/Initiator/Internals.hs +++ b/src/TorDNSEL/ExitTest/Initiator/Internals.hs @@ -58,7 +58,6 @@ import Control.Concurrent.Chan (Chan, newChan, writeChan, readChan) import qualified Control.Exception as E import Control.Monad (replicateM_, guard, when) import qualified Data.ByteString.Char8 as B -import Data.Dynamic (fromDynamic) import qualified Data.Foldable as F import Data.List (foldl', unfoldr, mapAccumL) import qualified Data.Map as M @@ -153,7 +152,7 @@ data TestStatus -- thread. startExitTestInitiator :: ExitTestInitiatorConfig -> IO ExitTestInitiator startExitTestInitiator initConf = do - log Info "Starting exit test initiator." :: IO () + log Info "Starting exit test initiator." chan <- newChan initiatorTid <- forkLinkIO $ do setTrapExit ((writeChan chan .) . Exit) @@ -172,15 +171,15 @@ startExitTestInitiator initConf = do | TestWaiting rid ports published <- testStatus s , canRunExitTest conf s ports = do log Info "Forking exit test clients for router " rid - " ports " ports '.' :: IO () + " ports " ports '.' newClients <- mapM (forkTestClient conf rid published) ports let newRunningClients = foldl' (flip Set.insert) (runningClients s) newClients log Info "Exit test clients currently running: " - (Set.size newRunningClients) '.' :: IO () + (Set.size newRunningClients) '.' if Q.length (pendingTests s) == 0 then do - log Info "Pending exit tests: 0." :: IO () + log Info "Pending exit tests: 0." loop conf s { runningClients = newRunningClients , testStatus = NoTestsPending } else do @@ -201,7 +200,7 @@ handleMessage handleMessage conf s (NewDirInfo routers) | nRouterTests == 0 = return (conf, s) | otherwise = do - log Info "Scheduling exit tests for " nRouterTests " routers." :: IO () + log Info "Scheduling exit tests for " nRouterTests " routers." now <- getCurrentTime let newS = s { pendingTests = newPendingTests , testHistory = appendTestsToHistory now nRouterTests . @@ -237,7 +236,7 @@ handleMessage conf s (Reconfigure reconf signal) = do return (newConf, s) handleMessage _ s (Terminate reason) = do - log Info "Terminating exit test initiator." :: IO () + log Info "Terminating exit test initiator." F.forM_ (runningClients s) $ \client -> terminateThread Nothing client (killThread client) exit reason @@ -251,13 +250,13 @@ handleMessage conf s (Exit tid reason) routers <- nsRouters `fmap` eticfGetNetworkState conf case testsToExecute conf routers (pendingTests s) of Nothing -> do - log Info "Pending exit tests: 0." :: IO () + log Info "Pending exit tests: 0." return (conf, s { pendingTests = Q.empty , testStatus = NoTestsPending }) Just (rid,ports,published,newPendingTests) -> do - log Info "Pending exit tests: " (Q.length newPendingTests + 1) '.' :: IO () + log Info "Pending exit tests: " (Q.length newPendingTests + 1) '.' log Debug "Waiting to run exit test for router " rid - " ports " ports '.' :: IO () + " ports " ports '.' return (conf, s { pendingTests = newPendingTests , testStatus = TestWaiting rid ports published }) -- Periodically, add every eligible router to the exit test queue. This should @@ -372,13 +371,13 @@ forkTestClient conf rid published port = return () case r of Left (E.fromException -> Just (e :: SocksError)) -> do - log Info "Exit test for router " rid " port " port " failed: " e :: IO () + log Info "Exit test for router " rid " port " port " failed: " e E.throwIO e Left (E.fromException -> Just (e :: E.IOException)) -> do log Warn "Exit test for router " rid " port " port " failed : " e ". This might indicate a problem with making application \ \connections through Tor. Is Tor running? Is its SocksPort \ - \listening on " (eticfSocksServer conf) '?' :: IO () + \listening on " (eticfSocksServer conf) '?' E.throwIO e Left e -> E.throwIO e Right Nothing -> @@ -402,8 +401,8 @@ forkTestTimer :: InitiatorState -> IO ThreadId forkTestTimer s = forkLinkIO $ do log Debug "Total routers scheduled in exit test history: " (nTotalRouters $ testHistory s) ". " - (show . F.toList . historySeq $ testHistory s) :: IO () - log Info "Running next exit test in " currentInterval " microseconds." :: IO () + (show . F.toList . historySeq $ testHistory s) + log Info "Running next exit test in " currentInterval " microseconds." threadDelay $ fromIntegral currentInterval where currentInterval = currentTestInterval nPending (testHistory s) diff --git a/src/TorDNSEL/ExitTest/Request.hs b/src/TorDNSEL/ExitTest/Request.hs index 82e198c..4634e8d 100644 --- a/src/TorDNSEL/ExitTest/Request.hs +++ b/src/TorDNSEL/ExitTest/Request.hs @@ -26,13 +26,11 @@ module TorDNSEL.ExitTest.Request ( , cookieLen ) where -import Control.Arrow ((***), second) +import Control.Arrow ((***)) import Control.Applicative import Control.Monad -import Control.Monad.Trans (lift, liftIO) import Data.Monoid import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy as BL import Data.Char (isSpace, toLower) import qualified Data.Map as M import System.IO (Handle) diff --git a/src/TorDNSEL/ExitTest/Server/Internals.hs b/src/TorDNSEL/ExitTest/Server/Internals.hs index 13e2136..8d6377b 100644 --- a/src/TorDNSEL/ExitTest/Server/Internals.hs +++ b/src/TorDNSEL/ExitTest/Server/Internals.hs @@ -32,7 +32,7 @@ import qualified Data.ByteString.Char8 as B import qualified Data.Foldable as F import qualified Data.Map as M import Data.Map (Map) -import Data.Maybe (catMaybes, fromJust, isJust) +import Data.Maybe import qualified Data.Set as S import Data.Set (Set) import Data.Time (UTCTime, getCurrentTime) diff --git a/src/TorDNSEL/NetworkState/Internals.hs b/src/TorDNSEL/NetworkState/Internals.hs index c4c6b4d..49e8be5 100644 --- a/src/TorDNSEL/NetworkState/Internals.hs +++ b/src/TorDNSEL/NetworkState/Internals.hs @@ -67,7 +67,7 @@ import qualified Control.Exception as E import qualified Data.ByteString.Char8 as B import Data.ByteString.Char8 (ByteString) import Data.List (foldl') -import Data.Maybe (mapMaybe, isJust, fromMaybe) +import Data.Maybe import qualified Data.Map as M import Data.Map (Map) import qualified Data.Set as S diff --git a/src/TorDNSEL/Socks/Internals.hs b/src/TorDNSEL/Socks/Internals.hs index 9f94b45..0367cc3 100644 --- a/src/TorDNSEL/Socks/Internals.hs +++ b/src/TorDNSEL/Socks/Internals.hs @@ -42,7 +42,6 @@ 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.Typeable (Typeable) import Network.Socket (HostAddress) import System.IO (Handle, BufferMode(NoBuffering), hClose, hSetBuffering) diff --git a/src/TorDNSEL/Statistics/Internals.hs b/src/TorDNSEL/Statistics/Internals.hs index d05da2c..8ed2808 100644 --- a/src/TorDNSEL/Statistics/Internals.hs +++ b/src/TorDNSEL/Statistics/Internals.hs @@ -26,7 +26,7 @@ import qualified Control.Exception as E import Control.Monad (when, forever) import Control.Monad.Fix (fix) import qualified Data.ByteString.Char8 as B -import Data.Maybe (isJust, isNothing) +import Data.Maybe import qualified Data.Set as S import Network.Socket (accept, socketToHandle, Socket) import System.IO (hClose, IOMode(ReadWriteMode)) @@ -118,7 +118,7 @@ startStatsServer listenSock = do let newHandlers = S.delete tid (handlers s) case terminateReason s of -- all the handlers have finished, so let's exit - Just exitReason | S.null newHandlers -> exit exitReason + Just reason | S.null newHandlers -> exit reason _ -> loop s { handlers = newHandlers } | isAbnormal reason -> exit reason | otherwise -> loop s diff --git a/src/TorDNSEL/TorControl/Internals.hs b/src/TorDNSEL/TorControl/Internals.hs index 7e0b8f1..58c64ef 100644 --- a/src/TorDNSEL/TorControl/Internals.hs +++ b/src/TorDNSEL/TorControl/Internals.hs @@ -145,10 +145,9 @@ import Control.Applicative 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.List (find) import qualified Data.Map as M -import Data.Maybe (fromMaybe, maybeToList, listToMaybe, isNothing, isJust) +import Data.Maybe import qualified Data.Sequence as S import Data.Sequence ((<|), ViewR((:>)), viewr) import Data.Time (UTCTime, TimeZone, localTimeToUTC, getCurrentTimeZone) diff --git a/src/TorDNSEL/Util.hsc b/src/TorDNSEL/Util.hsc index 6bbffc3..51c7664 100644 --- a/src/TorDNSEL/Util.hsc +++ b/src/TorDNSEL/Util.hsc @@ -109,25 +109,19 @@ module TorDNSEL.Util ( import Control.Arrow ((&&&), first, second) import Control.Applicative +import Control.Monad import qualified Control.Exception as E -import Control.Monad.Error - (Error(..), MonadError(..), MonadTrans(..), MonadIO(..)) +import Control.Monad.Error (Error(..), MonadError(..), MonadTrans(..), MonadIO(..)) import qualified Control.Monad.State as State -import Control.Monad.State - (MonadState, liftM, liftM2, zipWithM_, when, unless, guard, MonadPlus(..)) -import Data.Array.ST (runSTUArray, newArray_, readArray, writeArray) -import Data.Array.Unboxed ((!)) +import Control.Monad.State (MonadState) import Data.Bits ((.&.), (.|.), shiftL, shiftR) import Data.Char (intToDigit, showLitChar, isPrint, isControl, chr, ord, digitToInt, isAscii) -import Data.Dynamic (Dynamic) import Data.List (foldl', intersperse) -import Data.Maybe (mapMaybe) import Data.Monoid import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Internal as B (c2w) -import qualified Data.ByteString as B (hGetSome) import Data.ByteString (ByteString) import qualified Data.Map as M import Data.Ratio (numerator, denominator, (%)) @@ -143,7 +137,6 @@ import System.Directory (doesFileExist, removeFile) import System.Environment (getProgName) import System.Exit (exitWith, ExitCode) import System.IO (Handle, hPutStr) -import System.IO.Error (isEOFError) import System.Posix.Files (setFileMode) import System.Posix.Types (FileMode) import Text.Printf (printf) diff --git a/tordnsel.cabal b/tordnsel.cabal index 50e7f40..827256e 100644 --- a/tordnsel.cabal +++ b/tordnsel.cabal @@ -59,7 +59,7 @@ Other-Modules: TorDNSEL.Config HS-Source-Dirs: src Includes: sys/types.h, unistd.h, sysexits.h, netinet/in.h, openssl/rand.h Extra-Libraries: crypto -GHC-Options: -O2 -funbox-strict-fields -Wall -Werror +GHC-Options: -O2 -funbox-strict-fields -fno-warn-unused-do-bind -Wall -Werror CPP-Options: -DVERSION="0.1.1-dev" Extensions: FlexibleContexts FlexibleInstances

1 0

[tordnsel/master] some monadic utilities
by arlo＠torproject.org 16 Apr '16

16 Apr '16

commit edc8c858a736c8b513b90cf2e0a7dd187ab5c2af Author: David Kaloper <david(a)numm.org> Date: Sat Sep 21 19:13:02 2013 +0200 some monadic utilities --- src/TorDNSEL/Config/Internals.hs | 2 +- src/TorDNSEL/DNS/Internals.hs | 2 +- src/TorDNSEL/ExitTest/Server/Internals.hs | 2 +- src/TorDNSEL/Statistics/Internals.hs | 2 +- src/TorDNSEL/TorControl/Internals.hs | 3 ++- src/TorDNSEL/Util.hsc | 22 +++++++++++----------- 6 files changed, 17 insertions(+), 16 deletions(-) diff --git a/src/TorDNSEL/Config/Internals.hs b/src/TorDNSEL/Config/Internals.hs index d93da96..4b60db7 100644 --- a/src/TorDNSEL/Config/Internals.hs +++ b/src/TorDNSEL/Config/Internals.hs @@ -48,7 +48,7 @@ import Control.Arrow ((***), second) import Control.Concurrent.Chan import Control.Concurrent.MVar import qualified Control.Exception as E -import Control.Monad (liftM, liftM2, ap) +import Control.Monad (liftM, liftM2, ap, forever) import Control.Monad.Error (MonadError(..)) import Control.Monad.Fix (fix) import Data.Char (isSpace, toLower) diff --git a/src/TorDNSEL/DNS/Internals.hs b/src/TorDNSEL/DNS/Internals.hs index 91b2391..76002d8 100644 --- a/src/TorDNSEL/DNS/Internals.hs +++ b/src/TorDNSEL/DNS/Internals.hs @@ -59,7 +59,7 @@ module TorDNSEL.DNS.Internals ( ) where import qualified Control.Exception as E -import Control.Monad (when, unless, replicateM, liftM2, liftM3, forM) +import Control.Monad (when, unless, replicateM, liftM2, liftM3, forM, forever) import qualified Control.Monad.State as S import Control.Monad.Trans (lift) import Control.DeepSeq diff --git a/src/TorDNSEL/ExitTest/Server/Internals.hs b/src/TorDNSEL/ExitTest/Server/Internals.hs index 0d43db3..8f9a872 100644 --- a/src/TorDNSEL/ExitTest/Server/Internals.hs +++ b/src/TorDNSEL/ExitTest/Server/Internals.hs @@ -24,7 +24,7 @@ import Prelude hiding (log) import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan, isEmptyChan) import Control.Concurrent.QSemN (QSemN, newQSemN, waitQSemN, signalQSemN) import qualified Control.Exception as E -import Control.Monad (when, forM, foldM) +import Control.Monad (when, forM, foldM, forever) import Control.Monad.Fix (fix) import Control.Monad.Trans (lift) import Control.Applicative diff --git a/src/TorDNSEL/Statistics/Internals.hs b/src/TorDNSEL/Statistics/Internals.hs index 3932156..d05da2c 100644 --- a/src/TorDNSEL/Statistics/Internals.hs +++ b/src/TorDNSEL/Statistics/Internals.hs @@ -23,7 +23,7 @@ import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) import Control.Concurrent.MVar (MVar, newMVar, modifyMVar_, readMVar) import Control.Concurrent.QSem (QSem, newQSem, waitQSem, signalQSem) import qualified Control.Exception as E -import Control.Monad (when) +import Control.Monad (when, forever) import Control.Monad.Fix (fix) import qualified Data.ByteString.Char8 as B import Data.Maybe (isJust, isNothing) diff --git a/src/TorDNSEL/TorControl/Internals.hs b/src/TorDNSEL/TorControl/Internals.hs index 39bb21f..254d6b1 100644 --- a/src/TorDNSEL/TorControl/Internals.hs +++ b/src/TorDNSEL/TorControl/Internals.hs @@ -137,10 +137,11 @@ import Control.Concurrent.Chan (newChan, readChan, writeChan) import Control.Concurrent.MVar (MVar, newMVar, newEmptyMVar, takeMVar, tryPutMVar, withMVar, modifyMVar_) import qualified Control.Exception as E -import Control.Monad (when, unless, liftM, mzero, mplus) +import Control.Monad (when, unless, liftM, mzero, mplus, forever) import Control.Monad.Error (MonadError(..)) import Control.Monad.Fix (fix) import Control.Monad.State (StateT(StateT), get, put, lift, evalStateT) +import Control.Applicative import qualified Data.ByteString.Char8 as B import Data.ByteString (ByteString) import Data.Char (isSpace, isAlphaNum, isDigit, isAlpha, toLower) diff --git a/src/TorDNSEL/Util.hsc b/src/TorDNSEL/Util.hsc index 1cf59b2..5cea0bb 100644 --- a/src/TorDNSEL/Util.hsc +++ b/src/TorDNSEL/Util.hsc @@ -43,9 +43,9 @@ module TorDNSEL.Util ( , swap , partitionEither , whenJust - , forever , untilM , untilM_ + , muntil , inet_htoa , encodeBase16 , split @@ -293,20 +293,20 @@ partitionEither (Right x:xs) = (x :) `second` partitionEither xs whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenJust = flip . maybe . return $ () --- | Repeat an 'IO' action forever. -forever :: IO a -> IO () -forever = sequence_ . repeat - -- | Repeat an 'IO' action until a predicate is satisfied, collecting the -- results into a list. The predicate is evaluated before the 'IO' action. -untilM :: IO Bool -> IO a -> IO [a] -untilM p io = loop where loop = do p' <- p - if p' then return [] - else liftM2 (:) io loop +untilM :: Monad m => m Bool -> m a -> m [a] +untilM p io = p >>= \p' -> + if p' then return [] else liftM2 (:) io $ untilM p io -- | Like 'untilM', but ignoring the results of the 'IO' action. -untilM_ :: IO Bool -> IO a -> IO () -untilM_ p io = loop where loop = p >>= flip unless (io >> loop) +untilM_ :: Monad m => m Bool -> m a -> m () +untilM_ p io = p >>= (`unless` (io >> untilM_ p io)) + +-- | Like 'untilM', but the predicate is not monadic. +muntil :: Monad m => (a -> Bool) -> m a -> m [a] +muntil p a = a >>= \a' -> + if p a' then return [] else (a':) `liftM` muntil p a -- | Convert an IPv4 address to a 'String' in dotted-quad form. inet_htoa :: HostAddress -> String

1 0

[tordnsel/master] drop Util.splitByDelimiter
by arlo＠torproject.org 16 Apr '16

16 Apr '16

commit 143df1edcb7f54ebe3e9d61e0f9b2a7654e5d464 Author: David Kaloper <david(a)numm.org> Date: Wed Oct 16 18:57:22 2013 +0200 drop Util.splitByDelimiter --- .gitignore | 1 + src/TorDNSEL/Util.hsc | 15 +-------------- 2 files changed, 2 insertions(+), 14 deletions(-) diff --git a/.gitignore b/.gitignore index 84ca43d..87cfc48 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ dist/ +local/ .cabal-sandbox/ cabal.sandbox.config diff --git a/src/TorDNSEL/Util.hsc b/src/TorDNSEL/Util.hsc index 51c7664..f866eb9 100644 --- a/src/TorDNSEL/Util.hsc +++ b/src/TorDNSEL/Util.hsc @@ -1,7 +1,5 @@ {-# LANGUAGE ForeignFunctionInterface, OverlappingInstances, UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans -Wwarn #-} --- ^^^^^^ --- XXX: findSubstrings is deprecated +{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | @@ -63,7 +61,6 @@ module TorDNSEL.Util ( , inBoundsOf , htonl , ntohl - , splitByDelimiter , showUTCTime -- * Conduit utilities @@ -429,16 +426,6 @@ frameC delim = loop $ B.pack "" where (h, t) | B.null t -> loop h | otherwise -> h <$ C.leftover (B.drop (B.length delim) t) --- | Split @bs@ into pieces delimited by @delimiter@, consuming the delimiter. --- The result for overlapping delimiters is undefined. -splitByDelimiter :: ByteString -> ByteString -> [ByteString] -splitByDelimiter delimiter bs = subst (-len : B.findSubstrings delimiter bs) - where - subst (x:xs@(y:_)) = B.take (y-x-len) (B.drop (x+len) bs) : subst xs - subst [x] = [B.drop (x+len) bs] - subst [] = error "splitByDelimiter: empty list" - len = B.length delimiter - -- | Convert a 'UTCTime' to a string in ISO 8601 format. showUTCTime :: UTCTime -> String showUTCTime time = printf "%s %02d:%02d:%s" date hours mins secStr'

1 0

[tordnsel/master] Control.Concurrent: block/unblock -> mask/restore
by arlo＠torproject.org 16 Apr '16

16 Apr '16

commit 848228a5f1f043e5c10e55a0b9715e9c0d452535 Author: David Kaloper <david(a)numm.org> Date: Wed Aug 28 00:05:19 2013 +0200 Control.Concurrent: block/unblock -> mask/restore --- src/TorDNSEL/Control/Concurrent/Future.hs | 4 ++-- src/TorDNSEL/Control/Concurrent/Link/Internals.hs | 18 +++++++++++------- 2 files changed, 13 insertions(+), 9 deletions(-) diff --git a/src/TorDNSEL/Control/Concurrent/Future.hs b/src/TorDNSEL/Control/Concurrent/Future.hs index 4b5c6ac..8256477 100644 --- a/src/TorDNSEL/Control/Concurrent/Future.hs +++ b/src/TorDNSEL/Control/Concurrent/Future.hs @@ -34,8 +34,8 @@ spawn :: IO a -> IO (Future a) spawn io = do mv <- newEmptyMVar callingThread <- myThreadId - forkLinkIO . E.block $ do - r <- either (Left . extractReason) (Right . id) `fmap` E.try (E.unblock io) + forkLinkIO . E.mask $ \restore -> do + r <- either (Left . extractReason) (Right . id) `fmap` E.try (restore io) putMVar mv r unlinkThread callingThread either exit (const $ return ()) r diff --git a/src/TorDNSEL/Control/Concurrent/Link/Internals.hs b/src/TorDNSEL/Control/Concurrent/Link/Internals.hs index 7b614b9..5c3f8b2 100644 --- a/src/TorDNSEL/Control/Concurrent/Link/Internals.hs +++ b/src/TorDNSEL/Control/Concurrent/Link/Internals.hs @@ -32,6 +32,7 @@ import Control.Concurrent.MVar import GHC.Conc (setUncaughtExceptionHandler) import System.Exit (ExitCode) import Control.Monad (unless) +import Data.Functor import qualified Data.Foldable as F import qualified Data.Map as M import qualified Data.Set as S @@ -142,7 +143,7 @@ defaultSignal dst src e = E.throwTo dst $ ExitSignal src e withLinksDo :: IO a -> IO () withLinksDo io = E.mask $ \restore -> do setUncaughtExceptionHandler . const . return $ () - main <- C.myThreadId + main <- C.myThreadId mainId <- Tid `fmap` newUnique let initialState = ThreadState { ident = mainId @@ -158,7 +159,7 @@ withLinksDo io = E.mask $ \restore -> do , state = M.insert main initialState (state tm) } -- Don't bother propagating signals from the main thread -- since it's about to exit. - (restore io >> return ()) `E.catch` \(e :: E.SomeException) -> + (() <$ restore io) `E.catch` \(e :: E.SomeException) -> case extractReason e of NormalExit -> return () AbnormalExit (E.fromException -> Just e') -> @@ -178,8 +179,8 @@ forkLinkIO :: IO a -> IO ThreadId forkLinkIO = forkLinkIO' True forkLinkIO' :: Bool -> IO a -> IO ThreadId -forkLinkIO' shouldLink io = E.block $ do - parent <- C.myThreadId +forkLinkIO' shouldLink io = E.mask $ \restore -> do + parent <- C.myThreadId childId <- Tid `fmap` newUnique modifyMVar_ threadMap $ \tm -> do #ifdef DEBUG @@ -187,7 +188,9 @@ forkLinkIO' shouldLink io = E.block $ do #endif child <- forkHandler $ do child <- C.myThreadId - e <- either extractReason (const NormalExit) `fmap` E.try (E.unblock io) + e <- either (extractReason :: E.SomeException -> ExitReason) + (const NormalExit) + `fmap` E.try (restore io) -- modifyMVar is interruptible (a misfeature in this case), so an async -- exception could be delivered here. Forking an anonymous thread should -- avoid this race since nobody can throwTo it. @@ -234,9 +237,10 @@ forkLinkIO' shouldLink io = E.block $ do withMVar threadMap assertThreadMap #endif return childId + where - forkHandler = C.forkIO . ignore . (>> return ()) . E.block - ignore = E.handle $ \(e :: E.SomeException) -> return () + forkHandler io = E.mask_ . C.forkIO $ + (() <$ io) `E.catch` \(e :: E.SomeException) -> return () -- | 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

1 0

[tordnsel/master] stub hGetLine
by arlo＠torproject.org 16 Apr '16

16 Apr '16

commit d3976bd028ca1a476e24fea1d7d67acbd545592e Author: David Kaloper <david(a)numm.org> Date: Thu Aug 8 03:14:21 2013 +0200 stub hGetLine This function knows *way* too much about the IO manager. Go to sleep, Frankenstein. --- src/TorDNSEL/Util.hsc | 201 +++++++++++++++++++++++++------------------------- 1 file changed, 101 insertions(+), 100 deletions(-) diff --git a/src/TorDNSEL/Util.hsc b/src/TorDNSEL/Util.hsc index 57ada86..13303ac 100644 --- a/src/TorDNSEL/Util.hsc +++ b/src/TorDNSEL/Util.hsc @@ -363,106 +363,107 @@ foreign import ccall unsafe "ntohl" ntohl :: Word32 -> Word32 -- bytes. If EOF is encountered, return the bytes preceding it. The handle -- should be in 'LineBuffering' mode. hGetLine :: Handle -> ByteString -> Int -> IO ByteString -hGetLine h eol maxLen | B.null eol = B.hGet h maxLen -hGetLine h eol(a)(B.PS _ _ eolLen) maxLen - = wantReadableHandle "TorDNSEL.Util.hGetLine" h $ \handle_ -> do - case haBufferMode handle_ of - NoBuffering -> error "no buffering" - _other -> hGetLineBuffered handle_ - - where - hGetLineBuffered handle_ = do - let ref = haBuffer handle_ - buf <- readIORef ref - hGetLineBufferedLoop handle_ ref buf 0 0 [] - - hGetLineBufferedLoop handle_ ref - buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } !len !eolIx xss = do - (new_eolIx,off) <- findEOL eolIx r w raw - let new_len = len + off - r - - if maxLen > 0 && new_len - new_eolIx > maxLen - -- If the line length exceeds maxLen, return a partial line. - then do - let maxOff = off - (new_len - maxLen) - writeIORef ref buf{ bufRPtr = maxOff } - mkBigPS . (:xss) =<< mkPS raw r maxOff - else if new_eolIx == eolLen - -- We have a complete line; strip the EOL sequence and return it. - then do - if w == off - then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 } - else writeIORef ref buf{ bufRPtr = off } - if eolLen <= off - r - then mkBigPS . (:xss) =<< mkPS raw r (off - eolLen) - else fmap stripEOL . mkBigPS . (:xss) =<< mkPS raw r off - else do - xs <- mkPS raw r off - maybe_buf <- maybeFillReadBuffer (haFD handle_) True - (haIsStream handle_) buf{ bufWPtr=0, bufRPtr=0 } - case maybe_buf of - -- Nothing indicates we caught an EOF, and we may have a - -- partial line to return. - Nothing -> do - writeIORef ref buf{ bufRPtr=0, bufWPtr=0 } - if new_len > 0 - then mkBigPS (xs:xss) - else ioe_EOF - Just new_buf -> - hGetLineBufferedLoop handle_ ref new_buf new_len new_eolIx - (xs:xss) - - maybeFillReadBuffer fd is_line is_stream buf - = catch (Just `fmap` fillReadBuffer fd is_line is_stream buf) - (\e -> if isEOFError e then return Nothing else ioError e) - - findEOL eolIx - | eolLen == 1 = findEOLChar (B.w2c $ B.unsafeHead eol) - | otherwise = findEOLSeq eolIx - - findEOLChar eolChar r w raw - | r == w = return (0, r) - | otherwise = do - (!c,!r') <- readCharFromBuffer raw r - if c == eolChar - then return (1, r') - else findEOLChar eolChar r' w raw - - -- find the end-of-line sequence, if there is one - findEOLSeq !eolIx r w raw - | eolIx == eolLen || r == w = return (eolIx, r) - | otherwise = do - (!c,!r') <- readCharFromBuffer raw r - findEOLSeq (next c eolIx + 1) r' w raw - - -- get the next index into the EOL sequence we should match against - next !c !i = if i >= 0 && c /= eolIndex i then next c (table ! i) else i - - eolIndex = B.w2c . B.unsafeIndex eol - - -- build a match table for the Knuth-Morris-Pratt algorithm - table = runSTUArray (do - arr <- newArray_ (0, if eolLen == 1 then 1 else eolLen - 1) - zipWithM_ (writeArray arr) [0,1] [-1,0] - loop arr 2 0) - where - loop arr !t !p - | t >= eolLen = return arr - | eolIndex (t - 1) == eolIndex p - = let p' = p + 1 in writeArray arr t p' >> loop arr (t + 1) p' - | p > 0 = readArray arr p >>= loop arr t - | otherwise = writeArray arr t 0 >> loop arr (t + 1) p - - stripEOL (B.PS p s l) = E.assert (new_len >= 0) . B.copy $ B.PS p s new_len - where new_len = l - eolLen - - mkPS buf start end = B.create len $ \p -> do - B.memcpy_ptr_baoff p buf (fromIntegral start) (fromIntegral len) - return () - where len = end - start - - mkBigPS [ps] = return ps - mkBigPS pss = return $! B.concat (reverse pss) +hGetLine = error "hGetLine" -- XXX STUB +-- hGetLine h eol maxLen | B.null eol = B.hGet h maxLen +-- hGetLine h eol(a)(B.PS _ _ eolLen) maxLen +-- = wantReadableHandle "TorDNSEL.Util.hGetLine" h $ \handle_ -> do +-- case haBufferMode handle_ of +-- NoBuffering -> error "no buffering" +-- _other -> hGetLineBuffered handle_ +-- +-- where +-- hGetLineBuffered handle_ = do +-- let ref = haBuffer handle_ +-- buf <- readIORef ref +-- hGetLineBufferedLoop handle_ ref buf 0 0 [] +-- +-- hGetLineBufferedLoop handle_ ref +-- buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } !len !eolIx xss = do +-- (new_eolIx,off) <- findEOL eolIx r w raw +-- let new_len = len + off - r +-- +-- if maxLen > 0 && new_len - new_eolIx > maxLen +-- -- If the line length exceeds maxLen, return a partial line. +-- then do +-- let maxOff = off - (new_len - maxLen) +-- writeIORef ref buf{ bufRPtr = maxOff } +-- mkBigPS . (:xss) =<< mkPS raw r maxOff +-- else if new_eolIx == eolLen +-- -- We have a complete line; strip the EOL sequence and return it. +-- then do +-- if w == off +-- then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 } +-- else writeIORef ref buf{ bufRPtr = off } +-- if eolLen <= off - r +-- then mkBigPS . (:xss) =<< mkPS raw r (off - eolLen) +-- else fmap stripEOL . mkBigPS . (:xss) =<< mkPS raw r off +-- else do +-- xs <- mkPS raw r off +-- maybe_buf <- maybeFillReadBuffer (haFD handle_) True +-- (haIsStream handle_) buf{ bufWPtr=0, bufRPtr=0 } +-- case maybe_buf of +-- -- Nothing indicates we caught an EOF, and we may have a +-- -- partial line to return. +-- Nothing -> do +-- writeIORef ref buf{ bufRPtr=0, bufWPtr=0 } +-- if new_len > 0 +-- then mkBigPS (xs:xss) +-- else ioe_EOF +-- Just new_buf -> +-- hGetLineBufferedLoop handle_ ref new_buf new_len new_eolIx +-- (xs:xss) +-- +-- maybeFillReadBuffer fd is_line is_stream buf +-- = catch (Just `fmap` fillReadBuffer fd is_line is_stream buf) +-- (\e -> if isEOFError e then return Nothing else ioError e) +-- +-- findEOL eolIx +-- | eolLen == 1 = findEOLChar (B.w2c $ B.unsafeHead eol) +-- | otherwise = findEOLSeq eolIx +-- +-- findEOLChar eolChar r w raw +-- | r == w = return (0, r) +-- | otherwise = do +-- (!c,!r') <- readCharFromBuffer raw r +-- if c == eolChar +-- then return (1, r') +-- else findEOLChar eolChar r' w raw +-- +-- -- find the end-of-line sequence, if there is one +-- findEOLSeq !eolIx r w raw +-- | eolIx == eolLen || r == w = return (eolIx, r) +-- | otherwise = do +-- (!c,!r') <- readCharFromBuffer raw r +-- findEOLSeq (next c eolIx + 1) r' w raw +-- +-- -- get the next index into the EOL sequence we should match against +-- next !c !i = if i >= 0 && c /= eolIndex i then next c (table ! i) else i +-- +-- eolIndex = B.w2c . B.unsafeIndex eol +-- +-- -- build a match table for the Knuth-Morris-Pratt algorithm +-- table = runSTUArray (do +-- arr <- newArray_ (0, if eolLen == 1 then 1 else eolLen - 1) +-- zipWithM_ (writeArray arr) [0,1] [-1,0] +-- loop arr 2 0) +-- where +-- loop arr !t !p +-- | t >= eolLen = return arr +-- | eolIndex (t - 1) == eolIndex p +-- = let p' = p + 1 in writeArray arr t p' >> loop arr (t + 1) p' +-- | p > 0 = readArray arr p >>= loop arr t +-- | otherwise = writeArray arr t 0 >> loop arr (t + 1) p +-- +-- stripEOL (B.PS p s l) = E.assert (new_len >= 0) . B.copy $ B.PS p s new_len +-- where new_len = l - eolLen +-- +-- mkPS buf start end = B.create len $ \p -> do +-- B.memcpy_ptr_baoff p buf (fromIntegral start) (fromIntegral len) +-- return () +-- where len = end - start +-- +-- mkBigPS [ps] = return ps +-- mkBigPS pss = return $! B.concat (reverse pss) -- | Split @bs@ into pieces delimited by @delimiter@, consuming the delimiter. -- The result for overlapping delimiters is undefined.

1 0

[tordnsel/master] fix exceptions in TorDNSEL.Control.Concurrent
by arlo＠torproject.org 16 Apr '16

16 Apr '16

commit 7494d418a991eb60b4644169310026336068d634 Author: David Kaloper <david(a)numm.org> Date: Mon Aug 26 04:10:27 2013 +0200 fix exceptions in TorDNSEL.Control.Concurrent --- src/TorDNSEL/Control/Concurrent/Link.hs | 7 +- src/TorDNSEL/Control/Concurrent/Link/Internals.hs | 168 ++++++++++++---------- src/TorDNSEL/Control/Concurrent/Util.hs | 47 +++--- 3 files changed, 121 insertions(+), 101 deletions(-) diff --git a/src/TorDNSEL/Control/Concurrent/Link.hs b/src/TorDNSEL/Control/Concurrent/Link.hs index 98eda78..2c0a05f 100644 --- a/src/TorDNSEL/Control/Concurrent/Link.hs +++ b/src/TorDNSEL/Control/Concurrent/Link.hs @@ -30,15 +30,16 @@ module TorDNSEL.Control.Concurrent.Link ( , withMonitor , exit , throwTo - , throwDynTo , killThread , setTrapExit , unsetTrapExit - , ExitReason + , ExitReason(..) + , exitReason + , isAbnormal + , throwAbnormal , extractReason , fromExitSignal , LinkException(..) - , showLinkException ) where import TorDNSEL.Control.Concurrent.Link.Internals diff --git a/src/TorDNSEL/Control/Concurrent/Link/Internals.hs b/src/TorDNSEL/Control/Concurrent/Link/Internals.hs index cf83cba..7b614b9 100644 --- a/src/TorDNSEL/Control/Concurrent/Link/Internals.hs +++ b/src/TorDNSEL/Control/Concurrent/Link/Internals.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-ignore-asserts #-} ----------------------------------------------------------------------------- @@ -24,15 +25,18 @@ -- #not-home module TorDNSEL.Control.Concurrent.Link.Internals where +import qualified Control.Exception as E import qualified Control.Concurrent as C import Control.Concurrent.MVar (MVar, newMVar, withMVar, modifyMVar, modifyMVar_) -import qualified Control.Exception as E +import GHC.Conc (setUncaughtExceptionHandler) +import System.Exit (ExitCode) import Control.Monad (unless) import qualified Data.Foldable as F import qualified Data.Map as M import qualified Data.Set as S -import Data.Dynamic (Dynamic, fromDynamic, toDyn, Typeable) +-- import Data.Dynamic (Dynamic, fromDynamic, toDyn, Typeable) +import Data.Typeable (Typeable) import Data.List (nub) import Data.Unique (Unique, newUnique) import System.IO (hPutStrLn, hFlush, stderr) @@ -46,6 +50,9 @@ import TorDNSEL.Util newtype ThreadId = Tid Unique deriving (Eq, Ord) +-- ( Else an orphaned Show Unique... ) +instance Show ThreadId where show _ = "#<thread>" + -- | Return the 'ThreadId' of the calling thread. myThreadId :: IO ThreadId myThreadId = do @@ -74,11 +81,17 @@ threadMap :: MVar ThreadMap {-# NOINLINE threadMap #-} threadMap = unsafePerformIO . newMVar $ ThreadMap M.empty M.empty +-- | Erase 'threadMap', making it possible to re-run 'withLinksDo'. For +-- debugging only, as it loses track of threads. +unsafeResetThreadMap :: IO () +unsafeResetThreadMap = + modifyMVar_ threadMap $ const . return $ ThreadMap M.empty M.empty + -- | 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.handle (\(E.AssertionFailed msg) -> putStrLn $ "assertThreadMap: " ++ msg) $ 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))) $ @@ -100,36 +113,35 @@ assertThreadMap tm = -- | An internal type used to transmit the originating 'ThreadId' in an -- asynchronous exception to a linked thread. data ExitSignal = ExitSignal !ThreadId !ExitReason - deriving Typeable - --- | 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 - = (,) tid `fmap` fromDynamic d' + deriving (Show, Typeable) + +instance E.Exception ExitSignal + +-- | Extract the 'ExitReason' from an 'ExitSignal' contained within an +-- exception. If the exception doesn't contain an 'ExitReason', it becomes the +-- exit reason itself. +extractReason :: E.SomeException -> ExitReason +extractReason (E.fromException -> Just (ExitSignal _ e)) = e +extractReason e = AbnormalExit e + +-- | Extract a particular exception type from an 'ExitSignal', if present. +fromExitSignal :: E.Exception e => ExitSignal -> Maybe (ThreadId, e) +fromExitSignal (ExitSignal tid (AbnormalExit e)) + | Just e' <- E.fromException e = Just (tid, e') fromExitSignal _ = 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 _ _ 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 $ () +defaultSignal dst src NormalExit = return () +defaultSignal dst src e = E.throwTo dst $ ExitSignal src e + +-- | Initialize the state supporting links and monitors. 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 :: IO a -> IO () +withLinksDo io = E.mask $ \restore -> do + setUncaughtExceptionHandler . const . return $ () main <- C.myThreadId mainId <- Tid `fmap` newUnique let initialState = ThreadState @@ -146,12 +158,13 @@ withLinksDo showE io = E.block $ do , 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 :: E.SomeException) -> case extractReason e of - Nothing -> return () - Just e'@(E.ExitException _) -> E.throwIO e' - Just e' -> do - hPutStrLn stderr ("*** Exception: " ++ showE e') + NormalExit -> return () + AbnormalExit (E.fromException -> Just e') -> + E.throwIO (e' :: ExitCode) + AbnormalExit e' -> do + hPutStrLn stderr ("*** Exception: " ++ show e') hFlush stderr E.throwIO e' @@ -169,15 +182,19 @@ forkLinkIO' shouldLink io = E.block $ do parent <- C.myThreadId childId <- Tid `fmap` newUnique modifyMVar_ threadMap $ \tm -> do - -- assertThreadMap tm +#ifdef DEBUG + assertThreadMap tm +#endif child <- forkHandler $ do child <- C.myThreadId - e <- either extractReason (const Nothing) `fmap` E.try (E.unblock io) + e <- either extractReason (const NormalExit) `fmap` E.try (E.unblock io) -- modifyMVar is interruptible (a misfeature in this case), so an async -- exception could be delivered here. Forking an anonymous thread should -- avoid this race since nobody can throwTo it. forkHandler $ do - -- withMVar threadMap assertThreadMap +#ifdef DEBUG + withMVar threadMap assertThreadMap +#endif (signalAll,notifyAll) <- modifyMVar threadMap $ \tm1 -> let s = state tm1 M.! child unlinkAll = flip (F.foldl' (flip (child `unlinkFrom`))) (links s) @@ -193,7 +210,9 @@ forkLinkIO' shouldLink io = E.block $ do notifyAll ex = F.mapM_ (forkHandler . ($ ex) . fst) (monitors s) tm1' = tm1 { ids = newIds, state = newState } in tm1' `seq` return (tm1', (signalAll, notifyAll)) - -- withMVar threadMap assertThreadMap +#ifdef DEBUG + withMVar threadMap assertThreadMap +#endif notifyAll e signalAll e @@ -211,11 +230,13 @@ forkLinkIO' shouldLink io = E.block $ do tm { ids = M.insert childId child $ ids tm , state = M.insert child initialState . linkToParent $ state tm } - -- withMVar threadMap assertThreadMap +#ifdef DEBUG + withMVar threadMap assertThreadMap +#endif return childId where forkHandler = C.forkIO . ignore . (>> return ()) . E.block - ignore = E.handle . const . return $ () + ignore = E.handle $ \(e :: E.SomeException) -> return () -- | 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 @@ -225,16 +246,14 @@ forkLinkIO' shouldLink io = E.block $ do linkThread :: ThreadId -> IO () linkThread tid = do me <- C.myThreadId - mbSignalSelf <- modifyMVar threadMap $ \tm -> + mbSignalSelf <- modifyMVar threadMap $ \tm -> return $! case M.lookup tid (ids tm) of Just tid' - | tid' == me -> return (tm, Nothing) - | otherwise -> let tm' = tm { state = linkTogether me tid' $ state tm } - 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) + | tid' == me -> (tm, Nothing) + | otherwise -> (tm', Nothing) + where !tm' = tm { state = linkTogether me tid' $ state tm } + Nothing -> (tm, Just . signal s tid $ exitReason NonexistentThread) + where s = state tm M.! me whenJust mbSignalSelf id where linkTogether x y = (x `linkTo` y) . (y `linkTo` x) @@ -258,9 +277,22 @@ linkTo, unlinkFrom :: C.ThreadId -> C.ThreadId -> StateModifier data Monitor = Monitor !ThreadId !Unique deriving (Eq, Ord) --- | 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 +-- | The reason a thread was terminated. +data ExitReason = NormalExit | AbnormalExit E.SomeException + deriving (Show) + +-- | Construct an 'ExitReason' from any 'E.Exception'. +exitReason :: E.Exception e => e -> ExitReason +exitReason = AbnormalExit . E.toException + +isAbnormal :: ExitReason -> Bool +isAbnormal (AbnormalExit _) = True +isAbnormal _ = False + +-- | Check the exit reason and re-throw it if it's an 'AbnormalExit'. +throwAbnormal :: ExitReason -> IO () +throwAbnormal NormalExit = return () +throwAbnormal (AbnormalExit e) = E.throwIO e -- | Start monitoring the given thread, invoking an 'IO' action with the -- 'ExitReason' when the thread dies. Return a handle to the monitor, which can @@ -271,20 +303,19 @@ monitorThread :: ThreadId -> (ExitReason -> IO ()) -> IO Monitor monitorThread tid notify = do me <- C.myThreadId mon@(Monitor _ monId) <- Monitor tid `fmap` newUnique - let cleanup tid' = adjust' (\ts -> - ts { ownedMons = S.delete (tid', monId) (ownedMons ts) }) me + let cleanup tid' = flip adjust' me $ \ts -> + ts { ownedMons = S.delete (tid', monId) (ownedMons ts) } addMon tid' ts = ts { monitors = M.insert monId (notify, cleanup tid') (monitors ts) } addOwned tid' ts = ts {ownedMons = S.insert (tid', monId) (ownedMons ts)} - exists <- modifyMVar threadMap $ \tm -> + exists <- modifyMVar threadMap $ \tm -> return $! case M.lookup tid (ids tm) of - Nothing -> return (tm, False) - Just tid' -> - let tm' = tm { state = adjust' (addMon tid') tid' . - adjust' (addOwned tid') me $ state tm } - in tm' `seq` return (tm', True) + Nothing -> (tm, False) + Just tid' -> (tm', True) + where !tm' = tm { state = adjust' (addMon tid') tid' . + adjust' (addOwned tid') me $ state tm } unless exists $ - notify . Just . E.DynException . toDyn $ NonexistentThread + notify $ exitReason NonexistentThread return mon -- | Cancel a monitor, if it is currently active. @@ -310,10 +341,10 @@ 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.throwIO . (`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 +-- is 'NormalExit', the signal will be ignored unless the target thread is trapping -- signals. Otherwise, the target thread will either exit with the same -- 'ExitReason' or be notified of the signal depending on whether it is trapping -- signals. If the target thread doesn't exist, do nothing. @@ -324,25 +355,20 @@ 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.throwIO $ 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 whenJust mbSignal ($ e) --- | A variant of 'throwTo' for dynamically typed 'ExitReason's. -throwDynTo :: Typeable a => ThreadId -> a -> IO () -throwDynTo tid = throwTo tid . Just . E.DynException . toDyn - -- | Send an untrappable exit signal to a thread, if it exists. killThread :: ThreadId -> IO () 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' $ ExitSignal (ident (state tm M.! me)) + (exitReason E.ThreadKilled) whenJust mbSignal id -- | Redirect exit signals destined for the calling thread to the given 'IO' @@ -367,6 +393,4 @@ data LinkException = NonexistentThread -- ^ instance Show LinkException where show NonexistentThread = "Attempt to link to nonexistent thread" --- | Boilerplate conversion of a dynamically typed 'LinkException' to a string. -showLinkException :: Dynamic -> Maybe String -showLinkException = fmap (show :: LinkException -> String) . fromDynamic +instance E.Exception LinkException diff --git a/src/TorDNSEL/Control/Concurrent/Util.hs b/src/TorDNSEL/Control/Concurrent/Util.hs index 1defc31..a7c2a65 100644 --- a/src/TorDNSEL/Control/Concurrent/Util.hs +++ b/src/TorDNSEL/Control/Concurrent/Util.hs @@ -13,7 +13,8 @@ module TorDNSEL.Control.Concurrent.Util where import qualified Control.Exception as E -import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar, tryPutMVar) +import Data.Functor ( (<$) ) +import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar, tryPutMVar) import Data.Dynamic (Dynamic) import Data.Maybe (isJust) import System.Timeout @@ -51,10 +52,9 @@ terminateThread mbWait tid terminate = do sendSyncMessage :: (IO () -> IO ()) -> ThreadId -> IO () sendSyncMessage sendMsg tid = do err <- newEmptyMVar - let putResponse = (>> return ()) . tryPutMVar err - withMonitor tid putResponse $ do - sendMsg $ putResponse Nothing - takeMVar err >>= flip whenJust E.throwIO + withMonitor tid (tryPutMVar_ err) $ do + sendMsg $ tryPutMVar_ err NormalExit + takeMVar err >>= throwAbnormal -- | Send a message parameterized by a reply action to @tid@, returning the -- response value. If the thread exits before responding to the message, throw @@ -62,19 +62,13 @@ sendSyncMessage sendMsg tid = do call :: ((a -> IO ()) -> IO ()) -> ThreadId -> IO a call sendMsg tid = do mv <- newEmptyMVar - let putResponse = (>> return ()) . tryPutMVar mv - withMonitor tid (putResponse . Left) $ do - sendMsg $ putResponse . Right + withMonitor tid (tryPutMVar_ mv . Left) $ do + sendMsg $ tryPutMVar_ mv . Right response <- takeMVar mv case response of - Left Nothing -> E.throwDyn NonexistentThread - Left (Just e) -> E.throwIO e - Right r -> return r - --- | A wrapper for using 'showException' with 'ExitReason's. -showExitReason :: [Dynamic -> Maybe String] -> ExitReason -> String -showExitReason _ Nothing = "Normal exit" -showExitReason fs (Just e) = showException (showLinkException:fs) e + Left NormalExit -> E.throwIO NonexistentThread + Left (AbnormalExit e) -> E.throwIO e + Right r -> return r -- | Invoke the given 'IO' action in a new thread, passing it an action to -- invoke when it has successfully started. Link the new thread to the calling @@ -83,14 +77,13 @@ showExitReason fs (Just e) = showException (showLinkException:fs) e startLink :: (IO () -> IO a) -> IO ThreadId startLink io = do sync <- newEmptyMVar - err <- newEmptyMVar - let putResponse = (>> return ()) . tryPutMVar err + err <- newEmptyMVar tid <- forkLinkIO $ do takeMVar sync - io (putResponse Nothing) - withMonitor tid putResponse $ do + io $ tryPutMVar_ err NormalExit + withMonitor tid (tryPutMVar_ err) $ do putMVar sync () - takeMVar err >>= flip whenJust E.throwIO + takeMVar err >>= throwAbnormal return tid -- | Invoke the given 'IO' action in a temporary thread (linked to the calling @@ -100,15 +93,17 @@ startLink io = do tryForkLinkIO :: Thread a => IO a -> IO (Either ExitReason a, ThreadId) tryForkLinkIO io = do sync <- newEmptyMVar - response <- newEmptyMVar - let putResponse = (>> return ()) . tryPutMVar response + resp <- newEmptyMVar intermediate <- forkLinkIO $ do takeMVar sync - io >>= putResponse . Right - r <- withMonitor intermediate (putResponse . Left) $ do + io >>= tryPutMVar_ resp . Right + r <- withMonitor intermediate (tryPutMVar_ resp . Left) $ do putMVar sync () E.block $ do - r <- takeMVar response + r <- takeMVar resp either (const $ return ()) (linkThread . threadId) r return r return (r, intermediate) + +tryPutMVar_ :: MVar a -> a -> IO () +tryPutMVar_ = ((() <$) .) . tryPutMVar

1 0

[tordnsel/master] precise parsing exceptions
by arlo＠torproject.org 16 Apr '16

16 Apr '16

commit 243f8660bae4c3cd30fe16ad0180e71b78070179 Author: David Kaloper <david(a)numm.org> Date: Sat Aug 24 03:40:24 2013 +0200 precise parsing exceptions --- src/TorDNSEL/DNS/Internals.hs | 9 ++++++--- src/TorDNSEL/Socks/Internals.hs | 10 ++++++---- 2 files changed, 12 insertions(+), 7 deletions(-) diff --git a/src/TorDNSEL/DNS/Internals.hs b/src/TorDNSEL/DNS/Internals.hs index 0eed2be..91b2391 100644 --- a/src/TorDNSEL/DNS/Internals.hs +++ b/src/TorDNSEL/DNS/Internals.hs @@ -165,10 +165,13 @@ encodeMessage :: Message -> Packet encodeMessage = Packet . B.concat . L.toChunks . runPutMessage . putPacket -- | Decode a DNS message strictly, returning @'Just' _@ if parsing succeeded. +-- +-- XXX We just fight lazy decoding here -- we should replace `binary` with +-- `cereal`. ( See `Socks`. ) decodeMessage :: Packet -> IO (Maybe Message) -decodeMessage pkt = do - r <- E.tryJust syncExceptions (E.evaluate $!! unsafeDecodeMessage pkt) - return $ either (const Nothing) Just r +decodeMessage pkt = + ( E.evaluate $ Just $!! unsafeDecodeMessage pkt ) + `E.catch` \(E.ErrorCall _) -> return Nothing -- | Lazily decode a DNS message. If parsing fails, the result will contain an -- exceptional value at some level. diff --git a/src/TorDNSEL/Socks/Internals.hs b/src/TorDNSEL/Socks/Internals.hs index c5ce474..7999b91 100644 --- a/src/TorDNSEL/Socks/Internals.hs +++ b/src/TorDNSEL/Socks/Internals.hs @@ -142,11 +142,13 @@ encodeRequest = B.concat . L.toChunks . runPut . putRequest putWord8 0 -- | Decode a Socks4 response. +-- +-- XXX We just fight lazy decoding here -- we should replace `binary` with +-- `cereal`. ( See `DNS`. ) decodeResponse :: ByteString -> IO (Maybe Response) -decodeResponse resp = do - r <- E.tryJust syncExceptions - (E.evaluate $!! runGet getResponse (L.fromChunks [resp])) - return $ either (const Nothing) Just r +decodeResponse resp = + ( E.evaluate $ Just $!! runGet getResponse (L.fromChunks [resp]) ) + `E.catch` \(E.ErrorCall _) -> return Nothing where getResponse = do 0 <- getWord8

1 0

[tordnsel/master] start centralizing sync/async exn classification
by arlo＠torproject.org 16 Apr '16

16 Apr '16

commit a52e0fe72ae2f9a9f4c0ce0ec7b8092c5ad15d40 Author: David Kaloper <david(a)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

1 0

[translation/torbutton-torbuttondtd] Update translations for torbutton-torbuttondtd
by translation＠torproject.org 16 Apr '16

16 Apr '16

commit a262be46a628af775ccccd9eee12687c503a8f07 Author: Translation commit bot <translation(a)torproject.org> Date: Sat Apr 16 00:15:53 2016 +0000 Update translations for torbutton-torbuttondtd --- zh_HK/torbutton.dtd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/zh_HK/torbutton.dtd b/zh_HK/torbutton.dtd index 40696a7..39570a8 100644 --- a/zh_HK/torbutton.dtd +++ b/zh_HK/torbutton.dtd @@ -86,7 +86,7 @@ <!ENTITY torbutton.prefs.non_tor "非Tor洋蔥路由"> <!ENTITY torbutton.prefs.restore_tor "啟動還原工作階段時，將Tor洋蔥路由狀態設定成："> <!ENTITY torbutton.prefs.startup_tor "啟動瀏覽器時，將Tor洋蔥路由狀態設定成："> -<!ENTITY torbutton.prefs.reload_crashed_jar "Firefox撞毁時重新載入Jar╱清理Cookies (建議)"> +<!ENTITY torbutton.prefs.reload_crashed_jar "Firefox程式崩塌時重新載入Jar╱清理Cookies (建議)"> <!ENTITY torbutton.prefs.dual_cookie_jars "將Tor洋蔥路由同非Tor洋蔥路由嘅Cookie同時存放喺受保護嘅Jar內(危險)"> <!ENTITY torbutton.prefs.clear_http_auth "清除http驗證工作階段(建議)"> <!ENTITY torbutton.prefs.block_js_history "隔離瀏覽歷程記錄嘅存取到Tor洋蔥路由狀態(重要)">

1 0