{-# 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 {
SeekState -> [ByteString]
seek_before :: [B.ByteString],
SeekState -> [ByteString]
seek_after :: [B.ByteString],
SeekState -> Int
seek_pos :: !Int,
SeekState -> Integer
seek_before_length :: !Integer
}
data ReadState =
ReadState {
ReadState -> [ByteString]
read_chunks :: [B.ByteString],
ReadState -> [ByteString]
read_chunks_backwards :: [B.ByteString],
ReadState -> Integer
read_length :: Integer,
ReadState -> IORef SeekState
read_seek_state :: IORef SeekState
}
deriving Typeable
nullReadBuffer :: IO (Buffer e)
nullReadBuffer = do
ForeignPtr e
ptr <- Ptr e -> IO (ForeignPtr e)
forall a. Ptr a -> IO (ForeignPtr a)
newForeignPtr_ Ptr e
forall a. Ptr a
nullPtr
Buffer e -> IO (Buffer e)
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffer e -> IO (Buffer e)) -> Buffer e -> IO (Buffer e)
forall a b. (a -> b) -> a -> b
$ ForeignPtr e -> Int -> BufferState -> Buffer e
forall e. RawBuffer e -> Int -> BufferState -> Buffer e
emptyBuffer ForeignPtr e
ptr
0
BufferState
ReadBuffer
foreign import ccall unsafe "memmove"
memmove :: Ptr a -> Ptr a -> CSize -> IO (Ptr a)
instance BufferedIO ReadState where
emptyWriteBuffer :: ReadState -> Buffer Word8 -> IO (Buffer Word8)
emptyWriteBuffer _ _ = IOException -> IO (Buffer Word8)
forall a. IOException -> IO a
ioException IOException
unsupportedOperation
flushWriteBuffer :: ReadState -> Buffer Word8 -> IO (Buffer Word8)
flushWriteBuffer _ _ = IOException -> IO (Buffer Word8)
forall a. IOException -> IO a
ioException IOException
unsupportedOperation
flushWriteBuffer0 :: ReadState -> Buffer Word8 -> IO (Int, Buffer Word8)
flushWriteBuffer0 _ _ = IOException -> IO (Int, Buffer Word8)
forall a. IOException -> IO a
ioException IOException
unsupportedOperation
newBuffer :: ReadState -> BufferState -> IO (Buffer Word8)
newBuffer _ WriteBuffer = IOException -> IO (Buffer Word8)
forall a. IOException -> IO a
ioException IOException
unsupportedOperation
newBuffer rs :: ReadState
rs ReadBuffer = IO (Buffer Word8)
forall e. IO (Buffer e)
nullReadBuffer
fillReadBuffer :: ReadState -> Buffer Word8 -> IO (Int, Buffer Word8)
fillReadBuffer rs :: ReadState
rs bufIn :: Buffer Word8
bufIn = do
(count :: Maybe Int
count, buf :: Buffer Word8
buf) <- ReadState -> Buffer Word8 -> IO (Maybe Int, Buffer Word8)
forall dev.
BufferedIO dev =>
dev -> Buffer Word8 -> IO (Maybe Int, Buffer Word8)
fillReadBuffer0 ReadState
rs Buffer Word8
bufIn
(Int, Buffer Word8) -> IO (Int, Buffer Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe 0 Maybe Int
count, Buffer Word8
buf)
fillReadBuffer0 :: ReadState -> Buffer Word8 -> IO (Maybe Int, Buffer Word8)
fillReadBuffer0 rs :: ReadState
rs bufIn :: Buffer Word8
bufIn = do
SeekState
ss <- IORef SeekState -> IO SeekState
forall a. IORef a -> IO a
readIORef (ReadState -> IORef SeekState
read_seek_state ReadState
rs)
case SeekState -> [ByteString]
seek_after SeekState
ss of
[] -> do
(Maybe Int, Buffer Word8) -> IO (Maybe Int, Buffer Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int
forall a. Maybe a
Nothing, Buffer Word8
bufIn)
(chunk :: ByteString
chunk:chunks :: [ByteString]
chunks) ->
let (ptr :: ForeignPtr Word8
ptr, bsOffset_noseek :: Int
bsOffset_noseek, _) = ByteString -> (ForeignPtr Word8, Int, Int)
BI.toForeignPtr ByteString
chunk
bsOffset :: Int
bsOffset = Int
bsOffset_noseek Int -> Int -> Int
forall a. Num a => a -> a -> a
+ SeekState -> Int
seek_pos SeekState
ss
bsOffsetEnd :: Int
bsOffsetEnd = Int
bsOffset_noseek Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length ByteString
chunk
in do Buffer Word8
buf <- if Buffer Word8 -> Bool
forall e. Buffer e -> Bool
isEmptyBuffer Buffer Word8
bufIn
then Buffer Word8 -> IO (Buffer Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignPtr Word8 -> Int -> BufferState -> Buffer Word8
forall e. RawBuffer e -> Int -> BufferState -> Buffer e
emptyBuffer ForeignPtr Word8
ptr Int
bsOffsetEnd BufferState
ReadBuffer) {
bufL :: Int
bufL = Int
bsOffset, bufR :: Int
bufR = Int
bsOffsetEnd
}
else do let sz :: Int
sz = Buffer Word8 -> Int
forall e. Buffer e -> Int
bufferElems Buffer Word8
bufIn Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length ByteString
chunk Int -> Int -> Int
forall a. Num a => a -> a -> a
- SeekState -> Int
seek_pos SeekState
ss
Buffer Word8
buf <- Int -> BufferState -> IO (Buffer Word8)
newByteBuffer Int
sz BufferState
ReadBuffer
Buffer Word8 -> (Ptr Word8 -> IO (Ptr Any)) -> IO (Ptr Any)
forall e a. Buffer e -> (Ptr e -> IO a) -> IO a
withBuffer Buffer Word8
buf ((Ptr Word8 -> IO (Ptr Any)) -> IO (Ptr Any))
-> (Ptr Word8 -> IO (Ptr Any)) -> IO (Ptr Any)
forall a b. (a -> b) -> a -> b
$ \buf_ptr :: Ptr Word8
buf_ptr -> do
Buffer Word8 -> (Ptr Word8 -> IO (Ptr Word8)) -> IO (Ptr Word8)
forall e a. Buffer e -> (Ptr e -> IO a) -> IO a
withBuffer Buffer Word8
bufIn ((Ptr Word8 -> IO (Ptr Word8)) -> IO (Ptr Word8))
-> (Ptr Word8 -> IO (Ptr Word8)) -> IO (Ptr Word8)
forall a b. (a -> b) -> a -> b
$ \buf_in_ptr :: Ptr Word8
buf_in_ptr ->
Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8)
forall a. Ptr a -> Ptr a -> CSize -> IO (Ptr a)
memmove Ptr Word8
buf_ptr (Ptr Word8
buf_in_ptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Buffer Word8 -> Int
forall e. Buffer e -> Int
bufL Buffer Word8
bufIn) (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CSize) -> Int -> CSize
forall a b. (a -> b) -> a -> b
$ Buffer Word8 -> Int
forall e. Buffer e -> Int
bufferElems Buffer Word8
bufIn)
ForeignPtr Word8 -> (Ptr Word8 -> IO (Ptr Any)) -> IO (Ptr Any)
forall e a. RawBuffer e -> (Ptr e -> IO a) -> IO a
withRawBuffer ForeignPtr Word8
ptr ((Ptr Word8 -> IO (Ptr Any)) -> IO (Ptr Any))
-> (Ptr Word8 -> IO (Ptr Any)) -> IO (Ptr Any)
forall a b. (a -> b) -> a -> b
$ \ptr_ptr :: Ptr Word8
ptr_ptr ->
Ptr Any -> Ptr Any -> CSize -> IO (Ptr Any)
forall a. Ptr a -> Ptr a -> CSize -> IO (Ptr a)
memmove (Ptr Word8
buf_ptr Ptr Word8 -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Buffer Word8 -> Int
forall e. Buffer e -> Int
bufferElems Buffer Word8
bufIn) (Ptr Word8
ptr_ptr Ptr Word8 -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
bsOffset) (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
bsOffsetEnd Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bsOffset))
Buffer Word8 -> IO (Buffer Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffer Word8
buf { bufR :: Int
bufR = Int
sz })
IORef SeekState -> SeekState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (ReadState -> IORef SeekState
read_seek_state ReadState
rs)
($WSeekState :: [ByteString] -> [ByteString] -> Int -> Integer -> SeekState
SeekState {
seek_before :: [ByteString]
seek_before = ByteString
chunkByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:SeekState -> [ByteString]
seek_before SeekState
ss,
seek_after :: [ByteString]
seek_after = [ByteString]
chunks,
seek_pos :: Int
seek_pos = 0,
seek_before_length :: Integer
seek_before_length = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
chunk) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ SeekState -> Integer
seek_before_length SeekState
ss
})
(Maybe Int, Buffer Word8) -> IO (Maybe Int, Buffer Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int
forall a. a -> Maybe a
Just (ByteString -> Int
B.length ByteString
chunk Int -> Int -> Int
forall a. Num a => a -> a -> a
- SeekState -> Int
seek_pos SeekState
ss), Buffer Word8
buf)
normalisedSeekState :: [B.ByteString] -> [B.ByteString] -> Integer -> Integer -> Maybe SeekState
normalisedSeekState :: [ByteString]
-> [ByteString] -> Integer -> Integer -> Maybe SeekState
normalisedSeekState (x :: ByteString
x:before :: [ByteString]
before) after :: [ByteString]
after beforeLen :: Integer
beforeLen pos :: Integer
pos
| Integer
pos Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = [ByteString]
-> [ByteString] -> Integer -> Integer -> Maybe SeekState
normalisedSeekState
[ByteString]
before
(ByteString
xByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
after)
(Integer
beforeLen Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
x))
(Integer
pos Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
x))
normalisedSeekState [] _ _ pos :: Integer
pos
| Integer
pos Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = Maybe SeekState
forall a. Maybe a
Nothing
normalisedSeekState before :: [ByteString]
before (x :: ByteString
x:after :: [ByteString]
after) beforeLen :: Integer
beforeLen pos :: Integer
pos
| Integer
pos Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
x)
= [ByteString]
-> [ByteString] -> Integer -> Integer -> Maybe SeekState
normalisedSeekState
(ByteString
xByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
before)
[ByteString]
after
(Integer
beforeLen Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
x))
(Integer
pos Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
x))
normalisedSeekState _ [] _ pos :: Integer
pos
| Integer
pos Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> 0 = Maybe SeekState
forall a. Maybe a
Nothing
normalisedSeekState before :: [ByteString]
before after :: [ByteString]
after beforeLen :: Integer
beforeLen pos :: Integer
pos =
SeekState -> Maybe SeekState
forall a. a -> Maybe a
Just ($WSeekState :: [ByteString] -> [ByteString] -> Int -> Integer -> SeekState
SeekState {
seek_before :: [ByteString]
seek_before = [ByteString]
before,
seek_after :: [ByteString]
seek_after = [ByteString]
after,
seek_pos :: Int
seek_pos = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
pos,
seek_before_length :: Integer
seek_before_length = Integer
beforeLen
})
instance IODevice ReadState where
ready :: ReadState -> Bool -> Int -> IO Bool
ready _ _ _ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
close :: ReadState -> IO ()
close _ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
isSeekable :: ReadState -> IO Bool
isSeekable _ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
seek :: ReadState -> SeekMode -> Integer -> IO ()
seek rs :: ReadState
rs seekMode :: SeekMode
seekMode seekPos :: Integer
seekPos = do
Integer
size <- ReadState -> IO Integer
forall a. IODevice a => a -> IO Integer
getSize ReadState
rs
SeekState
curSeekState <- IORef SeekState -> IO SeekState
forall a. IORef a -> IO a
readIORef (ReadState -> IORef SeekState
read_seek_state ReadState
rs)
let newSeekState :: Maybe SeekState
newSeekState =
case SeekMode
seekMode of
AbsoluteSeek -> [ByteString]
-> [ByteString] -> Integer -> Integer -> Maybe SeekState
normalisedSeekState [] (ReadState -> [ByteString]
read_chunks ReadState
rs) 0 Integer
seekPos
RelativeSeek -> [ByteString]
-> [ByteString] -> Integer -> Integer -> Maybe SeekState
normalisedSeekState (SeekState -> [ByteString]
seek_before SeekState
curSeekState)
(SeekState -> [ByteString]
seek_after SeekState
curSeekState)
(SeekState -> Integer
seek_before_length SeekState
curSeekState)
(Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SeekState -> Int
seek_pos SeekState
curSeekState) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
seekPos)
SeekFromEnd -> [ByteString]
-> [ByteString] -> Integer -> Integer -> Maybe SeekState
normalisedSeekState (ReadState -> [ByteString]
read_chunks_backwards ReadState
rs) [] (ReadState -> Integer
read_length ReadState
rs) Integer
seekPos
IO () -> (SeekState -> IO ()) -> Maybe SeekState -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ()
forall a. IO a
ioe_seekOutOfRange (IORef SeekState -> SeekState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (ReadState -> IORef SeekState
read_seek_state ReadState
rs)) Maybe SeekState
newSeekState
tell :: ReadState -> IO Integer
tell rs :: ReadState
rs = do
SeekState
ss <- IORef SeekState -> IO SeekState
forall a. IORef a -> IO a
readIORef (ReadState -> IORef SeekState
read_seek_state ReadState
rs)
Integer -> IO Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (SeekState -> Integer
seek_before_length SeekState
ss Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SeekState -> Int
seek_pos SeekState
ss))
getSize :: ReadState -> IO Integer
getSize = Integer -> IO Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> IO Integer)
-> (ReadState -> Integer) -> ReadState -> IO Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadState -> Integer
read_length
setSize :: ReadState -> Integer -> IO ()
setSize _ _ = IOException -> IO ()
forall a. IOException -> IO a
ioException IOException
unsupportedOperation
devType :: ReadState -> IO IODeviceType
devType _ = IODeviceType -> IO IODeviceType
forall (m :: * -> *) a. Monad m => a -> m a
return IODeviceType
RegularFile
ioe_seekOutOfRange :: IO a
ioe_seekOutOfRange :: IO a
ioe_seekOutOfRange =
IOException -> IO a
forall a. IOException -> IO a
ioException (IOException -> IO a) -> IOException -> IO a
forall a b. (a -> b) -> a -> b
$ Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOException
IOError Maybe Handle
forall a. Maybe a
Nothing IOErrorType
InvalidArgument ""
"attempt to seek outside the file" Maybe CInt
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing
readHandle :: Bool -> BL.ByteString -> IO Handle
readHandle :: Bool -> ByteString -> IO Handle
readHandle binary :: Bool
binary bs :: ByteString
bs = do
let chunks :: [ByteString]
chunks = ByteString -> [ByteString]
BL.toChunks ByteString
bs
let ss :: SeekState
ss = $WSeekState :: [ByteString] -> [ByteString] -> Int -> Integer -> SeekState
SeekState {
seek_before :: [ByteString]
seek_before = [],
seek_after :: [ByteString]
seek_after = [ByteString]
chunks,
seek_pos :: Int
seek_pos = 0,
seek_before_length :: Integer
seek_before_length = 0
}
IORef SeekState
ssref <- SeekState -> IO (IORef SeekState)
forall a. a -> IO (IORef a)
newIORef SeekState
ss
let rs :: ReadState
rs = ReadState :: [ByteString]
-> [ByteString] -> Integer -> IORef SeekState -> ReadState
ReadState {
read_chunks :: [ByteString]
read_chunks = [ByteString]
chunks,
read_chunks_backwards :: [ByteString]
read_chunks_backwards = [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
chunks,
read_seek_state :: IORef SeekState
read_seek_state = IORef SeekState
ssref,
read_length :: Integer
read_length = [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((ByteString -> Integer) -> [ByteString] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> (ByteString -> Int) -> ByteString -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int
B.length) [ByteString]
chunks)
}
#if MIN_VERSION_base(4,5,0)
TextEncoding
localeEnc <- IO TextEncoding
getLocaleEncoding
#else
localeEnc <- return localeEncoding
#endif
let (encoding :: Maybe TextEncoding
encoding, newline :: NewlineMode
newline)
| Bool
binary = (Maybe TextEncoding
forall a. Maybe a
Nothing , NewlineMode
noNewlineTranslation)
| Bool
otherwise = (TextEncoding -> Maybe TextEncoding
forall a. a -> Maybe a
Just TextEncoding
localeEnc, NewlineMode
nativeNewlineMode )
ReadState
-> String
-> IOMode
-> Maybe TextEncoding
-> NewlineMode
-> IO Handle
forall dev.
(IODevice dev, BufferedIO dev, Typeable dev) =>
dev
-> String
-> IOMode
-> Maybe TextEncoding
-> NewlineMode
-> IO Handle
mkFileHandle ReadState
rs "ByteString" IOMode
ReadMode Maybe TextEncoding
encoding NewlineMode
newline