bytestring-handle-0.1.0.6/0000755000000000000000000000000013207727173013476 5ustar0000000000000000bytestring-handle-0.1.0.6/LICENSE0000644000000000000000000000277613207727173014517 0ustar0000000000000000Copyright (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. bytestring-handle-0.1.0.6/bytestring-handle.cabal0000644000000000000000000000234013207727173020104 0ustar0000000000000000name: bytestring-handle version: 0.1.0.6 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.11 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.11, test-framework-quickcheck2 >= 0.2.5 && < 0.4, HUnit >= 1.2 && < 1.7, 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.11, bytestring-handle bytestring-handle-0.1.0.6/Setup.hs0000644000000000000000000000005613207727173015133 0ustar0000000000000000import Distribution.Simple main = defaultMain bytestring-handle-0.1.0.6/test/0000755000000000000000000000000013207727173014455 5ustar0000000000000000bytestring-handle-0.1.0.6/test/Test.hs0000644000000000000000000001266213207727173015737 0ustar0000000000000000{-# 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 testsbytestring-handle-0.1.0.6/src/0000755000000000000000000000000013207727173014265 5ustar0000000000000000bytestring-handle-0.1.0.6/src/Data/0000755000000000000000000000000013207727173015136 5ustar0000000000000000bytestring-handle-0.1.0.6/src/Data/ByteString/0000755000000000000000000000000013207727173017230 5ustar0000000000000000bytestring-handle-0.1.0.6/src/Data/ByteString/Handle.hs0000644000000000000000000000025613207727173020762 0ustar0000000000000000module Data.ByteString.Handle ( readHandle, writeHandle ) where import Data.ByteString.Handle.Read ( readHandle ) import Data.ByteString.Handle.Write ( writeHandle )bytestring-handle-0.1.0.6/src/Data/ByteString/Handle/0000755000000000000000000000000013207727173020423 5ustar0000000000000000bytestring-handle-0.1.0.6/src/Data/ByteString/Handle/Write.hs0000644000000000000000000001457113207727173022061 0ustar0000000000000000{-# 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) bytestring-handle-0.1.0.6/src/Data/ByteString/Handle/Read.hs0000644000000000000000000001740013207727173021634 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable, ForeignFunctionInterface #-} 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.C.Types ( CSize(..) ) import Foreign.ForeignPtr ( newForeignPtr_ ) import Foreign.Ptr ( Ptr, nullPtr, plusPtr ) import System.IO ( Handle, IOMode( ReadMode ) , noNewlineTranslation, nativeNewlineMode ) import GHC.IO.Buffer ( BufferState(..), Buffer(..) , emptyBuffer, isEmptyBuffer, newBuffer, newByteBuffer , bufferElems, withBuffer, withRawBuffer ) 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 foreign import ccall unsafe "memmove" memmove :: Ptr a -> Ptr a -> CSize -> IO (Ptr a) 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 bufIn = do ss <- readIORef (read_seek_state rs) case seek_after ss of [] -> do return (Nothing, bufIn) (chunk:chunks) -> let (ptr, bsOffset_noseek, _) = BI.toForeignPtr chunk bsOffset = bsOffset_noseek + seek_pos ss bsOffsetEnd = bsOffset_noseek + B.length chunk in do buf <- if isEmptyBuffer bufIn then return (emptyBuffer ptr bsOffsetEnd ReadBuffer) { bufL = bsOffset, bufR = bsOffsetEnd } else do let sz = bufferElems bufIn + B.length chunk - seek_pos ss buf <- newByteBuffer sz ReadBuffer withBuffer buf $ \buf_ptr -> do withBuffer bufIn $ \buf_in_ptr -> memmove buf_ptr (buf_in_ptr `plusPtr` bufL bufIn) (fromIntegral $ bufferElems bufIn) withRawBuffer ptr $ \ptr_ptr -> memmove (buf_ptr `plusPtr` bufferElems bufIn) (ptr_ptr `plusPtr` bsOffset) (fromIntegral (bsOffsetEnd - bsOffset)) return (buf { bufR = sz }) 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