diff --git a/io-streams.cabal b/io-streams.cabal --- a/io-streams.cabal +++ b/io-streams.cabal @@ -1,5 +1,5 @@ Name: io-streams -Version: 1.1.2.2 +Version: 1.1.3.0 License: BSD3 License-file: LICENSE Category: Data, Network, IO-Streams @@ -81,6 +81,12 @@ . /ChangeLog/ . + [@1.1.3.0@] Added @System.IO.Streams.ByteString.takeExactly@. Widened + @network@ dependency to include 2.3. Added a + @NoInteractiveTests@ flag to selectively disable some tests for + environments where spawning interactive processes is + impossible. + . [@1.1.2.2@] Allowed newest versions of the @process@, @test-framework@, and @text@ libraries. . @@ -126,6 +132,10 @@ Extra-Source-Files: CONTRIBUTORS README.md +Flag NoInteractiveTests + Description: Do not run interactive tests + Default: False + ------------------------------------------------------------------------------ Library hs-source-dirs: src @@ -162,7 +172,7 @@ attoparsec >= 0.10 && <0.11, blaze-builder >= 0.3.1 && <0.4, bytestring >= 0.9 && <0.11, - network >= 2.4 && <2.5, + network >= 2.3 && <2.5, primitive >= 0.2 && <0.6, process >= 1 && <1.3, text >= 0.10 && <1.1, @@ -234,7 +244,7 @@ -fno-warn-unused-do-bind ghc-prof-options: -prof -auto-all - if !os(windows) + if !os(windows) && !flag(NoInteractiveTests) cpp-options: -DENABLE_PROCESS_TESTS @@ -246,7 +256,7 @@ directory >= 1.1 && <2, filepath >= 1.2 && <2, mtl >= 2 && <3, - network >= 2.4 && <2.5, + network >= 2.3 && <2.5, primitive >= 0.2 && <0.6, process >= 1 && <1.3, text >= 0.10 && <1.1, diff --git a/src/System/IO/Streams/ByteString.hs b/src/System/IO/Streams/ByteString.hs --- a/src/System/IO/Streams/ByteString.hs +++ b/src/System/IO/Streams/ByteString.hs @@ -29,6 +29,7 @@ , giveBytes , giveExactly , takeBytes + , takeExactly , throwIfConsumesMoreThan , throwIfProducesMoreThan @@ -215,7 +216,29 @@ takeBytes :: Int64 -- ^ maximum number of bytes to read -> InputStream ByteString -- ^ input stream to wrap -> IO (InputStream ByteString) -takeBytes k0 src = do +takeBytes k0 = takeBytes' k0 (return Nothing) +{-# INLINE takeBytes #-} + + +------------------------------------------------------------------------------ +-- | Like @Streams.'takeBytes'@, but throws 'ReadTooShortException' when +-- there aren't enough bytes present on the source. +takeExactly :: Int64 -- ^ number of bytes to read + -> InputStream ByteString -- ^ input stream to wrap + -> IO (InputStream ByteString) +takeExactly k0 = takeBytes' k0 (throwIO $ ReadTooShortException k0) +{-# INLINE takeExactly #-} + + +------------------------------------------------------------------------------ +-- Helper for the two above. +takeBytes' :: Int64 + -> IO (Maybe ByteString) + -- ^ What to do if the input ends before having consumed the + -- right amount of bytes. + -> InputStream ByteString + -> IO (InputStream ByteString) +takeBytes' k0 h src = do kref <- newIORef k0 return $! InputStream (prod kref) (pb kref) where @@ -223,7 +246,7 @@ k <- readIORef kref if k <= 0 then return Nothing - else read src >>= maybe (return Nothing) (chunk k) + else read src >>= maybe h (chunk k) where chunk k s = do let l = fromIntegral $ S.length s @@ -239,6 +262,7 @@ pb kref s = do modifyRef kref (+ (fromIntegral $ S.length s)) unRead s src +{-# INLINE takeBytes' #-} ------------------------------------------------------------------------------ @@ -404,8 +428,9 @@ ------------------------------------------------------------------------------ --- | Thrown by 'readExactly' when not enough bytes were available on the input. -data ReadTooShortException = ReadTooShortException Int deriving (Typeable) +-- | Thrown by 'readExactly' and 'takeExactly' when not enough bytes were +-- available on the input. +data ReadTooShortException = ReadTooShortException Int64 deriving (Typeable) instance Show ReadTooShortException where show (ReadTooShortException x) = "Short read, expected " ++ show x @@ -501,7 +526,7 @@ go !dl 0 = return $! S.concat $! dl [] go !dl k = read input >>= - maybe (throwIO $ ReadTooShortException n) + maybe (throwIO $ ReadTooShortException (fromIntegral n)) (\s -> do let l = S.length s if l >= k diff --git a/test/System/IO/Streams/Tests/ByteString.hs b/test/System/IO/Streams/Tests/ByteString.hs --- a/test/System/IO/Streams/Tests/ByteString.hs +++ b/test/System/IO/Streams/Tests/ByteString.hs @@ -43,6 +43,9 @@ , testTakeBytes2 , testTakeBytes3 , testTakeBytes4 + , testTakeExactly + , testTakeExactly2 + , testTakeExactly3 , testThrowIfProducesMoreThan , testThrowIfProducesMoreThan2 , testThrowIfProducesMoreThan3 @@ -142,7 +145,6 @@ assertEqual "take2" b y ) - ------------------------------------------------------------------------------ testTakeBytes2 :: Test testTakeBytes2 = testProperty "bytestring/takeBytes2" $ @@ -189,6 +191,47 @@ mb <- timeout 100000 $ toList is assertBool "takeBytes4" $ isJust mb + +------------------------------------------------------------------------------ +testTakeExactly :: Test +testTakeExactly = testProperty "bytestring/takeExactly" $ + monadicIO $ + forAllM arbitrary prop + where + prop :: L.ByteString -> PropertyM IO () + prop l = pre (L.length l > 5) >> liftQ (do + let (a,b) = L.splitAt 4 l + + is <- fromList (L.toChunks l) + is' <- takeExactly 4 is + + x <- liftM L.fromChunks $ toList is' + y <- liftM L.fromChunks $ toList is + + assertEqual "take1" a x + assertEqual "take2" b y + ) + +------------------------------------------------------------------------------ +testTakeExactly2 :: Test +testTakeExactly2 = testProperty "bytestring/takeExactly2" $ + monadicIO $ + forAllM arbitrary prop + where + prop :: L.ByteString -> PropertyM IO () + prop l = pre (L.length l < 10) >> liftQ (do + is <- fromList (L.toChunks l) + is' <- takeExactly 10 is + + expectExceptionH $ toList is' + ) + +------------------------------------------------------------------------------ +testTakeExactly3 :: Test +testTakeExactly3 = testCase "bytestring/takeExactly3" $ do + is <- fromList ["one", "two"] + is' <- takeExactly 7 is + expectExceptionH $ toList is' ------------------------------------------------------------------------------ testThrowIfProducesMoreThan :: Test diff --git a/test/System/IO/Streams/Tests/Network.hs b/test/System/IO/Streams/Tests/Network.hs --- a/test/System/IO/Streams/Tests/Network.hs +++ b/test/System/IO/Streams/Tests/Network.hs @@ -44,18 +44,18 @@ Streams.fromList ["", "ok"] >>= Streams.connectTo os N.shutdown sock N.ShutdownSend Streams.toList is >>= putMVar resultMVar - N.close sock + N.sClose sock server mvar = do sock <- N.socket N.AF_INET N.Stream N.defaultProtocol addr <- N.inet_addr "127.0.0.1" let saddr = N.SockAddrInet N.aNY_PORT addr - N.bind sock saddr + N.bindSocket sock saddr N.listen sock 5 port <- N.socketPort sock putMVar mvar port (csock, _) <- N.accept sock (is, os) <- Streams.socketToStreams csock Streams.toList is >>= flip Streams.writeList os - N.close csock - N.close sock + N.sClose csock + N.sClose sock