tor-commits April 2016

tor-commits@lists.torproject.org

20 participants
1645 discussions

[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] 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] 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] 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] 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] port to wheezy
by arlo＠torproject.org 16 Apr '16

16 Apr '16

commit d3d8c70cac03f18610f74bb658ff8ff9535b8147 Author: David Kaloper <david(a)numm.org> Date: Mon Nov 4 05:56:45 2013 +0100 port to wheezy --- src/TorDNSEL/ExitTest/Request.hs | 1 - src/TorDNSEL/TorControl/Internals.hs | 9 +++++---- src/TorDNSEL/Util.hsc | 20 +++++++++++++------- tordnsel.cabal | 9 +++++---- 4 files changed, 23 insertions(+), 16 deletions(-) diff --git a/src/TorDNSEL/ExitTest/Request.hs b/src/TorDNSEL/ExitTest/Request.hs index affa6b8..5d74ae3 100644 --- a/src/TorDNSEL/ExitTest/Request.hs +++ b/src/TorDNSEL/ExitTest/Request.hs @@ -30,7 +30,6 @@ import Control.Arrow ((***)) import Control.Applicative import Control.Monad import Data.Monoid -import Data.Maybe import qualified Data.ByteString.Char8 as B import Data.Char (isSpace, toLower) import qualified Data.Map as M diff --git a/src/TorDNSEL/TorControl/Internals.hs b/src/TorDNSEL/TorControl/Internals.hs index 43b6d19..551593a 100644 --- a/src/TorDNSEL/TorControl/Internals.hs +++ b/src/TorDNSEL/TorControl/Internals.hs @@ -839,14 +839,13 @@ c_replies = c_lines_any =$= line0 [] line0 acc = await >>= return () `maybe` \line -> do let (code, (typ, text)) = B.splitAt 1 `second` B.splitAt 3 line - code' <- either (monadThrow . ProtocolError) return $ - parseReplyCode code + code' <- either throwProtoError return $ parseReplyCode code case () of _ | typ == B.pack "-" -> line0 (acc' []) | typ == B.pack "+" -> rest [] >>= line0 . acc' | typ == B.pack " " -> yield (reverse $ acc' []) >> line0 [] - | otherwise -> monadThrow $ - ProtocolError $ cat "Malformed reply line type " (esc 1 typ) '.' + | otherwise -> throwProtoError $ + cat "Malformed reply line type " (esc 1 typ) '.' where acc' xs = Reply code' text xs : acc @@ -857,6 +856,8 @@ c_replies = c_lines_any =$= line0 [] | line == B.pack "." -> return $ reverse acc | otherwise -> rest (line:acc) + throwProtoError = lift . E.throw . ProtocolError + -------------------------------------------------------------------------------- -- Data types diff --git a/src/TorDNSEL/Util.hsc b/src/TorDNSEL/Util.hsc index 7397208..12493fe 100644 --- a/src/TorDNSEL/Util.hsc +++ b/src/TorDNSEL/Util.hsc @@ -141,6 +141,7 @@ import System.Posix.Types (FileMode) import Text.Printf (printf) import Data.Binary (Binary(..)) +import Data.Conduit (Pipe(..), Conduit, Sink) import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import qualified Data.Conduit.Binary as CB @@ -431,19 +432,25 @@ showUTCTime time = printf "%s %02d:%02d:%s" date hours mins secStr' -------------------------------------------------------------------------------- -- Conduit utilities +-- ## Conduit 0.4.2 shim +-- ## +leftover :: Monad m => i -> Conduit i m o +leftover i = Done (Just i) () +-- ## + -- | 'CB.take' for strict 'ByteString's. -c_take :: Monad m => Int -> C.ConduitM ByteString o m ByteString +c_take :: Monad m => Int -> Sink ByteString 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)) + -> Sink ByteString m (Maybe (ByteString, ByteString)) c_breakDelim delim = wait_input $ B.empty where wait_input front = C.await >>= - (Nothing <$ C.leftover front) `maybe` \bs -> + (Nothing <$ leftover front) `maybe` \bs -> let (front', bs') = (<> bs) `second` B.splitAt (B.length front - d_len + 1) front @@ -455,15 +462,14 @@ c_breakDelim delim = wait_input $ B.empty d_len = B.length delim - -- | Take a CRLF-delimited line from the input. -c_line_crlf :: Monad m => C.ConduitM ByteString o m ByteString +c_line_crlf :: Monad m => Sink ByteString m ByteString c_line_crlf = c_breakDelim (B.pack "\r\n") >>= - return B.empty `maybe` \(line, rest) -> line <$ C.leftover rest + return B.empty `maybe` \(line, rest) -> line <$ leftover rest -- | Stream lines delimited by either LF or CRLF. -c_lines_any :: Monad m => C.Conduit ByteString m ByteString +c_lines_any :: Monad m => Conduit ByteString m ByteString c_lines_any = CB.lines C.=$= CL.map strip where strip bs = case unsnoc bs of diff --git a/tordnsel.cabal b/tordnsel.cabal index 827256e..0b5182c 100644 --- a/tordnsel.cabal +++ b/tordnsel.cabal @@ -13,10 +13,10 @@ Package-URL: https://archive.torproject.org/tor-package-archive/tordnsel/tor Author: tup Maintainer: tup.tuple(a)googlemail.com, lunar(a)debian.org, andrew(a)torproject.org Build-Type: Simple -Build-Depends: base>=2.0, network>=2.0, mtl>=1.0, unix>=1.0, stm>=2.0, - time>=1.0, HUnit>=1.1, binary>=0.4, bytestring>=0.9, array>=0.1, directory>=1.0, - containers>=0.1, conduit >= 1.0.0 && < 1.1.0, deepseq >= 1.3 -Tested-With: GHC==6.6, GHC==6.8, GHC==6.10, GHC==6.12 +Build-Depends: base>=4.5, network==2.3.*, mtl==2.*, unix>=2.5, stm>=2.3, + time>=1.4, HUnit>=1.2, binary>=0.5, bytestring>=0.9, array>=0.4, + directory>=1.1, containers>=0.4, conduit==0.4.2, deepseq>=1.3 +Tested-With: GHC==7.4, GHC==7.6 Data-Files: config/tordnsel.conf.sample, contrib/cacti-input.pl, contrib/tordnsel-init.d-script.sample, doc/tordnsel.8 @@ -72,6 +72,7 @@ Extensions: FlexibleContexts DeriveDataTypeable GeneralizedNewtypeDeriving Rank2Types + StandaloneDeriving Executable: runtests Buildable: False

1 0

[tordnsel/master] introduce conduits
by arlo＠torproject.org 16 Apr '16

16 Apr '16

commit fe5b3964db5f8b7f88fc308b38c16e1ccd7fa849 Author: David Kaloper <david(a)numm.org> Date: Sat Sep 21 19:18:52 2013 +0200 introduce conduits And get rid of TorDNSEL.Util.hGetLine. --- src/TorDNSEL/ExitTest/Request.hs | 94 ++++++++++--------- src/TorDNSEL/ExitTest/Server/Internals.hs | 2 +- src/TorDNSEL/TorControl/Internals.hs | 78 ++++++++-------- src/TorDNSEL/Util.hsc | 148 ++++++++---------------------- tordnsel.cabal | 2 +- 5 files changed, 130 insertions(+), 194 deletions(-) diff --git a/src/TorDNSEL/ExitTest/Request.hs b/src/TorDNSEL/ExitTest/Request.hs index 87a2fbd..82e198c 100644 --- a/src/TorDNSEL/ExitTest/Request.hs +++ b/src/TorDNSEL/ExitTest/Request.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + ----------------------------------------------------------------------------- -- | -- Module : TorDNSEL.ExitTest.Request @@ -24,14 +26,20 @@ module TorDNSEL.ExitTest.Request ( , cookieLen ) where -import Control.Arrow ((***)) -import Control.Monad (guard) +import Control.Arrow ((***), second) +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) +import Data.Conduit +import qualified Data.Conduit.Binary as CB + import TorDNSEL.Util -------------------------------------------------------------------------------- @@ -40,55 +48,50 @@ import TorDNSEL.Util -- | Create an HTTP request that POSTs a cookie to one of our listening ports. createRequest :: B.ByteString -> Port -> Cookie -> B.ByteString createRequest host port cookie = - B.intercalate (B.pack "\r\n") - -- POST should force caching proxies to forward the request. - [ B.pack "POST / HTTP/1.0" - -- Host doesn't exist in HTTP 1.0. We'll use it anyway to help the request - -- traverse transparent proxies. - , B.pack "Host: " `B.append` hostValue - , B.pack "Content-Type: application/octet-stream" - , B.pack "Content-Length: " `B.append` B.pack (show cookieLen) - , B.pack "Connection: close" - , B.pack "\r\n" `B.append` unCookie cookie ] + B.intercalate "\r\n" + -- POST should force caching proxies to forward the request. + [ "POST / HTTP/1.0" + -- Host doesn't exist in HTTP 1.0. We'll use it anyway to help the request + -- traverse transparent proxies. + , "Host: " <> hostValue + , "Content-Type: application/octet-stream" + , "Content-Length: " <> bshow cookieLen + , "Connection: close" + , "\r\n" <> unCookie cookie ] + where hostValue | port == 80 = host - | otherwise = B.concat [host, B.pack ":", B.pack $ show port] + | otherwise = B.concat [host, ":", bshow port] -- | Given an HTTP client, return the cookie contained in the body of the HTTP -- request if it's well-formatted, otherwise return 'Nothing'. -getRequest :: Handle -> MaybeT IO Cookie -getRequest client = do - (reqLine,headers) <- liftIO $ getHeader - guard $ reqLine `elem` [B.pack "POST / HTTP/1.0", B.pack "POST / HTTP/1.1"] - Just contentType <- return $ B.pack "content-type" `M.lookup` headers - guard $ contentType == B.pack "application/octet-stream" - Just contentLen <- return $ readInt =<< B.pack "content-length" `M.lookup` headers - guard $ contentLen == cookieLen - - fmap Cookie . lift $ B.hGet client cookieLen +getRequest :: Handle -> IO (Maybe Cookie) +getRequest client = + CB.sourceHandle client $= CB.isolate maxReqLen $$ do + mh <- getHeaders + case checkHeaders mh of + Nothing -> return Nothing + Just _ -> Just . Cookie <$> takeC cookieLen + where - maxHeaderLen = 2048 - crlf = B.pack "\r\n" - crlfLen = 2 - - getHeader = do - reqLine <- hGetLine client crlf maxHeaderLen - headers <- getHeaders (maxHeaderLen - B.length reqLine - crlfLen) - return (reqLine, M.fromList headers) - - getHeaders remain - | remain <= 0 = return [] - | otherwise = do - header <- hGetLine client crlf remain - if B.null header - then return [] - else do - headers <- getHeaders (remain - B.length header - crlfLen) - return (readHeader header : headers) - - readHeader = - (B.map toLower *** B.dropWhile isSpace . B.drop 1) . B.break (== ':') + maxReqLen = 2048 + cookieLen + line = frameC "\r\n" + + getHeaders = + (,) <$> line + <*> (decodeHeaders <$> muntil B.null line) + where + decodeHeaders = M.fromList . + map ((B.map toLower *** B.dropWhile isSpace . B.tail) + . B.break (== ':')) + + checkHeaders (reqLine, headers) = do + contentType <- "content-type" `M.lookup` headers + contentLen <- readInt =<< "content-length" `M.lookup` headers + guard $ reqLine `elem` ["POST / HTTP/1.0", "POST / HTTP/1.1"] + guard $ contentType == "application/octet-stream" + guard $ contentLen == cookieLen -------------------------------------------------------------------------------- -- Cookies @@ -97,7 +100,7 @@ getRequest client = do -- associate it with the exit node we're testing through and use it look up that -- exit node when we receive it on a listening port. newtype Cookie = Cookie { unCookie :: B.ByteString } - deriving (Eq, Ord) + deriving (Eq, Ord, Show) -- | Create a new cookie from pseudo-random data. newCookie :: (Int -> IO B.ByteString) -> IO Cookie @@ -106,3 +109,4 @@ newCookie getRandBytes = Cookie `fmap` getRandBytes cookieLen -- | The cookie length in bytes. cookieLen :: Int cookieLen = 32 + diff --git a/src/TorDNSEL/ExitTest/Server/Internals.hs b/src/TorDNSEL/ExitTest/Server/Internals.hs index 8f9a872..13e2136 100644 --- a/src/TorDNSEL/ExitTest/Server/Internals.hs +++ b/src/TorDNSEL/ExitTest/Server/Internals.hs @@ -181,7 +181,7 @@ 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.try $ do - r <- runMaybeT $ getRequest client + r <- getRequest client case r of Just cookie -> do now <- getCurrentTime diff --git a/src/TorDNSEL/TorControl/Internals.hs b/src/TorDNSEL/TorControl/Internals.hs index 254d6b1..7e0b8f1 100644 --- a/src/TorDNSEL/TorControl/Internals.hs +++ b/src/TorDNSEL/TorControl/Internals.hs @@ -95,7 +95,6 @@ module TorDNSEL.TorControl.Internals ( -- * Backend connection manager , IOMessage(..) , startIOManager - , ReplyType(..) , startSocketReader -- * Data types @@ -130,6 +129,7 @@ module TorDNSEL.TorControl.Internals ( , parseReplyCode , throwIfNotPositive , isPositive + ) where import Control.Arrow (first, second) @@ -156,6 +156,10 @@ import Data.Typeable (Typeable) import System.IO (Handle, hClose, hSetBuffering, BufferMode(..), hFlush) import System.IO.Error (isEOFError) +import Data.Conduit +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL + import TorDNSEL.Control.Concurrent.Link import TorDNSEL.Control.Concurrent.Future import TorDNSEL.Control.Concurrent.Util @@ -213,7 +217,6 @@ openConnection handle mbPasswd = do let conn' = Conn tellIOManager ioManagerTid protInfo confSettings authenticate mbPasswd conn' useFeature [VerboseNames] conn' - putStrLn "*X MRMLJ" return conn' ) `onException'` closeConnection' conn confSettings @@ -823,45 +826,48 @@ startIOManager handle = do eventCode = B.takeWhile (/= ' ') . repText --- | Reply types in a single sequence of replies. -data ReplyType - = MidReply !Reply -- ^ A reply preceding other replies. - | LastReply !Reply -- ^ The last reply. - deriving Show - -- | Start a thread that reads replies from @handle@ and passes them to -- @sendRepliesToIOManager@, linking it to the calling thread. startSocketReader :: Handle -> ([Reply] -> IO ()) -> IO ThreadId startSocketReader handle sendRepliesToIOManager = - forkLinkIO . forever $ readReplies >>= sendRepliesToIOManager + forkLinkIO $ CB.sourceHandle handle $= + repliesC $$ + CL.mapM_ sendRepliesToIOManager + +-- | Conduit taking lines to 'Reply' blocks. +replyC :: Conduit B.ByteString IO [Reply] +replyC = + line0 [] + where + + line0 acc = await >>= return () `maybe` \line -> do + let (code, (typ, text)) = B.splitAt 1 `second` B.splitAt 3 line + code' <- either (monadThrow . ProtocolError) return $ + parseReplyCode code + case () of + _ | typ == B.pack "-" -> line0 (Reply code' text [] : acc) + | typ == B.pack "+" -> line0 . (: acc) . Reply code' text =<< rest [] + | typ == B.pack " " -> do + yield $ reverse (Reply code' text [] : acc) + line0 [] + | otherwise -> monadThrow $ ProtocolError $ + cat "Malformed reply line type " (esc 1 typ) '.' + + rest acc = + await >>= \mline -> case mline of + Nothing -> return $ reverse acc + Just line | B.null line -> rest acc + | line == B.pack "." -> return $ reverse (line:acc) + | otherwise -> rest (line:acc) + +-- | Conduit taking raw 'ByteString' to 'Reply' blocks. +repliesC :: Conduit B.ByteString IO [Reply] +repliesC = + CB.lines =$= CL.map strip =$= replyC where - readReplies = do - line <- parseReplyLine =<< hGetLine handle crlf maxLineLength - case line of - MidReply reply -> fmap (reply :) readReplies - LastReply reply -> return [reply] - - parseReplyLine line = - either (E.throwIO . ProtocolError) (parseReplyLine' typ text) - (parseReplyCode code) - where (code,(typ,text)) = B.splitAt 1 `second` B.splitAt 3 line - - parseReplyLine' typ text code - | 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.throwIO . ProtocolError $ - cat "Malformed reply line type " (esc 1 typ) '.' - - readData = do - line <- hGetLine handle (B.pack "\n") maxLineLength - case (if B.last line == '\r' then B.init else id) line of - line' | line == (B.pack ".\r") -> return [] - | any B.null [line, line'] -> readData - | otherwise -> fmap (line' :) readData - - crlf = B.pack "\r\n" - maxLineLength = 2^20 + strip bs = case unsnoc bs of + Just (bs', '\r') -> bs' + _ -> bs -------------------------------------------------------------------------------- -- Data types diff --git a/src/TorDNSEL/Util.hsc b/src/TorDNSEL/Util.hsc index 5cea0bb..6bbffc3 100644 --- a/src/TorDNSEL/Util.hsc +++ b/src/TorDNSEL/Util.hsc @@ -30,6 +30,9 @@ module TorDNSEL.Util ( , replaceError , handleError + -- * Show functions + , bshow + -- * Strict functions , adjust' , alter' @@ -49,6 +52,7 @@ module TorDNSEL.Util ( , inet_htoa , encodeBase16 , split + , unsnoc , syncExceptions , bracket' , finally' @@ -59,10 +63,13 @@ module TorDNSEL.Util ( , inBoundsOf , htonl , ntohl - , hGetLine , splitByDelimiter , showUTCTime + -- * Conduit utilities + , takeC + , frameC + -- * Network functions , bindUDPSocket , bindListeningTCPSocket @@ -116,9 +123,11 @@ import Data.Char 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.Internal as B -import qualified Data.ByteString.Unsafe 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, (%)) @@ -140,6 +149,9 @@ import System.Posix.Types (FileMode) import Text.Printf (printf) import Data.Binary (Binary(..)) +import qualified Data.Conduit as C +import qualified Data.Conduit.Binary as CB + #include <netinet/in.h> -------------------------------------------------------------------------------- @@ -240,6 +252,12 @@ handleError :: MonadError e m => (e -> m a) -> m a -> m a handleError = flip catchError -------------------------------------------------------------------------------- +-- Show functions + +bshow :: (Show a) => a -> B.ByteString +bshow = B.pack . show + +-------------------------------------------------------------------------------- -- Strict functions -- | Same as 'M.adjust', but the adjusting function is applied strictly. @@ -322,6 +340,10 @@ 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) +-- | Deconstruct a 'ByteString' at the tail. +unsnoc :: ByteString -> Maybe (ByteString, Char) +unsnoc bs | B.null bs = Nothing + | otherwise = Just (B.init bs, B.last bs) -- | Try an action, catching -- roughly -- "synchronous" exceptions. -- @@ -401,114 +423,18 @@ instance Error e => MonadError e Maybe where foreign import ccall unsafe "htonl" htonl :: Word32 -> Word32 foreign import ccall unsafe "ntohl" ntohl :: Word32 -> Word32 --- | Read a line terminated by an arbitrary sequence of bytes from a handle. The --- end-of-line sequence is stripped before returning the line. @maxLen@ --- specifies the maximum line length to read, not including the end-of-line --- sequence. If the line length exceeds @maxLen@, return the first @maxLen@ --- bytes. If EOF is encountered, return the bytes preceding it. The handle --- should be in 'LineBuffering' mode. -hGetLine :: Handle -> ByteString -> Int -> IO ByteString -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) +takeC :: Monad m => Int -> C.ConduitM ByteString o m ByteString +takeC = fmap (mconcat . BL.toChunks) . CB.take + +-- | Take a prefix up to delimiter. +-- FIXME This is worst-case quadratic. +frameC :: Monad m => ByteString -> C.ConduitM ByteString o m ByteString +frameC delim = loop $ B.pack "" where + loop acc = C.await >>= + return acc `maybe` \bs -> + case B.breakSubstring delim $ acc <> bs of + (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. diff --git a/tordnsel.cabal b/tordnsel.cabal index 3173943..50e7f40 100644 --- a/tordnsel.cabal +++ b/tordnsel.cabal @@ -15,7 +15,7 @@ Maintainer: tup.tuple(a)googlemail.com, lunar(a)debian.org, andrew(a)torproject.o Build-Type: Simple Build-Depends: base>=2.0, network>=2.0, mtl>=1.0, unix>=1.0, stm>=2.0, time>=1.0, HUnit>=1.1, binary>=0.4, bytestring>=0.9, array>=0.1, directory>=1.0, - containers>=0.1, deepseq >= 1.3 + containers>=0.1, conduit >= 1.0.0 && < 1.1.0, deepseq >= 1.3 Tested-With: GHC==6.6, GHC==6.8, GHC==6.10, GHC==6.12 Data-Files: config/tordnsel.conf.sample, contrib/cacti-input.pl, contrib/tordnsel-init.d-script.sample, doc/tordnsel.8

1 0

[tordnsel/master] fix frame reading complexity
by arlo＠torproject.org 16 Apr '16

16 Apr '16

commit 054dba9d9e6d1a6a4f3970e5fea9642114464af5 Author: David Kaloper <david(a)numm.org> Date: Thu Oct 17 01:14:17 2013 +0200 fix frame reading complexity --- src/TorDNSEL/ExitTest/Request.hs | 25 +++++++++++----------- src/TorDNSEL/TorControl/Internals.hs | 36 ++++++++++++-------------------- src/TorDNSEL/Util.hsc | 40 +++++++++++++++++++++++++++--------- 3 files changed, 56 insertions(+), 45 deletions(-) diff --git a/src/TorDNSEL/ExitTest/Request.hs b/src/TorDNSEL/ExitTest/Request.hs index 4634e8d..84f502a 100644 --- a/src/TorDNSEL/ExitTest/Request.hs +++ b/src/TorDNSEL/ExitTest/Request.hs @@ -30,6 +30,7 @@ import Control.Arrow ((***)) import Control.Applicative import Control.Monad import Data.Monoid +import Data.Maybe import qualified Data.ByteString.Char8 as B import Data.Char (isSpace, toLower) import qualified Data.Map as M @@ -67,27 +68,27 @@ createRequest host port cookie = getRequest :: Handle -> IO (Maybe Cookie) getRequest client = CB.sourceHandle client $= CB.isolate maxReqLen $$ do - mh <- getHeaders - case checkHeaders mh of + reqline <- line + hs <- accHeaders [] + case checkHeaders reqline hs of Nothing -> return Nothing Just _ -> Just . Cookie <$> takeC cookieLen where maxReqLen = 2048 + cookieLen - line = frameC "\r\n" + line = fromMaybe "" <$> frame "\r\n" - getHeaders = - (,) <$> line - <*> (decodeHeaders <$> muntil B.null line) - where - decodeHeaders = M.fromList . - map ((B.map toLower *** B.dropWhile isSpace . B.tail) - . B.break (== ':')) + accHeaders hs = line >>= \ln -> + if ln == "" then return $ M.fromList hs + else accHeaders (parseHeader ln : hs) - checkHeaders (reqLine, headers) = do + parseHeader = (B.map toLower *** B.dropWhile isSpace . B.tail) . + B.break (== ':') + + checkHeaders reqline headers = do contentType <- "content-type" `M.lookup` headers contentLen <- readInt =<< "content-length" `M.lookup` headers - guard $ reqLine `elem` ["POST / HTTP/1.0", "POST / HTTP/1.1"] + guard $ reqline `elem` ["POST / HTTP/1.0", "POST / HTTP/1.1"] guard $ contentType == "application/octet-stream" guard $ contentLen == cookieLen diff --git a/src/TorDNSEL/TorControl/Internals.hs b/src/TorDNSEL/TorControl/Internals.hs index 58c64ef..0d299d6 100644 --- a/src/TorDNSEL/TorControl/Internals.hs +++ b/src/TorDNSEL/TorControl/Internals.hs @@ -137,11 +137,10 @@ 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, forever) +import Control.Monad (when, unless, liftM, mzero, mplus) 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) @@ -830,13 +829,13 @@ startIOManager handle = do startSocketReader :: Handle -> ([Reply] -> IO ()) -> IO ThreadId startSocketReader handle sendRepliesToIOManager = forkLinkIO $ CB.sourceHandle handle $= - repliesC $$ + c_replies $$ CL.mapM_ sendRepliesToIOManager --- | Conduit taking lines to 'Reply' blocks. -replyC :: Conduit B.ByteString IO [Reply] -replyC = - line0 [] +-- | Stream decoded 'Reply' groups. +c_replies :: Conduit B.ByteString IO [Reply] +c_replies = + frames (B.pack "\r\n") =$= line0 [] where line0 acc = await >>= return () `maybe` \line -> do @@ -844,13 +843,13 @@ replyC = code' <- either (monadThrow . ProtocolError) return $ parseReplyCode code case () of - _ | typ == B.pack "-" -> line0 (Reply code' text [] : acc) - | typ == B.pack "+" -> line0 . (: acc) . Reply code' text =<< rest [] - | typ == B.pack " " -> do - yield $ reverse (Reply code' text [] : acc) - line0 [] - | otherwise -> monadThrow $ ProtocolError $ - cat "Malformed reply line type " (esc 1 typ) '.' + _ | typ == B.pack "-" -> line0 (acc' []) + | typ == B.pack "+" -> rest [] >>= line0 . acc' + | typ == B.pack " " -> yield (reverse $ acc' []) >> line0 [] + | otherwise -> monadThrow $ + ProtocolError $ cat "Malformed reply line type " (esc 1 typ) '.' + where + acc' xs = Reply code' text xs : acc rest acc = await >>= \mline -> case mline of @@ -859,15 +858,6 @@ replyC = | line == B.pack "." -> return $ reverse (line:acc) | otherwise -> rest (line:acc) --- | Conduit taking raw 'ByteString' to 'Reply' blocks. -repliesC :: Conduit B.ByteString IO [Reply] -repliesC = - CB.lines =$= CL.map strip =$= replyC - where - strip bs = case unsnoc bs of - Just (bs', '\r') -> bs' - _ -> bs - -------------------------------------------------------------------------------- -- Data types diff --git a/src/TorDNSEL/Util.hsc b/src/TorDNSEL/Util.hsc index f866eb9..2c57e0e 100644 --- a/src/TorDNSEL/Util.hsc +++ b/src/TorDNSEL/Util.hsc @@ -65,7 +65,8 @@ module TorDNSEL.Util ( -- * Conduit utilities , takeC - , frameC + , frames + , frame -- * Network functions , bindUDPSocket @@ -416,15 +417,34 @@ 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 --- | Take a prefix up to delimiter. --- FIXME This is worst-case quadratic. -frameC :: Monad m => ByteString -> C.ConduitM ByteString o m ByteString -frameC delim = loop $ B.pack "" where - loop acc = C.await >>= - return acc `maybe` \bs -> - case B.breakSubstring delim $ acc <> bs of - (h, t) | B.null t -> loop h - | otherwise -> h <$ C.leftover (B.drop (B.length delim) t) +-- | 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 "" + where + 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 + + 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 + -- | Convert a 'UTCTime' to a string in ISO 8601 format. showUTCTime :: UTCTime -> String

1 0

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

16 Apr '16

commit be92ae00b21041ff9033d8e2a83dd8610f8dc2d2 Author: David Kaloper <david(a)numm.org> Date: Tue Sep 3 20:45:12 2013 +0200 fix exceptions --- src/TorDNSEL/Config/Internals.hs | 18 ++--- src/TorDNSEL/DNS/Server/Internals.hs | 15 ++-- src/TorDNSEL/ExitTest/Initiator/Internals.hs | 44 ++++++------ src/TorDNSEL/ExitTest/Server/Internals.hs | 66 ++++++++++-------- src/TorDNSEL/Log/Internals.hsc | 2 +- src/TorDNSEL/Main.hsc | 97 ++++++++++++++------------ src/TorDNSEL/NetworkState/Internals.hs | 24 ++++--- src/TorDNSEL/NetworkState/Storage/Internals.hs | 10 +-- src/TorDNSEL/Socks.hs | 1 - src/TorDNSEL/Socks/Internals.hs | 9 +-- src/TorDNSEL/Statistics/Internals.hs | 11 +-- src/TorDNSEL/TorControl.hs | 1 - src/TorDNSEL/TorControl/Internals.hs | 56 +++++++-------- src/TorDNSEL/Util.hsc | 12 ---- 14 files changed, 183 insertions(+), 183 deletions(-) diff --git a/src/TorDNSEL/Config/Internals.hs b/src/TorDNSEL/Config/Internals.hs index c8aa790..d93da96 100644 --- a/src/TorDNSEL/Config/Internals.hs +++ b/src/TorDNSEL/Config/Internals.hs @@ -52,7 +52,7 @@ import Control.Monad (liftM, liftM2, ap) import Control.Monad.Error (MonadError(..)) import Control.Monad.Fix (fix) import Data.Char (isSpace, toLower) -import Data.Maybe (catMaybes, isJust) +import Data.Maybe (catMaybes) import qualified Data.ByteString.Char8 as B import Data.ByteString (ByteString) import qualified Data.Map as M @@ -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." + log Info "Starting reconfigure server." :: IO () chan <- newChan tid <- forkLinkIO $ do setTrapExit $ (writeChan chan .) . Exit @@ -433,13 +433,13 @@ startReconfigServer sock sendConfig = do handleMessage :: State -> ReconfigMessage -> IO State handleMessage s (NewClient client signal) = do - E.handleJust E.ioErrors - (log Warn "Reading config from reconfigure socket failed: ") $ + E.handle + (\(e :: E.IOException) -> log Warn "Reading config from reconfigure socket failed: " e) $ E.bracket (socketToHandle client ReadWriteMode) hClose $ \handle -> do str <- B.hGetContents handle case parseConfigFile str >>= makeConfig of Left e -> do - hCat handle "Parse error: " e "\r\n" + hCat handle "Parse error: " e "\r\n" :: IO () 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." + log Info "Terminating reconfigure server." :: IO () terminateThread Nothing (listenerTid s) (killThread $ listenerTid s) msgs <- untilM (isEmptyChan $ reconfigChan s) (readChan $ reconfigChan s) sequence_ [sClose client | NewClient client _ <- msgs] @@ -460,10 +460,10 @@ handleMessage s (Terminate reason) = do handleMessage s (Exit tid reason) | tid == listenerTid s = do log Warn "The reconfigure listener thread exited unexpectedly: " - (showExitReason [] reason) "; restarting." + (show reason) "; restarting." :: IO () newListenerTid <- forkListener (listenSock s) (writeChan $ reconfigChan s) return s { listenerTid = newListenerTid } - | isJust reason = exit reason + | isAbnormal reason = exit reason | otherwise = return s -- | Fork the listener thread. @@ -481,4 +481,4 @@ forkListener sock send = -- exit signal will be sent. terminateReconfigServer :: Maybe Int -> ReconfigServer -> IO () terminateReconfigServer mbWait (ReconfigServer tid send) = - terminateThread mbWait tid (send $ Terminate Nothing) + terminateThread mbWait tid (send $ Terminate NormalExit) diff --git a/src/TorDNSEL/DNS/Server/Internals.hs b/src/TorDNSEL/DNS/Server/Internals.hs index 268ca8d..9bc8fc3 100644 --- a/src/TorDNSEL/DNS/Server/Internals.hs +++ b/src/TorDNSEL/DNS/Server/Internals.hs @@ -81,11 +81,18 @@ data DNSMessage | Terminate ExitReason -- ^ Terminate the DNS server gracefully deriving Typeable +-- This is to please the Exception instance. +instance Show DNSMessage where + showsPrec _ (Terminate a) = ("Terminate " ++) . shows a + showsPrec _ (Reconfigure _ _) = ("Reconfigure" ++) + +instance E.Exception DNSMessage + -- | Given an initial 'DNSConfig', start the DNS server and return a handle to -- it. Link the DNS server to the calling thread. startDNSServer :: DNSConfig -> IO DNSServer startDNSServer initConf = do - log Info "Starting DNS server." + log Info "Starting DNS server." :: IO () fmap DNSServer . forkLinkIO . E.block . loop $ initConf where loop conf = do @@ -101,7 +108,7 @@ startDNSServer initConf = do signal loop newConf Left (_,Terminate reason) -> do - log Info "Terminating DNS server." + log Info "Terminating DNS server." :: IO () exit reason Right _ -> loop conf -- impossible @@ -110,7 +117,7 @@ startDNSServer initConf = do -- the calling thread. reconfigureDNSServer :: (DNSConfig -> DNSConfig) -> DNSServer -> IO () reconfigureDNSServer reconf (DNSServer tid) = - sendSyncMessage (throwDynTo tid . Reconfigure reconf) tid + sendSyncMessage (throwTo tid . exitReason . Reconfigure reconf) tid -- | Terminate the DNS server gracefully. The optional parameter specifies the -- amount of time in microseconds to wait for the thread to terminate. If the @@ -118,7 +125,7 @@ reconfigureDNSServer reconf (DNSServer tid) = -- sent. terminateDNSServer :: Maybe Int -> DNSServer -> IO () terminateDNSServer mbWait (DNSServer tid) = - terminateThread mbWait tid (throwDynTo tid $ Terminate Nothing) + terminateThread mbWait tid (throwTo tid $ exitReason $ Terminate NormalExit) -- | A stateful wrapper for 'dnsResponse'. dnsHandler :: DNSConfig -> Message -> IO (Maybe Message) diff --git a/src/TorDNSEL/ExitTest/Initiator/Internals.hs b/src/TorDNSEL/ExitTest/Initiator/Internals.hs index d4538df..4605c15 100644 --- a/src/TorDNSEL/ExitTest/Initiator/Internals.hs +++ b/src/TorDNSEL/ExitTest/Initiator/Internals.hs @@ -63,7 +63,7 @@ import qualified Data.Foldable as F import Data.List (foldl', unfoldr, mapAccumL) import qualified Data.Map as M import Data.Map (Map) -import Data.Maybe (mapMaybe, isJust) +import Data.Maybe (mapMaybe ) import qualified Data.Sequence as Seq import Data.Sequence (Seq, ViewL((:<)), viewl, (<|), (|>), ViewR((:>)), viewr) import qualified Data.Set as Set @@ -153,7 +153,7 @@ data TestStatus -- thread. startExitTestInitiator :: ExitTestInitiatorConfig -> IO ExitTestInitiator startExitTestInitiator initConf = do - log Info "Starting exit test initiator." + log Info "Starting exit test initiator." :: IO () chan <- newChan initiatorTid <- forkLinkIO $ do setTrapExit ((writeChan chan .) . Exit) @@ -172,15 +172,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 '.' + " ports " ports '.' :: IO () 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) '.' + (Set.size newRunningClients) '.' :: IO () if Q.length (pendingTests s) == 0 then do - log Info "Pending exit tests: 0." + log Info "Pending exit tests: 0." :: IO () loop conf s { runningClients = newRunningClients , testStatus = NoTestsPending } else do @@ -201,7 +201,7 @@ handleMessage handleMessage conf s (NewDirInfo routers) | nRouterTests == 0 = return (conf, s) | otherwise = do - log Info "Scheduling exit tests for " nRouterTests " routers." + log Info "Scheduling exit tests for " nRouterTests " routers." :: IO () now <- getCurrentTime let newS = s { pendingTests = newPendingTests , testHistory = appendTestsToHistory now nRouterTests . @@ -237,7 +237,7 @@ handleMessage conf s (Reconfigure reconf signal) = do return (newConf, s) handleMessage _ s (Terminate reason) = do - log Info "Terminating exit test initiator." + log Info "Terminating exit test initiator." :: IO () F.forM_ (runningClients s) $ \client -> terminateThread Nothing client (killThread client) exit reason @@ -251,13 +251,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." + log Info "Pending exit tests: 0." :: IO () return (conf, s { pendingTests = Q.empty , testStatus = NoTestsPending }) Just (rid,ports,published,newPendingTests) -> do - log Info "Pending exit tests: " (Q.length newPendingTests + 1) '.' + log Info "Pending exit tests: " (Q.length newPendingTests + 1) '.' :: IO () log Debug "Waiting to run exit test for router " rid - " ports " ports '.' + " ports " ports '.' :: IO () return (conf, s { pendingTests = newPendingTests , testStatus = TestWaiting rid ports published }) -- Periodically, add every eligible router to the exit test queue. This should @@ -267,7 +267,7 @@ handleMessage conf s (Exit tid reason) =<< eticfGetNetworkState conf newTid <- forkPeriodicTestTimer return (conf, newS { periodicTestTimer = newTid }) - | isJust reason = exit reason + | isAbnormal reason = exit reason | otherwise = return (conf, s) -- | Notify the exit test initiator of new directory information. @@ -295,7 +295,7 @@ reconfigureExitTestInitiator reconf (ExitTestInitiator send tid) = -- exit signal will be sent. terminateExitTestInitiator :: Maybe Int -> ExitTestInitiator -> IO () terminateExitTestInitiator mbWait (ExitTestInitiator send tid) = - terminateThread mbWait tid (send $ Terminate Nothing) + terminateThread mbWait tid (send $ Terminate NormalExit) -------------------------------------------------------------------------------- -- Scheduling exit tests @@ -362,7 +362,7 @@ forkTestClient :: ExitTestInitiatorConfig -> RouterID -> UTCTime -> Port -> IO ThreadId forkTestClient conf rid published port = forkLinkIO $ do - r <- E.tryJust clientExceptions . + r <- E.try . eticfWithCookie conf rid published port $ \cookie -> timeout connectionTimeout . E.bracket connectToSocksServer hClose $ \handle -> @@ -371,15 +371,16 @@ forkTestClient conf rid published port = B.hGet handle 1024 -- ignore response return () case r of - Left e(a)(E.DynException d) | Just (e' :: SocksError) <- fromDynamic d -> do - log Info "Exit test for router " rid " port " port " failed: " e' + Left (E.fromException -> Just (e :: SocksError)) -> do + log Info "Exit test for router " rid " port " port " failed: " e :: IO () E.throwIO e - Left e -> do + 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) '?' + \listening on " (eticfSocksServer conf) '?' :: IO () E.throwIO e + Left e -> E.throwIO e Right Nothing -> log Info "Exit test for router " rid " port " port " timed out." _ -> @@ -394,11 +395,6 @@ forkTestClient conf rid published port = connect sock (eticfSocksServer conf) socketToHandle sock ReadWriteMode - clientExceptions e(a)(E.DynException d) - | Just (_ :: SocksError) <- fromDynamic d = Just e - clientExceptions e(a)(E.IOException _) = Just e - clientExceptions _ = Nothing - connectionTimeout = 120 * 10^6 -- | Fork a timer thread for the next exit test, returning its 'ThreadId'. @@ -406,8 +402,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) - log Info "Running next exit test in " currentInterval " microseconds." + (show . F.toList . historySeq $ testHistory s) :: IO () + log Info "Running next exit test in " currentInterval " microseconds." :: IO () threadDelay $ fromIntegral currentInterval where currentInterval = currentTestInterval nPending (testHistory s) diff --git a/src/TorDNSEL/ExitTest/Server/Internals.hs b/src/TorDNSEL/ExitTest/Server/Internals.hs index 97d1f8e..0d43db3 100644 --- a/src/TorDNSEL/ExitTest/Server/Internals.hs +++ b/src/TorDNSEL/ExitTest/Server/Internals.hs @@ -27,6 +27,7 @@ import qualified Control.Exception as E import Control.Monad (when, forM, foldM) import Control.Monad.Fix (fix) import Control.Monad.Trans (lift) +import Control.Applicative import qualified Data.ByteString.Char8 as B import qualified Data.Foldable as F import qualified Data.Map as M @@ -136,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' @@ -157,9 +158,9 @@ 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.try $ bindListeningTCPSocket addr case r of - Left e -> do + Left (e :: E.IOException ) -> do log Warn "Opening exit test listener on " addr " failed: " e "; \ \skipping listener." return Nothing @@ -169,7 +170,8 @@ reopenSocketIfClosed addr mbSock = MaybeT $ do where isListeningSocketOpen Nothing = return False isListeningSocketOpen (Just sock) = - getSocketName sock >> return True `catch` const (return False) + (True <$ getSocketName sock) + `E.catch` \(_ :: E.SomeException) -> return False -- | Process a 'ServerMessage' and return the new config and state, given the -- current config and state. @@ -178,7 +180,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.try $ do r <- runMaybeT $ getRequest client case r of Just cookie -> do @@ -251,32 +253,34 @@ handleMessage _conf s (Terminate reason) = do handleMessage conf s (Exit tid reason) | tid `S.member` handlers s = do - whenJust reason $ - log Warn "Bug: An exit test client handler exited abnormally: " - return (conf, s { handlers = S.delete tid (handlers s) }) - | tid `S.member` deadListeners s - = return (conf, s { deadListeners = S.delete tid (deadListeners s) }) + case reason of + AbnormalExit _ -> log Warn "Bug: An exit test client handler exited abnormally: " + NormalExit -> return () + return (conf, s { handlers = S.delete tid (handlers s) }) + | tid `S.member` deadListeners s = + return (conf, s { deadListeners = S.delete tid (deadListeners s) }) | Just (Listener addr sock owner) <- tid `M.lookup` listenerThreads s = do - log Warn "An exit test listener thread for " addr " exited unexpectedly: " - (fromJust reason) "; restarting." - mbSock <- runMaybeT $ reopenSocketIfClosed addr (Just sock) - case mbSock of - -- The socket couldn't be reopened, so drop the listener. - Nothing -> - return ( conf { etscfListenAddrs = - S.delete addr (etscfListenAddrs conf) } - , s { listenerThreads = M.delete tid (listenerThreads s) } ) - Just sock' -> do - -- If the socket was reopened, we own it now. - let owner' | sock /= sock' = ExitTestServerOwned - | otherwise = owner - listener' = Listener addr sock' owner' - tid' <- startListenerThread ((writeChan (serverChan s) .) . NewClient) - (handlerSem s) owner sock addr - listener' `seq` return - (conf, s { listenerThreads = M.insert tid' listener' . - M.delete tid $ listenerThreads s }) - | isJust reason = exit reason + + log Warn "An exit test listener thread for " addr " exited unexpectedly: " + reason "; restarting." + mbSock <- runMaybeT $ reopenSocketIfClosed addr (Just sock) + case mbSock of + -- The socket couldn't be reopened, so drop the listener. + Nothing -> + return ( conf { etscfListenAddrs = + S.delete addr (etscfListenAddrs conf) } + , s { listenerThreads = M.delete tid (listenerThreads s) } ) + Just sock' -> do + -- If the socket was reopened, we own it now. + let owner' | sock /= sock' = ExitTestServerOwned + | otherwise = owner + listener' = Listener addr sock' owner' + tid' <- startListenerThread ((writeChan (serverChan s) .) . NewClient) + (handlerSem s) owner sock addr + listener' `seq` return + (conf, s { listenerThreads = M.insert tid' listener' . + M.delete tid $ listenerThreads s }) + | isAbnormal reason = exit reason | otherwise = return (conf, s) -- | Reconfigure the exit test server synchronously with the given function. If @@ -293,4 +297,4 @@ reconfigureExitTestServer reconf (ExitTestServer send tid) = -- be sent. terminateExitTestServer :: Maybe Int -> ExitTestServer -> IO () terminateExitTestServer mbWait (ExitTestServer send tid) = - terminateThread mbWait tid (send $ Terminate Nothing) + terminateThread mbWait tid (send $ Terminate NormalExit) diff --git a/src/TorDNSEL/Log/Internals.hsc b/src/TorDNSEL/Log/Internals.hsc index 0b26873..6c64f9f 100644 --- a/src/TorDNSEL/Log/Internals.hsc +++ b/src/TorDNSEL/Log/Internals.hsc @@ -173,7 +173,7 @@ reconfigureLogger reconf = terminateLogger :: Maybe Int -> IO () terminateLogger mbWait = withLogger $ \tid logChan -> - terminateThread mbWait tid (writeChan logChan $ Terminate Nothing) + terminateThread mbWait tid (writeChan logChan $ Terminate NormalExit) -------------------------------------------------------------------------------- -- System logger diff --git a/src/TorDNSEL/Main.hsc b/src/TorDNSEL/Main.hsc index e612de0..e9a145a 100644 --- a/src/TorDNSEL/Main.hsc +++ b/src/TorDNSEL/Main.hsc @@ -197,10 +197,10 @@ main = do verifyConfig args ["--reconfigure",runtimeDir] -> do sock <- connectToReconfigSocket runtimeDir - `E.catch` \e -> do + `E.catch` \(e :: E.SomeException) -> do hCat stderr "Connecting to reconfigure socket failed: " e '\n' exitWith $ fromSysExitCode Unavailable - r <- E.handleJust E.ioErrors (\e -> do + r <- E.handle (\(e :: E.IOException) -> do hCat stderr "An I/O error occurred while reconfiguring: " e '\n' exitWith $ fromSysExitCode IOError) $ E.bracket (socketToHandle sock ReadWriteMode) hClose $ \handle -> do @@ -221,7 +221,7 @@ main = do conf <- exitLeft Usage $ parseConfigArgs args case B.pack "configfile" `M.lookup` conf of Just fp -> do - file <- E.catchJust E.ioErrors (B.readFile $ B.unpack fp) + file <- catchIO (B.readFile $ B.unpack fp) (exitPrint NoInput . cat "Opening config file failed: ") exitLeft DataError $ makeConfig . M.union conf =<< parseConfigFile file Nothing -> exitLeft Usage $ makeConfig conf @@ -237,33 +237,33 @@ main = do euid /= 0) $ exitPrint NoPermission ("You must be root to drop privileges or chroot." ++) - ids <- E.catchJust E.ioErrors + ids <- catchIO (getIDs (cfUser conf) (cfGroup conf)) (exitPrint OSFile . cat "Looking up uid/gid failed: ") - E.catchJust E.ioErrors + catchIO (checkDirectory (fst ids) (cfChangeRootDirectory conf) (cfStateDirectory conf)) (exitPrint Can'tCreate . cat "Preparing state directory failed: ") - E.catchJust E.ioErrors + catchIO (checkDirectory Nothing Nothing (cfRuntimeDirectory conf)) (exitPrint Can'tCreate . cat "Preparing runtime directory failed: ") - statsSock <- E.catchJust E.ioErrors + statsSock <- catchIO (bindStatsSocket $ cfRuntimeDirectory conf) (exitPrint Can'tCreate . cat "Opening statistics listener failed: ") - reconfigSock <- E.catchJust E.ioErrors + reconfigSock <- catchIO (bindReconfigSocket (cfRuntimeDirectory conf) (fst ids)) (exitPrint Can'tCreate . cat "Opening reconfigure listener failed: ") - pidHandle <- E.catchJust E.ioErrors + pidHandle <- catchIO (flip openFile WriteMode `liftMb` cfPIDFile conf) (exitPrint Can'tCreate . cat "Opening PID file failed: ") log Notice "Opening DNS listener on " (cfDNSListenAddress conf) '.' - dnsSock <- E.catchJust E.ioErrors + dnsSock <- catchIO (bindUDPSocket $ cfDNSListenAddress conf) (\e -> exitPrint (bindErrorCode e) $ cat "Opening DNS listener on " (cfDNSListenAddress conf) @@ -276,7 +276,7 @@ main = do let sockAddr = SockAddrInet (fromIntegral port) (htonl . fst $ tcfTestListenAddress testConf) log Notice "Opening exit test listener on " sockAddr '.' - sock <- E.catchJust E.ioErrors + sock <- catchIO (bindListeningTCPSocket sockAddr) (\e -> exitPrint (bindErrorCode e) $ cat "Opening exit test listener on " sockAddr " failed: " e) @@ -285,7 +285,7 @@ main = do -- We lose any other running threads when we 'forkProcess', so don't 'forkIO' -- before this point. (if cfRunAsDaemon conf then daemonize else id) . - withLinksDo (showException [showLinkException]) $ do + withLinksDo $ do whenJust pidHandle $ \handle -> do hPutStrLn handle . show =<< getProcessID @@ -311,7 +311,7 @@ verifyConfig args = Right conf -> case B.pack "configfile" `M.lookup` conf of Just fp -> do - file <- E.catchJust E.ioErrors (B.readFile $ B.unpack fp) $ \e -> do + file <- catchIO (B.readFile $ B.unpack fp) $ \e -> do hCat stderr "Opening config file failed: " e '\n' exitWith $ fromSysExitCode NoInput check DataError $ parseConfigFile file >>= makeConfig . M.union conf @@ -334,10 +334,13 @@ runMainThread static initTestListeners initDNSListener initConf = do installHandler sigHUP (Catch hupHandler) Nothing installHandler sigINT (Catch $ termHandler sigINT) Nothing - initState <- E.handle (\e -> do log Error "Starting failed: " e - terminateLogger Nothing - closeSystemLogger - exitWith $ fromSysExitCode ConfigError) $ do + initState <- + E.handle (\(e :: E.SomeException) -> do + log Error "Starting failed: " e + terminateLogger Nothing + closeSystemLogger + exitWith $ fromSysExitCode ConfigError) $ do + initLogger <- initializeLogger initConf whenJust (cfChangeRootDirectory initConf) $ \dir -> log Notice "Chrooted in " (esc 256 $ B.pack dir) '.' @@ -347,12 +350,11 @@ runMainThread static initTestListeners initDNSListener initConf = do initReconfig <- startReconfigServer (reconfigSocket static) (((writeChan mainChan . Reconfigure) .) . curry Just) let cleanup = terminateReconfigServer Nothing initReconfig - stats <- startStatsServer (statsSocket static) - `E.catch` \e -> cleanup >> E.throwIO e + stats <- startStatsServer (statsSocket static) `E.onException` cleanup let cleanup' = cleanup >> terminateStatsServer Nothing stats netState <- initializeNetworkStateManager (mkExitTestConfig static initTestListeners initConf) initConf - `E.catch` \e -> cleanup' >> E.throwIO e + `E.onException` cleanup' dns <- startDNSServer (mkDNSServerConfig initDNSListener initConf) return $ State (Just initLogger) (Just initReconfig) (Just stats) netState dns initTestListeners initDNSListener S.empty @@ -374,9 +376,9 @@ handleMessage _ static conf s (Reconfigure reconf) = flip runStateT s $ do Nothing | Just configFile <- cfConfigFile conf -> do log Notice "Caught SIGHUP. Reloading config file." - r <- liftIO . E.tryJust E.ioErrors $ B.readFile configFile + r <- liftIO . E.try $ B.readFile configFile case r of - Left e -> do + Left (e :: E.IOException) -> do -- If we're chrooted, it's not suprising that we can't read our -- config file. when (isNothing $ cfChangeRootDirectory conf) $ @@ -412,7 +414,7 @@ handleMessage _ static conf s (Reconfigure reconf) = flip runStateT s $ do when (cfStateDirectory conf /= cfStateDirectory newConf') $ liftIO $ checkDirectory Nothing Nothing (cfStateDirectory newConf') - `E.catch` \e -> do + `catchIO` \e -> do errorRespond $ cat "Preparing new state directory failed: " e "; exiting gracefully." terminateProcess Can'tCreate static s Nothing @@ -442,30 +444,30 @@ handleMessage mainChan static conf s (Exit tid reason) Left _ -> return Nothing Right newLogger -> do log Warn "The logger thread exited unexpectedly: " - (showExitReason [] reason) "; restarted." + (show reason) "; restarted." return $ Just newLogger return (conf, s { logger = mbNewLogger , deadThreads = S.insert dead (deadThreads s) }) | deadThreadIs reconfigServer = do log Warn "The reconfigure server thread exited unexpectedly: " - (showExitReason [] reason) "; restarting." + (show reason) "; restarting." (r,dead) <- tryForkLinkIO $ startReconfigServer (reconfigSocket static) (((writeChan mainChan . Reconfigure) .) . curry Just) mbNewReconfigServer <- case r of Left e -> do log Warn "Restarting reconfigure server failed: " - (showExitReason [] e) "; disabling reconfigure server." + (show e) "; disabling reconfigure server." return Nothing Right newReconfigServer -> return $ Just newReconfigServer return (conf, s { reconfigServer = mbNewReconfigServer , deadThreads = S.insert dead (deadThreads s) }) | deadThreadIs statsServer = do log Warn "The statistics server thread exited unexpectedly: " - (showExitReason [] reason) "; restarting." + (show reason) "; restarting." (r,dead) <- tryForkLinkIO . startStatsServer $ statsSocket static mbNewStatsServer <- case r of Left e -> do - log Warn "Restarting statistics server failed: " (showExitReason [] e) + log Warn "Restarting statistics server failed: " (show e) "; disabling statistics server." return Nothing Right newStatsServer -> return $ Just newStatsServer @@ -473,24 +475,24 @@ handleMessage mainChan static conf s (Exit tid reason) , deadThreads = S.insert dead (deadThreads s) }) | tid == threadId (networkStateManager s) = do log Warn "The network state manager thread exited unexpectedly: " - (showExitReason [] reason) "; restarting." + (show reason) "; restarting." newManager <- initializeNetworkStateManager (mkExitTestConfig static (exitTestListeners s) conf) conf - `E.catch` \e -> do + `E.catch` \(e :: E.SomeException) -> do log Error "Restarting network state manager failed: " e "; exiting gracefully." terminateProcess Internal static s Nothing return (conf, s { networkStateManager = newManager }) | tid == threadId (dnsServer s) = do log Warn "The DNS server thread exited unexpectedly: " - (showExitReason [] reason) "; restarting." + (show reason) "; restarting." newDNSServer <- startDNSServer $ mkDNSServerConfig (dnsListener s) conf return (conf, s { dnsServer = newDNSServer }) | tid `S.member` deadThreads s = return (conf, s { deadThreads = S.delete tid (deadThreads s) }) | otherwise = do log Warn "Bug: Received unexpected exit signal: " - (showExitReason [] reason) + (show reason) return (conf, s) where deadThreadIs thr = ((tid ==) . threadId) `fmap` thr s == Just True @@ -615,10 +617,9 @@ reconfigureDNSListenerAndServer reconfigureDNSListenerAndServer static oldConf newConf errorRespond = do when (cfDNSListenAddress oldConf /= cfDNSListenAddress newConf) $ do log Notice "Opening DNS listener on " (cfDNSListenAddress newConf) '.' - r <- liftIO . E.tryJust E.ioErrors $ - bindUDPSocket $ cfDNSListenAddress newConf + r <- liftIO . E.try $ bindUDPSocket $ cfDNSListenAddress newConf case r of - Left e -> do + Left (e :: E.IOException) -> do errorRespond $ cat "Opening DNS listener on " (cfDNSListenAddress newConf) " failed: " e "; exiting gracefully." @@ -649,18 +650,20 @@ terminateProcess status static s mbWait = do forM_ (M.assocs $ exitTestListeners s) $ \(addr,mbSock) -> whenJust mbSock $ \sock -> do log Info "Closing exit test listener on " addr '.' - ignoreJust E.ioErrors $ sClose sock + ignoreIOExn $ sClose sock log Info "Closing DNS listener." - ignoreJust E.ioErrors . sClose $ dnsListener s + ignoreIOExn . sClose $ dnsListener s log Info "Closing statistics listener." - ignoreJust E.ioErrors . sClose $ statsSocket static + ignoreIOExn . sClose $ statsSocket static log Info "Closing reconfigure listener." - ignoreJust E.ioErrors . sClose $ reconfigSocket static - ignoreJust E.ioErrors . hClose $ randomHandle static + ignoreIOExn . sClose $ reconfigSocket static + ignoreIOExn . hClose $ randomHandle static log Notice "All subsystems have terminated. Exiting now." terminateLogger mbWait closeSystemLogger exitWith $ fromSysExitCode status + where + ignoreIOExn = (`catchIO` \_ -> return ()) -------------------------------------------------------------------------------- -- Daemon operations @@ -732,7 +735,7 @@ setMaxOpenFiles lowerLimit cap = do unResourceLimit (ResourceLimit n) = n unResourceLimit _ = error "unResourceLimit: bug" - fmap unResourceLimit $ E.catchJust E.ioErrors + fmap unResourceLimit $ catchIO (setResourceLimit ResourceOpenFiles (newLimits most) >> return most) $ \e -> do #ifdef OPEN_MAX @@ -743,7 +746,7 @@ setMaxOpenFiles lowerLimit cap = do return openMax else E.throwIO (E.IOException e) #else - E.throwIO (E.IOException e) + E.throwIO e #endif instance Ord ResourceLimit where @@ -777,10 +780,8 @@ checkDirectory uid newRoot path = do -- return 'ToStdOut'. checkLogTarget :: LogTarget -> IO LogTarget checkLogTarget target@(ToFile logPath) = - E.catchJust E.ioErrors - (do E.bracket (openFile logPath AppendMode) hClose (const $ return ()) - return target) - (const $ return ToStdOut) + E.bracket (openFile logPath AppendMode) hClose (\_ -> return target) + `catchIO` (\_ -> return ToStdOut) checkLogTarget target = return target -- | System exit status codes from sysexits.h. @@ -845,5 +846,9 @@ liftMb f = maybe (return Nothing) (liftM Just . f) infixr 8 `liftMb` +-- | Specialization of 'E.catch' for 'E.IOException'. +catchIO :: IO a -> (E.IOException -> IO a) -> IO a +catchIO = E.catch + foreign import ccall unsafe "unistd.h chroot" c_chroot :: CString -> IO CInt diff --git a/src/TorDNSEL/NetworkState/Internals.hs b/src/TorDNSEL/NetworkState/Internals.hs index cb3ae46..c4c6b4d 100644 --- a/src/TorDNSEL/NetworkState/Internals.hs +++ b/src/TorDNSEL/NetworkState/Internals.hs @@ -187,7 +187,7 @@ startNetworkStateManager initConf = do Just testConf | Right conn <- controller -> execStateT (initializeExitTests net (nsmcfStateDir initConf) testConf) emptyState - `E.catch` \e -> closeConnection conn >> E.throwIO e + `E.onException` closeConnection conn _ -> return emptyState swapMVar networkStateMV $! networkState initState signal @@ -213,7 +213,7 @@ reconfigureNetworkStateManager reconf (NetworkStateManager send tid) = -- exit signal will be sent. terminateNetworkStateManager :: Maybe Int -> NetworkStateManager -> IO () terminateNetworkStateManager mbWait (NetworkStateManager send tid) = - terminateThread mbWait tid (send $ Terminate Nothing) + terminateThread mbWait tid (send $ Terminate NormalExit) -- | Process a 'ManagerMessage' and return the new config and state, given the -- current config and state. @@ -361,7 +361,7 @@ handleMessage net conf (Exit tid reason) = get >>= handleExit where return conf | Right conn <- torControlConn s, tid == threadId conn = do log Warn "The Tor controller thread exited unexpectedly: " - (showExitReason [showTorControlError] reason) "; restarting." + (show reason) "; restarting." (controller,deadTid) <- startTorController net conf Nothing put $! s { torControlConn = controller , deadThreads = S.insert deadTid (deadThreads s) } @@ -378,7 +378,7 @@ handleMessage net conf (Exit tid reason) = get >>= handleExit where Just (testConf,testState) | tid == toTid storageManager -> do log Warn "The storage manager thread exited unexpectedly: " - (showExitReason [] reason) "; restarting." + (show reason) "; restarting." storage <- liftIO . startStorageManager . StorageConfig $ nsmcfStateDir conf liftIO $ rebuildExitAddressStorage (nsRouters $ networkState s) @@ -387,7 +387,7 @@ handleMessage net conf (Exit tid reason) = get >>= handleExit where return conf | tid == toTid exitTestServer -> do log Warn "The exit test server thread exited unexpectedly: " - (showExitReason [] reason) "; restarting." + (show reason) "; restarting." server <- liftIO $ startExitTestServer (M.assocs $ etcfListeners testConf) (initExitTestServerConfig net testConf) @@ -395,7 +395,7 @@ handleMessage net conf (Exit tid reason) = get >>= handleExit where return conf | tid == toTid exitTestInitiator -> do log Warn "The exit test initiator thread exited unexpectedly: " - (showExitReason [] reason) "; restarting." + (show reason) "; restarting." initiator <- liftIO $ startExitTestInitiator (initExitTestInitiatorConfig net testConf) putTestState testState { exitTestInitiator = initiator } @@ -403,7 +403,7 @@ handleMessage net conf (Exit tid reason) = get >>= handleExit where where toTid f = threadId $ f testState putTestState x = put $! s { exitTestState = Just $! x} - _ | isJust reason -> liftIO $ exit reason + _ | isAbnormal reason -> liftIO $ exit reason | otherwise -> return conf -- | Register a mapping from cookie to router identifier, descriptor published @@ -448,9 +448,9 @@ startTorController startTorController net conf mbDelay = liftIO $ do log Info "Starting Tor controller." (r,tid) <- tryForkLinkIO $ do - E.bracketOnError' (socket AF_INET Stream tcpProtoNum) sClose $ \sock -> do + bracketOnError' (socket AF_INET Stream tcpProtoNum) sClose $ \sock -> do connect sock $ nsmcfTorControlAddr conf - E.bracketOnError' + bracketOnError' ( socketToHandle sock ReadWriteMode >>= (`openConnection` nsmcfTorControlPasswd conf) ) closeConnection $ \conn -> do @@ -473,7 +473,7 @@ startTorController net conf mbDelay = liftIO $ do case r of Left reason -> do log Warn "Initializing Tor controller connection failed: " - (showExitReason [showTorControlError] reason) + (show reason) "; I'll try again in " delay " seconds." timerTid <- forkLinkIO $ threadDelay (delay * 10^6) return (Left (timerTid, nextDelay), tid) @@ -481,8 +481,12 @@ startTorController net conf mbDelay = liftIO $ do log Info "Successfully initialized Tor controller connection." return (Right conn, tid) where + logTorControlErrors :: (CatArg a) => String -> [a] -> IO () logTorControlErrors event = mapM_ (log Warn "Error in " event " event: ") + + logParseErrors :: (CatArg b) => ([a], [b]) -> IO [a] logParseErrors (xs,errors) = mapM_ (log Warn) errors >> return xs + updateDescriptors (NetworkStateManager send _) = send . NewDescriptors updateNetworkStatus (NetworkStateManager send _) = send . NewNetworkStatus nextDelay | delay' < maxDelay = delay' diff --git a/src/TorDNSEL/NetworkState/Storage/Internals.hs b/src/TorDNSEL/NetworkState/Storage/Internals.hs index 0f79cf8..532ae2d 100644 --- a/src/TorDNSEL/NetworkState/Storage/Internals.hs +++ b/src/TorDNSEL/NetworkState/Storage/Internals.hs @@ -137,9 +137,9 @@ startStorageManager initConf = do return (s { exitAddrLen = addrLen, journalLen = 0 }, nullSignal) getFileSize fp = - E.catchJust E.ioErrors + E.catch ((fromIntegral . fileSize) `fmap` getFileStatus fp) - (\e -> if isDoesNotExistError e then return 0 else ioError e) + (\e -> if isDoesNotExistError e then return 0 else E.throwIO e) nullSignal = return () @@ -179,7 +179,7 @@ reconfigureStorageManager reconf (StorageManager tellStorageManager tid) -- be sent. terminateStorageManager :: Maybe Int -> StorageManager -> IO () terminateStorageManager mbWait (StorageManager tellStorageManager tid) = - terminateThread mbWait tid (tellStorageManager $ Terminate Nothing) + terminateThread mbWait tid (tellStorageManager $ Terminate NormalExit) -- | An exit address entry stored in our state directory. The design here is the -- same as Tor uses for storing router descriptors. @@ -241,9 +241,9 @@ 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.catch (B.readFile path) - (\e -> if isDoesNotExistError e then return B.empty else ioError e) + (\e -> if isDoesNotExistError e then return B.empty else E.throwIO e) addrs <- forM (parseSubDocs (B.pack "ExitNode") parseExitAddress . parseDocument . B.lines $ file) $ \exitAddr -> do case exitAddr of diff --git a/src/TorDNSEL/Socks.hs b/src/TorDNSEL/Socks.hs index f3d18f7..56de807 100644 --- a/src/TorDNSEL/Socks.hs +++ b/src/TorDNSEL/Socks.hs @@ -21,7 +21,6 @@ module TorDNSEL.Socks ( -- * Errors , SocksError(..) - , showSocksError ) where import TorDNSEL.Socks.Internals diff --git a/src/TorDNSEL/Socks/Internals.hs b/src/TorDNSEL/Socks/Internals.hs index 7999b91..9f94b45 100644 --- a/src/TorDNSEL/Socks/Internals.hs +++ b/src/TorDNSEL/Socks/Internals.hs @@ -36,7 +36,6 @@ module TorDNSEL.Socks.Internals ( -- * Errors , SocksError(..) - , showSocksError ) where import qualified Control.Exception as E @@ -69,8 +68,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.throwIO (SocksError result) + _ -> E.throwIO SocksProtocolError -------------------------------------------------------------------------------- -- Data types @@ -176,6 +175,4 @@ instance Show SocksError where showsPrec _ (SocksError result) = cat "Socks error: " result showsPrec _ SocksProtocolError = cat "Socks protocol error" --- | Boilerplate conversion of a dynamically typed 'SocksError' to a string. -showSocksError :: Dynamic -> Maybe String -showSocksError = fmap (show :: SocksError -> String) . fromDynamic +instance E.Exception SocksError diff --git a/src/TorDNSEL/Statistics/Internals.hs b/src/TorDNSEL/Statistics/Internals.hs index bb390eb..3932156 100644 --- a/src/TorDNSEL/Statistics/Internals.hs +++ b/src/TorDNSEL/Statistics/Internals.hs @@ -23,6 +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.Fix (fix) import qualified Data.ByteString.Char8 as B import Data.Maybe (isJust, isNothing) @@ -107,19 +108,19 @@ startStatsServer listenSock = do if isNothing $ terminateReason s then do log Warn "The statistics listener thread exited unexpectedly:\ - \ " (showExitReason [] reason) "; restarting." + \ " (show reason) "; restarting." newListenerTid <- forkListener statsChan listenSock handlerQSem loop s { listenerTid = newListenerTid } else loop s | tid `S.member` handlers s -> do - whenJust reason $ + when (isAbnormal reason) $ log Warn "Bug: A statistics client handler exited abnormally: " 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 _ -> loop s { handlers = newHandlers } - | isJust reason -> exit reason + | isAbnormal reason -> exit reason | otherwise -> loop s return $ StatsServer (writeChan statsChan) statsServerTid @@ -133,7 +134,7 @@ forkListener statsChan listenSock sem = forkLinkIO . E.block . forever $ do waitQSem sem (client,_) <- E.unblock $ accept listenSock - `E.catch` \e -> signalQSem sem >> E.throwIO e + `E.onException` signalQSem sem writeChan statsChan $ NewClient client -- | Terminate the stats server gracefully. The optional parameter specifies the @@ -142,7 +143,7 @@ forkListener statsChan listenSock sem = -- sent. terminateStatsServer :: Maybe Int -> StatsServer -> IO () terminateStatsServer mbWait (StatsServer tellStatsServer statsServerTid) = - terminateThread mbWait statsServerTid (tellStatsServer $ Terminate Nothing) + terminateThread mbWait statsServerTid (tellStatsServer $ Terminate NormalExit) -- | Render 'Stats' to text as a sequence of CRLF-terminated lines. renderStats :: Stats -> B.ByteString diff --git a/src/TorDNSEL/TorControl.hs b/src/TorDNSEL/TorControl.hs index 3c42d12..872b938 100644 --- a/src/TorDNSEL/TorControl.hs +++ b/src/TorDNSEL/TorControl.hs @@ -79,7 +79,6 @@ module TorDNSEL.TorControl ( -- * Errors , ReplyCode , TorControlError(..) - , showTorControlError ) where import TorDNSEL.TorControl.Internals diff --git a/src/TorDNSEL/TorControl/Internals.hs b/src/TorDNSEL/TorControl/Internals.hs index 7c0e972..39bb21f 100644 --- a/src/TorDNSEL/TorControl/Internals.hs +++ b/src/TorDNSEL/TorControl/Internals.hs @@ -126,7 +126,6 @@ module TorDNSEL.TorControl.Internals ( , protocolError , parseError , TorControlError(..) - , showTorControlError , toTCError , parseReplyCode , throwIfNotPositive @@ -162,7 +161,6 @@ import TorDNSEL.Control.Concurrent.Util import TorDNSEL.Directory import TorDNSEL.Document import TorDNSEL.Util -improt qualified TorDNSEL.Util ( bracket', finally' ) -------------------------------------------------------------------------------- -- Connections @@ -341,7 +339,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.throwIO $ toTCError command reply where command = Command (B.pack "getinfo") [key] [] maxRepLen = 64 @@ -372,7 +370,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.throwIO $ toTCError command reply where command = Command (B.pack "getinfo") [key] [] check f = either (parseError command) (return . f) maxRepLen = 64 @@ -405,7 +403,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.throwIO $ toTCError command reply where command = Command (B.pack "extendcircuit") args [] args = add purpose [cid, B.intercalate (B.pack ",") $ map encodeBase16RouterID path] @@ -523,11 +521,11 @@ sendCommand' command isQuit mbEvHandlers (tellIOManager,ioManagerTid) = do tellIOManager $ SendCommand command isQuit mbEvHandlers (putResponse.Right) response <- takeMVar mv 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 + Left NormalExit -> E.throwIO ConnectionClosed + Left (AbnormalExit (E.fromException -> Just NonexistentThread)) + -> E.throwIO ConnectionClosed + Left (AbnormalExit e) -> E.throwIO e + Right replies -> return replies -------------------------------------------------------------------------------- -- Config variables @@ -637,7 +635,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.throwIO . ParseError maxVarLen = 64 -------------------------------------------------------------------------------- @@ -664,7 +662,7 @@ newDescriptorsEvent :: newDescriptorsEvent handler conn = EventHandler (B.pack "NEWDESC") handleNewDesc where safeGetDescriptor rid = Right `fmap` getDescriptor rid conn - `E.catchDyn` \(e :: TorControlError) -> return (Left e) + `E.catch` \(e :: TorControlError) -> return (Left e) handleNewDesc (Reply _ text _:_) = do -- pipeline descriptor requests (es',ds) <- fmap partitionEither . mapM resolve @@ -761,15 +759,20 @@ startIOManager handle = do runIOManager $ \loop s -> do message <- readChan ioChan case message of - Exit tid reason + Exit tid _ | tid == evHandlerTid s -> do newEvHandlerTid <- startEventHandler eventChan loop s { evHandlerTid = newEvHandlerTid } - | isNothing reason -> loop s + + Exit _ NormalExit -> loop s + + Exit tid (AbnormalExit (E.fromException -> Just e)) | tid == socketReaderTid - , Just (E.IOException e) <- reason, isEOFError e - , quitSent s, S.null (responds s) -> kill $ evHandlerTid s - | otherwise -> exit reason + , isEOFError e + , quitSent s + , S.null (responds s) -> kill $ evHandlerTid s + + Exit _ reason -> exit reason CloseConnection -> mapM_ kill [socketReaderTid, evHandlerTid s] @@ -806,8 +809,8 @@ startIOManager handle = do | otherwise -> loop Right event -> event >> loop - kill tid = terminateThread Nothing tid . throwTo tid . Just $ - E.AsyncException E.ThreadKilled + kill tid = terminateThread Nothing tid . throwTo tid $ + exitReason E.ThreadKilled renderCommand (Command key args []) = B.intercalate (B.pack " ") (key : args) `B.append` B.pack "\r\n" @@ -838,7 +841,7 @@ startSocketReader handle sendRepliesToIOManager = LastReply reply -> return [reply] parseReplyLine line = - either (E.throwDyn . ProtocolError) (parseReplyLine' typ text) + either (E.throwIO . ProtocolError) (parseReplyLine' typ text) (parseReplyCode code) where (code,(typ,text)) = B.splitAt 1 `second` B.splitAt 3 line @@ -846,7 +849,7 @@ 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 $ + | otherwise = E.throwIO . ProtocolError $ cat "Malformed reply line type " (esc 1 typ) '.' readData = do @@ -1117,10 +1120,7 @@ instance Show TorControlError where showsPrec _ (ProtocolError msg) = cat "Protocol error: " msg showsPrec _ ConnectionClosed = ("Connection is already closed" ++) --- | Boilerplate conversion of a dynamically typed 'TorControlError' to a --- string. -showTorControlError :: Dynamic -> Maybe String -showTorControlError = fmap (show :: TorControlError -> String) . fromDynamic +instance E.Exception TorControlError -- | Given a command, return a \"command failed\" message. commandFailed :: Command -> ShowS @@ -1129,11 +1129,11 @@ 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.throwIO . 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.throwIO . ParseError . cat (commandFailed command) -- | Convert a command and negative reply to a 'TorControlError'. toTCError :: Command -> Reply -> TorControlError @@ -1150,7 +1150,7 @@ parseReplyCode bs throwIfNotPositive :: Command -> Reply -> IO () throwIfNotPositive command reply = unless (isPositive $ repCode reply) $ - E.throwDyn $ toTCError command reply + E.throwIO $ toTCError command reply -- | Is a reply successful? isPositive :: ReplyCode -> Bool diff --git a/src/TorDNSEL/Util.hsc b/src/TorDNSEL/Util.hsc index 4329e68..1cf59b2 100644 --- a/src/TorDNSEL/Util.hsc +++ b/src/TorDNSEL/Util.hsc @@ -49,7 +49,6 @@ module TorDNSEL.Util ( , inet_htoa , encodeBase16 , split - , ignoreJust , syncExceptions , bracket' , finally' @@ -365,10 +364,6 @@ 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 e) => (e -> Maybe a) -> IO () -> IO () -ignoreJust p = E.handleJust p . const . return $ () - -- | A predicate matching synchronous exceptions. -- XXX This is a bad idea. The exn itself conveys no info on how it was thrown. syncExceptions :: E.SomeException -> Maybe E.SomeException @@ -525,13 +520,6 @@ splitByDelimiter delimiter bs = subst (-len : B.findSubstrings delimiter bs) subst [] = error "splitByDelimiter: empty list" len = B.length delimiter --- | 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 - -- | 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

[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

Jump to page:

2025

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

tor-commits April 2016