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

[webwml/master] get rid of the orphan "telephone" header
by arma＠torproject.org 16 Apr '16

16 Apr '16

commit eb2c0b7b31a67fe3cd38dd231b32fb2a23e0549e Author: Roger Dingledine <arma(a)torproject.org> Date: Sat Apr 16 15:35:34 2016 -0400 get rid of the orphan "telephone" header (and also the commented out text, since it's unlikely we're going to be turning that back on anytime soon) --- about/en/contact.wml | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/about/en/contact.wml b/about/en/contact.wml index b3d667d..9f790ad 100644 --- a/about/en/contact.wml +++ b/about/en/contact.wml @@ -17,7 +17,6 @@ <li><a href="#email">Email</a></li> <li><a href="#irc">IRC</a></li> <li><a href="#twitter">Twitter</a></li> - <li><a href="#phone">Telephone</a></li> <li><a href="#mail">Mailing Address</a></li> <li><a href="#security">Security Issues</a></li> </ul> @@ -104,16 +103,6 @@ </ul> </p> - - <a id="mail"></a> <h3><a class="anchor" href="#mail">Mailing Address</a></h3> <p>Should you need to reach us via old reliable mail, our mailing

1 0

[stem/master] Add SYSTEM_CALL_TIME to the stem.util.system module
by atagar＠torproject.org 16 Apr '16

16 Apr '16

commit de2e0e3a40b5f01af94bf3093e9cc06b85058789 Author: Damian Johnson <atagar(a)torproject.org> Date: Sat Apr 16 11:43:24 2016 -0700 Add SYSTEM_CALL_TIME to the stem.util.system module Nyx needs the ability to determine how much time is spent on subcommands so we can account for those in our 'nyx cpu usage'. On reflection other applications using os.times() will need this too - easy addition. --- docs/change_log.rst | 1 + stem/util/system.py | 19 ++++++++++++++++++- test/integ/util/system.py | 9 +++++++++ 3 files changed, 28 insertions(+), 1 deletion(-) diff --git a/docs/change_log.rst b/docs/change_log.rst index 1c6f491..13824b2 100644 --- a/docs/change_log.rst +++ b/docs/change_log.rst @@ -84,6 +84,7 @@ The following are only available within Stem's `git repository * Recognize IPv4-mapped IPv6 addresses in our utils (:trac:`18079`) * Allow :func:`stem.util.conf.Config.set` to remove values when provided with a **None** value * Additional information when :func:`~stem.util.system.call` fails through a :class:`~stem.util.system.CallError` + * Added **stem.util.system.SYSTEM_CALL_TIME** with the total time spent on system calls * Added an **is_ipv6** value to :class:`~stem.util.connection.Connection` instances * Added :func:`~stem.util.system.pids_by_user` * Added :func:`~stem.util.__init__.datetime_to_unix` diff --git a/stem/util/system.py b/stem/util/system.py index b9baa28..5ef61c6 100644 --- a/stem/util/system.py +++ b/stem/util/system.py @@ -10,6 +10,10 @@ best-effort, providing **None** if the lookup fails. Dropped the get_* prefix from several function names. The old names still work, but are deprecated aliases. +.. versionchanged:: 1.5.0 + Added the **SYSTEM_CALL_TIME** global, which tracks total time spent making + system commands. + **Module Overview:** :: @@ -52,6 +56,7 @@ import platform import re import subprocess import tarfile +import threading import time import stem.util.proc @@ -127,6 +132,13 @@ _PROCESS_NAME = None _MAX_NAME_LENGTH = -1 +# Tracks total time spent shelling out to other commands like 'ps' and +# 'netstat', so we can account for it as part of our cpu time along with +# os.times(). + +SYSTEM_CALL_TIME = 0.0 +SYSTEM_CALL_TIME_LOCK = threading.RLock() + class CallError(OSError): """ @@ -1035,17 +1047,19 @@ def call(command, default = UNDEFINED, ignore_exit_status = False, env = None): **OSError** subclass """ + global SYSTEM_CALL_TIME + if isinstance(command, str): command_list = command.split(' ') else: command_list = command exit_status, runtime, stdout, stderr = None, None, None, None + start_time = time.time() try: is_shell_command = command_list[0] in SHELL_COMMANDS - start_time = time.time() process = subprocess.Popen(command_list, stdout = subprocess.PIPE, stderr = subprocess.PIPE, shell = is_shell_command, env = env) stdout, stderr = process.communicate() @@ -1078,6 +1092,9 @@ def call(command, default = UNDEFINED, ignore_exit_status = False, env = None): return default else: raise CallError(str(exc), ' '.join(command_list), exit_status, runtime, stdout, stderr) + finally: + with SYSTEM_CALL_TIME_LOCK: + SYSTEM_CALL_TIME += time.time() - start_time def get_process_name(): diff --git a/test/integ/util/system.py b/test/integ/util/system.py index 3207f9d..7933492 100644 --- a/test/integ/util/system.py +++ b/test/integ/util/system.py @@ -563,6 +563,15 @@ class TestSystem(unittest.TestCase): self.assertEqual(home_dir, stem.util.system.expand_path('~%s' % username)) self.assertEqual(os.path.join(home_dir, 'foo'), stem.util.system.expand_path('~%s/foo' % username)) + def test_call_time_tracked(self): + """ + Check that time taken in the call() function is tracked by SYSTEM_CALL_TIME. + """ + + initial = stem.util.system.SYSTEM_CALL_TIME + stem.util.system.call('sleep 0.5') + self.assertTrue(stem.util.system.SYSTEM_CALL_TIME - initial > 0.4) + def test_set_process_name(self): """ Exercises the get_process_name() and set_process_name() methods.

1 0

[tordnsel/master] Add libghc-binary-dev to README
by arlo＠torproject.org 16 Apr '16

16 Apr '16

commit cba10d41cb2d1e3d78675676df5d92093b91dd4f Author: Arlo Breault <arlolra(a)gmail.com> Date: Sat Apr 16 08:15:28 2016 -0700 Add libghc-binary-dev to README --- README | 4 ++-- tordnsel.cabal | 9 ++++----- 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/README b/README index 5159db0..8d9869b 100644 --- a/README +++ b/README @@ -24,8 +24,8 @@ Dependencies TorDNSEL requires GHC 7.6. If you're running Debian Jessie: - apt-get install ghc libghc-network-dev libghc-mtl-dev libghc-stm-dev - libghc-hunit-dev libghc-conduit-dev libghc-conduit-extra-dev + apt-get install ghc libghc-hunit-dev libghc-binary-dev libghc-conduit-dev \ + libghc-conduit-extra-dev libghc-mtl-dev libghc-network-dev libghc-stm-dev OpenSSL's libcrypto is required for strong random numbers: diff --git a/tordnsel.cabal b/tordnsel.cabal index 39a1341..2d0b148 100644 --- a/tordnsel.cabal +++ b/tordnsel.cabal @@ -13,11 +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 Build-Type: Simple -Build-Depends: array>=0.4, base>=4.5, binary>=0.7, bytestring>=0.10, - containers>=0.5, deepseq>=1.3, directory>=1.2, time>=1.4, - unix>=2.5, - HUnit==1.2.*, conduit==1.1.*, conduit-extra==1.1.*, - mtl==2.1.*, network==2.4.*, stm==2.4.* +Build-Depends: array>=0.4, base>=4.5, bytestring>=0.10, containers>=0.5, + deepseq>=1.3, directory>=1.2, time>=1.4, unix>=2.5, + HUnit==1.2.*, binary==0.7.*, conduit==1.1.*, + conduit-extra==1.1.*, mtl==2.1.*, network==2.4.*, stm==2.4.* Tested-With: GHC==7.6 Data-Files: config/tordnsel.conf.sample, contrib/cacti-input.pl, contrib/tordnsel-init.d-script.sample, doc/tordnsel.8

1 0

[tordnsel/master] Add a .travis.yml
by arlo＠torproject.org 16 Apr '16

16 Apr '16

commit 45f6d6846d2ea1cb0d4054451ac12ade19a8dcba Author: Arlo Breault <arlolra(a)gmail.com> Date: Fri Apr 15 19:31:01 2016 -0700 Add a .travis.yml --- .travis.yml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..ca0dd47 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,4 @@ +language: haskell + +ghc: + - 7.6

1 0

[tordnsel/master] Build tests
by arlo＠torproject.org 16 Apr '16

16 Apr '16

commit 80ef12016bf5f5574d306b9edd14d90e8cba7daf Author: Arlo Breault <arlolra(a)gmail.com> Date: Fri Apr 15 21:59:50 2016 -0700 Build tests --- .travis.yml | 4 ++++ src/TorDNSEL/Config/Tests.hs | 10 +++++----- tordnsel.cabal | 18 ++++++++++++++++-- 3 files changed, 25 insertions(+), 7 deletions(-) diff --git a/.travis.yml b/.travis.yml index ca0dd47..66ff6df 100644 --- a/.travis.yml +++ b/.travis.yml @@ -2,3 +2,7 @@ language: haskell ghc: - 7.6 + +script: + - cabal configure --enable-tests --ghc-options="-fno-warn-unused-do-bind" && cabal build + - ./dist/build/runtests/runtests diff --git a/src/TorDNSEL/Config/Tests.hs b/src/TorDNSEL/Config/Tests.hs index e7b9a54..5065b54 100644 --- a/src/TorDNSEL/Config/Tests.hs +++ b/src/TorDNSEL/Config/Tests.hs @@ -37,7 +37,7 @@ config = toConfig [ "ZoneOfAuthority" ~> "exitlist.example.com." , "DomainName" ~> "exitlist-ns.example.com." , "SOARName" ~> "hostmaster.example.com." - , "StateDirectory" ~> "/state" + , "StateDirectory" ~> "/state/" , "RuntimeDirectory" ~> "/srv/tordnsel/run/" , "DNSListenAddress" ~> "127.0.0.1:53" , "Address" ~> "10.0.0.1" @@ -78,10 +78,10 @@ configFile = \\n\ \## Store exit test results in this directory. This should be an absolute\n\ \## path accessible inside the chroot (if one is configured).\n\ - \#StateDirectory /srv/tordnsel/state\n\ + \#StateDirectory /srv/tordnsel/state/\n\ \## This line is equivalent to the previous line if you've specified\n\ - \## ChangeRootDirectory as /srv/tordnsel.\n\ - \StateDirectory /state\n\ + \## ChangeRootDirectory as /srv/tordnsel/.\n\ + \StateDirectory /state/\n\ \\n\ \## Place the statistics and reconfigure sockets in this directory before\n\ \## chrooting or dropping privileges.\n\ @@ -138,7 +138,7 @@ configFile = \\n\ \## Call chroot(2) to change our root directory. This option also requires\n\ \## root privileges.\n\ - \ChangeRootDirectory /srv/tordnsel\n\ + \ChangeRootDirectory /srv/tordnsel/\n\ \\n\ \## Write our PID to the specified file before chrooting or dropping\n\ \## privileges. This file won't be removed on exit.\n\ diff --git a/tordnsel.cabal b/tordnsel.cabal index 177f7f4..39a1341 100644 --- a/tordnsel.cabal +++ b/tordnsel.cabal @@ -77,13 +77,27 @@ Extensions: FlexibleContexts StandaloneDeriving Executable: runtests -Buildable: False +Buildable: True Main-Is: runtests.hs Other-Modules: TorDNSEL.Config.Tests TorDNSEL.Directory.Tests TorDNSEL.DNS.Tests TorDNSEL.DNS.Server.Tests + TorDNSEL.Util + TorDNSEL.Log.Internals +Extensions: FlexibleContexts + FlexibleInstances + TypeSynonymInstances + MultiParamTypeClasses + PatternGuards + BangPatterns + ViewPatterns + ScopedTypeVariables + DeriveDataTypeable + GeneralizedNewtypeDeriving + Rank2Types + StandaloneDeriving HS-Source-Dirs: src Includes: netinet/in.h, openssl/rand.h Extra-Libraries: crypto -GHC-Options: -Wall -Werror -fno-warn-missing-signatures +GHC-Options: -Wall -fno-warn-missing-signatures

1 0

[tordnsel/master] Tested with GHC==7.6
by arlo＠torproject.org 16 Apr '16

16 Apr '16

commit de090504160d40f6d860b1269672895b655212f4 Author: Arlo Breault <arlolra(a)gmail.com> Date: Fri Apr 15 19:27:28 2016 -0700 Tested with GHC==7.6 --- README | 6 +++--- src/TorDNSEL/Util.hsc | 16 +++------------- tordnsel.cabal | 14 ++++++++------ 3 files changed, 14 insertions(+), 22 deletions(-) diff --git a/README b/README index 214b582..5159db0 100644 --- a/README +++ b/README @@ -22,10 +22,10 @@ Presumably, users of software with built-in support for DNSBLs would configure Dependencies - TorDNSEL requires GHC 6.8. If you're running Debian Lenny: + TorDNSEL requires GHC 7.6. If you're running Debian Jessie: - apt-get install ghc6 libghc6-mtl-dev libghc6-network-dev libghc6-time-dev \ - libghc6-hunit-dev libghc6-stm-dev libghc6-binary-dev + apt-get install ghc libghc-network-dev libghc-mtl-dev libghc-stm-dev + libghc-hunit-dev libghc-conduit-dev libghc-conduit-extra-dev OpenSSL's libcrypto is required for strong random numbers: diff --git a/src/TorDNSEL/Util.hsc b/src/TorDNSEL/Util.hsc index 12493fe..8af374c 100644 --- a/src/TorDNSEL/Util.hsc +++ b/src/TorDNSEL/Util.hsc @@ -141,7 +141,7 @@ import System.Posix.Types (FileMode) import Text.Printf (printf) import Data.Binary (Binary(..)) -import Data.Conduit (Pipe(..), Conduit, Sink) +import Data.Conduit.Internal (Conduit, Sink) import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import qualified Data.Conduit.Binary as CB @@ -432,12 +432,6 @@ 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 -> Sink ByteString m ByteString c_take = fmap (mconcat . BL.toChunks) . CB.take @@ -450,7 +444,7 @@ c_breakDelim :: Monad m c_breakDelim delim = wait_input $ B.empty where wait_input front = C.await >>= - (Nothing <$ leftover front) `maybe` \bs -> + (Nothing <$ C.leftover front) `maybe` \bs -> let (front', bs') = (<> bs) `second` B.splitAt (B.length front - d_len + 1) front @@ -466,7 +460,7 @@ c_breakDelim delim = wait_input $ B.empty 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 <$ leftover rest + return B.empty `maybe` \(line, rest) -> line <$ C.leftover rest -- | Stream lines delimited by either LF or CRLF. c_lines_any :: Monad m => Conduit ByteString m ByteString @@ -511,10 +505,6 @@ bindListeningUnixDomainStreamSocket sockPath mode = do listen sock sOMAXCONN return sock --- network-2.3 compat --- -deriving instance Ord SockAddr - -------------------------------------------------------------------------------- -- Monads diff --git a/tordnsel.cabal b/tordnsel.cabal index 0b5182c..177f7f4 100644 --- a/tordnsel.cabal +++ b/tordnsel.cabal @@ -11,12 +11,14 @@ License-File: LICENSE Homepage: http://p56soo2ibjkx23xo.onion/ Package-URL: https://archive.torproject.org/tor-package-archive/tordnsel/tordnsel-0.1.1.… Author: tup -Maintainer: tup.tuple(a)googlemail.com, lunar(a)debian.org, andrew(a)torproject.org +Maintainer: tup.tuple(a)googlemail.com, lunar(a)debian.org Build-Type: Simple -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 +Build-Depends: array>=0.4, base>=4.5, binary>=0.7, bytestring>=0.10, + containers>=0.5, deepseq>=1.3, directory>=1.2, time>=1.4, + unix>=2.5, + HUnit==1.2.*, conduit==1.1.*, conduit-extra==1.1.*, + mtl==2.1.*, network==2.4.*, stm==2.4.* +Tested-With: GHC==7.6 Data-Files: config/tordnsel.conf.sample, contrib/cacti-input.pl, contrib/tordnsel-init.d-script.sample, doc/tordnsel.8 @@ -59,7 +61,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 -fno-warn-unused-do-bind -Wall -Werror +GHC-Options: -O2 -funbox-strict-fields -fno-warn-unused-do-bind -Wall CPP-Options: -DVERSION="0.1.1-dev" Extensions: FlexibleContexts FlexibleInstances

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

[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] 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] 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