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