bytestring-handle (empty) → 0.1.0.0
raw patch · 7 files changed
+569/−0 lines, 7 filesdep +HUnitdep +QuickCheckdep +basesetup-changed
Dependencies added: HUnit, QuickCheck, base, bytestring, bytestring-handle, test-framework, test-framework-hunit, test-framework-quickcheck2
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- bytestring-handle.cabal +38/−0
- src/Data/ByteString/Handle.hs +6/−0
- src/Data/ByteString/Handle/Read.hs +188/−0
- src/Data/ByteString/Handle/Write.hs +186/−0
- test/Test.hs +119/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Ganesh Sittampalam++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Ganesh Sittampalam nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bytestring-handle.cabal view
@@ -0,0 +1,38 @@+name: bytestring-handle+version: 0.1.0.0+synopsis: ByteString-backed Handles+-- description:+homepage: http://hub.darcs.net/ganesh/bytestring-handle+license: BSD3+license-file: LICENSE+author: Ganesh Sittampalam+maintainer: Ganesh Sittampalam <ganesh@earth.li>+-- copyright:+category: System+build-type: Simple+cabal-version: >=1.8++library+ exposed-modules: Data.ByteString.Handle+ other-modules:+ Data.ByteString.Handle.Read+ Data.ByteString.Handle.Write+ build-depends: bytestring >= 0.9.1.5 && < 0.11,+ base >= 4.2 && < 4.7+ hs-source-dirs: src++test-suite test+ type: exitcode-stdio-1.0++ hs-source-dirs: test+ main-is: Test.hs++ build-depends:+ QuickCheck >= 2.1.2 && < 2.6,+ test-framework-quickcheck2 >= 0.2.5 && < 0.4,+ HUnit >= 1.2 && < 1.3,+ test-framework-hunit >= 0.2.0 && < 0.4,+ test-framework >= 0.2.0 && < 0.9,+ bytestring >= 0.9.1.5 && < 0.11,+ base >= 4.2 && < 4.7,+ bytestring-handle
+ src/Data/ByteString/Handle.hs view
@@ -0,0 +1,6 @@+module Data.ByteString.Handle+ ( readHandle, writeHandle+ ) where++import Data.ByteString.Handle.Read ( readHandle )+import Data.ByteString.Handle.Write ( writeHandle )
+ src/Data/ByteString/Handle/Read.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE CPP, DeriveDataTypeable #-}+module Data.ByteString.Handle.Read+ ( readHandle+ ) where++import Control.Monad ( when )+import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as BI+import qualified Data.ByteString.Lazy as BL+import Data.IORef ( IORef, newIORef, readIORef, modifyIORef, writeIORef )+import Data.Maybe ( fromMaybe )+import Data.Typeable ( Typeable )+import Data.Word ( Word8 )+import Foreign.ForeignPtr ( newForeignPtr_ )+import Foreign.Ptr ( nullPtr )+import System.IO+ ( Handle, IOMode( ReadMode )+ , noNewlineTranslation, nativeNewlineMode+ )++import GHC.IO.Buffer ( BufferState(..), emptyBuffer, Buffer(..) )+import GHC.IO.BufferedIO ( BufferedIO(..) )+import GHC.IO.Device ( IODevice(..), IODeviceType(..), SeekMode(..) )+#if MIN_VERSION_base(4,5,0)+import GHC.IO.Encoding ( getLocaleEncoding )+#else+import GHC.IO.Encoding ( localeEncoding )+#endif+import GHC.IO.Exception+ ( ioException, unsupportedOperation+ , IOException(IOError), IOErrorType(InvalidArgument)+ )+import GHC.IO.Handle ( mkFileHandle )+++data SeekState =+ SeekState {+ -- a reversed list of the chunks before the current seek position+ seek_before :: [B.ByteString],+ -- a list of the chunks including and after the current seek position+ seek_after :: [B.ByteString],+ -- an index into the first chunk of seek_after+ seek_pos :: !Int,+ -- total length of seek_before : redundant info for cheaply answering 'tell'+ seek_before_length :: !Integer+ }++data ReadState =+ ReadState {+ read_chunks :: [B.ByteString],+ -- reverse list for use with SeekFromEnd - lazily constructed+ read_chunks_backwards :: [B.ByteString],+ -- for use with getSize and SeekFromEnd - lazily constructed+ read_length :: Integer,+ read_seek_state :: IORef SeekState+ }+ deriving Typeable++nullReadBuffer = do+ ptr <- newForeignPtr_ nullPtr+ return $ emptyBuffer ptr+ 0+ ReadBuffer++instance BufferedIO ReadState where+ emptyWriteBuffer _ _ = ioException unsupportedOperation+ flushWriteBuffer _ _ = ioException unsupportedOperation+ flushWriteBuffer0 _ _ = ioException unsupportedOperation++ newBuffer _ WriteBuffer = ioException unsupportedOperation+ newBuffer rs ReadBuffer = nullReadBuffer++ fillReadBuffer rs bufIn = do+ (count, buf) <- fillReadBuffer0 rs bufIn+ return (fromMaybe 0 count, buf)++ fillReadBuffer0 rs _ = do+ ss <- readIORef (read_seek_state rs)+ case seek_after ss of+ [] -> do+ buf <- nullReadBuffer+ return (Nothing, buf)+ (chunk:chunks) ->+ let (ptr, bsOffset, _) = BI.toForeignPtr chunk+ buf = (emptyBuffer ptr (bsOffset + B.length chunk) ReadBuffer) {+ bufL = bsOffset + seek_pos ss, bufR = bsOffset + B.length chunk+ }+ in do writeIORef (read_seek_state rs)+ (SeekState {+ seek_before = chunk:seek_before ss,+ seek_after = chunks,+ seek_pos = 0,+ seek_before_length = fromIntegral (B.length chunk) + seek_before_length ss+ })+ return (Just (B.length chunk - seek_pos ss), buf)+++normalisedSeekState :: [B.ByteString] -> [B.ByteString] -> Integer -> Integer -> Maybe SeekState+normalisedSeekState (x:before) after beforeLen pos+ | pos < 0 = normalisedSeekState+ before+ (x:after)+ (beforeLen - fromIntegral (B.length x))+ (pos + fromIntegral (B.length x))+normalisedSeekState [] _ _ pos+ | pos < 0 = Nothing+normalisedSeekState before (x:after) beforeLen pos+ | pos >= fromIntegral (B.length x)+ = normalisedSeekState+ (x:before)+ after+ (beforeLen + fromIntegral (B.length x))+ (pos - fromIntegral (B.length x))+normalisedSeekState _ [] _ pos+ | pos > 0 = Nothing+normalisedSeekState before after beforeLen pos =+ Just (SeekState {+ seek_before = before,+ seek_after = after,+ seek_pos = fromIntegral pos,+ seek_before_length = beforeLen+ })+++instance IODevice ReadState where+ ready _ _ _ = return True+ close _ = return ()++ isSeekable _ = return True++ seek rs seekMode seekPos = do+ size <- getSize rs+ curSeekState <- readIORef (read_seek_state rs)+ let newSeekState =+ case seekMode of+ AbsoluteSeek -> normalisedSeekState [] (read_chunks rs) 0 seekPos+ RelativeSeek -> normalisedSeekState (seek_before curSeekState)+ (seek_after curSeekState)+ (seek_before_length curSeekState)+ (fromIntegral (seek_pos curSeekState) + seekPos)+ SeekFromEnd -> normalisedSeekState (read_chunks_backwards rs) [] (read_length rs) seekPos+ maybe ioe_seekOutOfRange (writeIORef (read_seek_state rs)) newSeekState++ tell rs = do+ ss <- readIORef (read_seek_state rs)+ return (seek_before_length ss + fromIntegral (seek_pos ss))++ getSize = return . read_length+ setSize _ _ = ioException unsupportedOperation++ devType _ = return RegularFile -- TODO: is this correct?++ioe_seekOutOfRange :: IO a+ioe_seekOutOfRange =+ ioException $ IOError Nothing InvalidArgument ""+ "attempt to seek outside the file" Nothing Nothing++readHandle :: Bool -> BL.ByteString -> IO Handle+readHandle binary bs = do+ let chunks = BL.toChunks bs++ let ss = SeekState {+ seek_before = [],+ seek_after = chunks,+ seek_pos = 0,+ seek_before_length = 0+ }++ ssref <- newIORef ss++ let rs = ReadState {+ read_chunks = chunks,+ read_chunks_backwards = reverse chunks,+ read_seek_state = ssref,+ read_length = sum (map (fromIntegral . B.length) chunks)+ }++#if MIN_VERSION_base(4,5,0)+ localeEnc <- getLocaleEncoding+#else+ localeEnc <- return localeEncoding+#endif++ let (encoding, newline)+ | binary = (Nothing , noNewlineTranslation)+ | otherwise = (Just localeEnc, nativeNewlineMode )++ mkFileHandle rs "ByteString" ReadMode encoding newline
+ src/Data/ByteString/Handle/Write.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE CPP, DeriveDataTypeable #-}+module Data.ByteString.Handle.Write+ ( writeHandle+ ) where++import Control.Monad ( when )+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Internal as BI+import qualified Data.ByteString.Lazy.Internal as BLI+import Data.IORef ( IORef, newIORef, readIORef, modifyIORef, writeIORef )+import Data.Typeable ( Typeable )+import System.IO+ ( Handle, hClose, IOMode( WriteMode )+ , noNewlineTranslation, nativeNewlineMode+ )++import GHC.IO.Buffer ( BufferState(..), emptyBuffer, Buffer(..) )+import GHC.IO.BufferedIO ( BufferedIO(..) )+import GHC.IO.Device ( IODevice(..), IODeviceType(..), SeekMode(..) )+#if MIN_VERSION_base(4,5,0)+import GHC.IO.Encoding ( getLocaleEncoding )+#else+import GHC.IO.Encoding ( localeEncoding )+#endif+import GHC.IO.Exception+ ( ioException, unsupportedOperation+ , IOException(IOError), IOErrorType(InvalidArgument)+ )+import GHC.IO.Handle ( mkFileHandle )++data SeekState =+ SeekState {+ seek_pos :: Integer,+ -- the start position of the current chunk+ seek_base :: Integer+ }++data WriteState =+ WriteState {+ -- the Integer is the cumulative size of the chunk + all those before it in the + write_chunks_backwards :: IORef [(Integer, B.ByteString)],+ write_seek_state :: IORef SeekState,+ write_size :: IORef Integer+ }+ deriving Typeable++nextChunkSize :: Int -> Int+nextChunkSize lastSize+ | lastSize < 16 = 16 -- the minimum size currently targeted by Data.ByteString.Lazy.cons'+ | 2 * lastSize >= BLI.defaultChunkSize = BLI.defaultChunkSize+ | otherwise = 2 * lastSize++chunkForPosition :: Integer -> IORef [(Integer, B.ByteString)] -> IO (Integer, B.ByteString)+chunkForPosition pos chunks_backwards_ref = do+ when (pos > 1000000) $ error "gone"+ chunks_backwards <- readIORef chunks_backwards_ref+ let (curSize, lastSize) =+ case chunks_backwards of+ [] -> (0, 0)+ ((sz, c):_) -> (sz, B.length c)+ if pos < curSize+ then do+ let (sz, c) = head $ dropWhile (\(sz, c) -> pos < sz - fromIntegral (B.length c)) chunks_backwards+ return (sz - fromIntegral (B.length c), c)+ else do+ let sz = nextChunkSize lastSize+ newChunk <- BI.mallocByteString sz+ let bs = BI.fromForeignPtr newChunk 0 sz+ writeIORef chunks_backwards_ref ((curSize + fromIntegral sz, bs):chunks_backwards)+ chunkForPosition pos chunks_backwards_ref++initialWriteState :: IO WriteState+initialWriteState = do+ chunks <- newIORef []+ pos <- newIORef $ SeekState { seek_pos = 0, seek_base = 0 }+ sz <- newIORef 0++ return $ + WriteState {+ write_chunks_backwards = chunks,+ write_seek_state = pos,+ write_size = sz+ }++instance BufferedIO WriteState where+ newBuffer _ ReadBuffer = ioException unsupportedOperation+ newBuffer ws WriteBuffer = do+ ss <- readIORef (write_seek_state ws) + (chunkBase, chunk) <- chunkForPosition (seek_pos ss) (write_chunks_backwards ws)+ let chunkOffset = fromIntegral (seek_pos ss - chunkBase)+ let (ptr, bsOffset, len) = BI.toForeignPtr chunk+ buf = (emptyBuffer ptr (bsOffset + len) WriteBuffer) {+ bufL = bsOffset + chunkOffset, bufR = bsOffset + chunkOffset+ }+ writeIORef (write_seek_state ws) (ss { seek_base = chunkBase - fromIntegral bsOffset })+ return buf++ -- default impl for emptyWriteBuffer++ flushWriteBuffer ws buf = do+ ss <- readIORef (write_seek_state ws)+ let newPos = seek_base ss + fromIntegral (bufR buf)+ writeIORef (write_seek_state ws)+ (SeekState { seek_pos = newPos,+ seek_base = error "seek_base needs to be updated"+ })+ modifyIORef (write_size ws) (`max` newPos)+ newBuffer ws WriteBuffer++ flushWriteBuffer0 ws buf = do+ let count = bufR buf - bufL buf+ newBuf <- flushWriteBuffer ws buf+ return (count, newBuf)++ fillReadBuffer _ _ = ioException unsupportedOperation++ fillReadBuffer0 _ _ = ioException unsupportedOperation++instance IODevice WriteState where+ ready _ _ _ = return True+ close ws = return ()++ isSeekable _ = return True++ seek ws seekMode seekPos = do+ curSeekState <- readIORef (write_seek_state ws)+ newSeekPos <-+ case seekMode of+ AbsoluteSeek -> return seekPos+ RelativeSeek -> return $ seek_pos curSeekState + seekPos+ -- can probably assume last buffer is flushed, so could probably count the+ -- current end pos if we really wanted to+ SeekFromEnd -> ioException unsupportedOperation+ when (newSeekPos < 0) $ ioe_seekOutOfRange+ writeIORef (write_seek_state ws)+ (SeekState { seek_pos = newSeekPos,+ seek_base = error "seek_base needs to be updated"+ })+ modifyIORef (write_size ws) (`max` newSeekPos)++ tell ws = do+ ss <- readIORef (write_seek_state ws)+ return (seek_pos ss)++ getSize ws = readIORef (write_size ws)+ setSize ws sz = do+ writeIORef (write_size ws) sz+ -- force chunk creation+ _ <- chunkForPosition sz (write_chunks_backwards ws)+ return ()++ devType _ = return RegularFile -- TODO: is this correct?++ioe_seekOutOfRange :: IO a+ioe_seekOutOfRange =+ ioException $ IOError Nothing InvalidArgument ""+ "attempt to seek outside the file" Nothing Nothing++writeHandle :: Bool -> (Handle -> IO a) -> IO (BL.ByteString, a)+writeHandle binary doOutput = do++ ws <- initialWriteState++#if MIN_VERSION_base(4,5,0)+ localeEnc <- getLocaleEncoding+#else+ localeEnc <- return localeEncoding+#endif++ let (encoding, newline)+ | binary = (Nothing , noNewlineTranslation)+ | otherwise = (Just localeEnc, nativeNewlineMode )++ handle <- mkFileHandle ws "ByteString" WriteMode encoding newline++ res <- doOutput handle++ hClose handle++ sz <- readIORef (write_size ws)+ chunks_backwards <- readIORef (write_chunks_backwards ws)++ let bs = BL.take (fromIntegral sz) . BL.fromChunks . reverse . map snd $ chunks_backwards++ return (bs, res)
+ test/Test.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE ScopedTypeVariables #-}+import Control.Applicative ( (<$>) )+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BLC+import Data.Char ( chr )+import Data.Int ( Int64 )+import System.IO+ ( Handle, hGetContents, hSeek, SeekMode(..), hPutStr+ , TextEncoding, hSetEncoding, utf8, latin1+ )+import System.IO.Unsafe ( unsafePerformIO )++import Test.HUnit+import Test.Framework ( defaultMain )+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2 ( testProperty )+import Test.QuickCheck ( (==>), Property )+import Test.QuickCheck.Arbitrary ( Arbitrary(..) )++import Data.ByteString.Handle ( readHandle, writeHandle )++instance Arbitrary BL.ByteString where+ arbitrary = fmap BL.pack arbitrary++readViaHandle :: Bool -> BL.ByteString -> (Handle -> IO a) -> a+readViaHandle binary bs f = unsafePerformIO $ readHandle binary bs >>= f++writeViaHandle :: Bool -> (Handle -> IO ()) -> BL.ByteString+writeViaHandle binary f = fst $ unsafePerformIO $ writeHandle binary f++simpleBinaryReadRoundTrip :: BL.ByteString -> Bool+simpleBinaryReadRoundTrip bs =+ -- ironically, BL.hGetContents doesn't like ByteString-backed handles - fails with "Not an FD"+ bs == readViaHandle True bs (\h -> BLC.pack <$> hGetContents h)++prop_SimpleBinaryReadRoundTrip :: BL.ByteString -> Bool+prop_SimpleBinaryReadRoundTrip bs = simpleBinaryReadRoundTrip bs++simpleBinaryWriteRoundTrip :: BL.ByteString -> Bool+simpleBinaryWriteRoundTrip bs =+ bs == writeViaHandle True (\h -> hPutStr h (BLC.unpack bs))++prop_SimpleBinaryWriteRoundTrip :: BL.ByteString -> Bool+prop_SimpleBinaryWriteRoundTrip bs = simpleBinaryWriteRoundTrip bs++-- testing segments of bytestrings is important because they are internally represented+-- using offsets into the original bytestrings++tailBinaryReadRoundTrip :: BL.ByteString -> Bool+tailBinaryReadRoundTrip bs =+ BL.tail bs == readViaHandle True (BL.tail bs) (\h -> BLC.pack <$> hGetContents h)++prop_TailBinaryReadRoundTrip :: BL.ByteString -> Property+prop_TailBinaryReadRoundTrip bs = not (BL.null bs) ==> tailBinaryReadRoundTrip bs++seekBinaryReadRoundTrip :: BL.ByteString -> Bool+seekBinaryReadRoundTrip bs =+ BL.tail bs == readViaHandle True bs (\h -> do { hSeek h AbsoluteSeek 1 ; BLC.pack <$> hGetContents h })++prop_SeekBinaryReadRoundTrip :: BL.ByteString -> Property+prop_SeekBinaryReadRoundTrip bs = not (BL.null bs) ==> seekBinaryReadRoundTrip bs++initBinaryReadRoundTrip :: BL.ByteString -> Bool+initBinaryReadRoundTrip bs =+ BL.init bs == readViaHandle True (BL.init bs) (\h -> BLC.pack <$> hGetContents h)++prop_InitBinaryReadRoundTrip :: BL.ByteString -> Property+prop_InitBinaryReadRoundTrip bs = not (BL.null bs) ==> initBinaryReadRoundTrip bs++takeBinaryReadRoundTrip :: Int64 -> BL.ByteString -> Bool+takeBinaryReadRoundTrip n bs =+ BL.take n bs == BL.take n (readViaHandle True bs (\h -> BLC.pack <$> hGetContents h))++takeSeekBinaryReadRoundTrip :: Int64 -> BL.ByteString -> Bool+takeSeekBinaryReadRoundTrip n bs =+ BL.take n (BL.tail bs) == BL.take n (readViaHandle True bs (\h -> do { hSeek h AbsoluteSeek 1 ; BLC.pack <$> hGetContents h }))++-- several times the default 32K chunk size+bigByteString :: BL.ByteString+bigByteString = BL.pack $ concat $ replicate 1000 $ [0..255] ++ [1..100]++infiniteByteString :: BL.ByteString+infiniteByteString = BL.cycle $ BL.pack $ [0..255] ++ [1..100]++encode :: TextEncoding -> String -> BL.ByteString+encode te str = writeViaHandle True (\h -> do { hSetEncoding h te ; hPutStr h str })++decode :: TextEncoding -> BL.ByteString -> String+decode te bs = readViaHandle True bs (\h -> do { hSetEncoding h te ; hGetContents h })++tests =+ [ testProperty "Simple binary read roundtrip" prop_SimpleBinaryReadRoundTrip+ , testProperty "Tail binary read roundtrip" prop_TailBinaryReadRoundTrip+ , testProperty "Init binary read roundtrip" prop_InitBinaryReadRoundTrip+ , testProperty "Seek binary read roundtrip" prop_SeekBinaryReadRoundTrip+ , testCase "Big bytestring binary read roundtrip" $+ assertBool "roundtrip succeeded" (simpleBinaryReadRoundTrip bigByteString)+ , testCase "Big bytestring tail binary read roundtrip" $+ assertBool "roundtrip succeeded" (tailBinaryReadRoundTrip bigByteString)+ , testCase "Big bytestring init binary read roundtrip" $+ assertBool "roundtrip succeeded" (initBinaryReadRoundTrip bigByteString)+ , testCase "Big bytestring seek binary read roundtrip" $+ assertBool "roundtrip succeeded" (seekBinaryReadRoundTrip bigByteString)+ , testCase "Infinite bytestring read roundtrip" $+ assertBool "roundtrip succeeded" (takeBinaryReadRoundTrip 100000 infiniteByteString)+ , testCase "Infinite bytestring seek read roundtrip" $+ assertBool "roundtrip succeeded" (takeSeekBinaryReadRoundTrip 100000 infiniteByteString)+ , testProperty "Simple binary write roundtrip" prop_SimpleBinaryWriteRoundTrip+ , testCase "Sterling symbol latin1 encode" $+ assertEqual "latin1 sterling" (BL.pack [163]) (encode latin1 [chr 163])+ , testCase "Sterling symbol utf8 encode" $+ assertEqual "latin1 sterling" (BL.pack [194,163]) (encode utf8 [chr 163])+ , testCase "Sterling symbol latin1 decode" $+ assertEqual "latin1 sterling" [chr 163] (decode latin1 (BL.pack [163]))+ , testCase "Sterling symbol utf8 decode" $+ assertEqual "latin1 sterling" [chr 163] (decode utf8 (BL.pack [194,163]))+ ]++main = defaultMain tests