diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bytestring-handle.cabal b/bytestring-handle.cabal new file mode 100644 --- /dev/null +++ b/bytestring-handle.cabal @@ -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 +-- 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 diff --git a/src/Data/ByteString/Handle.hs b/src/Data/ByteString/Handle.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Handle.hs @@ -0,0 +1,6 @@ +module Data.ByteString.Handle + ( readHandle, writeHandle + ) where + +import Data.ByteString.Handle.Read ( readHandle ) +import Data.ByteString.Handle.Write ( writeHandle ) diff --git a/src/Data/ByteString/Handle/Read.hs b/src/Data/ByteString/Handle/Read.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Handle/Read.hs @@ -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 diff --git a/src/Data/ByteString/Handle/Write.hs b/src/Data/ByteString/Handle/Write.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Handle/Write.hs @@ -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) diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -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