{-# 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
       SeekState -> [ByteString]
seek_before :: [B.ByteString],
       -- a list of the chunks including and after the current seek position
       SeekState -> [ByteString]
seek_after :: [B.ByteString],
       -- an index into the first chunk of seek_after
       SeekState -> Int
seek_pos :: !Int,
       -- total length of seek_before : redundant info for cheaply answering 'tell'
       SeekState -> Integer
seek_before_length :: !Integer
    }

data ReadState =
    ReadState {
        ReadState -> [ByteString]
read_chunks :: [B.ByteString],
        -- reverse list for use with SeekFromEnd - lazily constructed
        ReadState -> [ByteString]
read_chunks_backwards :: [B.ByteString],
        -- for use with getSize and SeekFromEnd - lazily constructed
        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 -- TODO: is this correct?

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