commit 5a70559f8ca976e51d830f6fafb12b045f577055 Author: David Kaloper david@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