GetContents.hs

module Lazy.Scope.GetContents where

import Control.Exception (ioError)
import Data.ByteString qualified as S
import Data.ByteString.Lazy.Internal (ByteString(Chunk, Empty), defaultChunkSize)
import Lazy.Scope.Type (LazyT, Handle(..), Bs, Scoped(Scoped))
import Lazy.Scope.Scoped (toBs)
import Relude hiding (Handle)
import System.IO.Error (mkIOError, illegalOperationErrorType)
import System.IO.Unsafe (unsafeInterleaveIO)
import Text.Show (showsPrec)

hGetContentsOnlyN :: Int -> Handle s -> IO LByteString
hGetContentsOnlyN k (Handle h) = lazyRead
  where
    lazyRead = unsafeInterleaveIO loop

    loop = do
        c <- S.hGetSome h k
        if S.null c
          then return Empty
          else Chunk c <$> lazyRead

hGetContents :: MonadIO m => Handle s -> LazyT s m (Bs s)
hGetContents h = lift $ liftIO (Scoped <$> hGetContentsOnlyN defaultChunkSize h)

hGetNonBlockingN :: Int -> Handle s -> Int -> IO LByteString
hGetNonBlockingN k (Handle h) n | n > 0= readChunks n
  where
    readChunks !i = do
        c <- S.hGetNonBlocking h (min k i)
        case S.length c of
            0 -> return Empty
            m -> do cs <- readChunks (i - m)
                    return (Chunk c cs)

hGetNonBlockingN _ _ 0 = return Empty
hGetNonBlockingN _ h n = illegalBufferSize h "hGetNonBlocking" n

illegalBufferSize :: Handle s -> String -> Int -> IO a
illegalBufferSize (Handle handle) fn sz =
    ioError (mkIOError illegalOperationErrorType msg (Just handle) Nothing)
    --TODO: System.IO uses InvalidArgument here, but it's not exported :-(
    where
      msg = fn ++ ": illegal ByteString size " ++ showsPrec 9 sz []


hGetNonBlocking :: MonadIO m => Handle s -> Int -> LazyT s m (Bs s)
hGetNonBlocking h n = lift (liftIO $ toBs <$> hGetNonBlockingN defaultChunkSize h n)

hPutNonBlocking :: MonadIO m => Handle s -> Bs s -> LazyT s m (Bs s)
hPutNonBlocking _ (Scoped Empty)           = pure (Scoped Empty)
hPutNonBlocking bh@(Handle h) (Scoped bs@(Chunk c cs)) = do
  c' <- lift (liftIO $ S.hPutNonBlocking h c)
  case S.length c' of
    l' | l' == S.length c -> hPutNonBlocking bh (Scoped cs)
    0                     -> return $ Scoped bs
    _                     -> return $ Scoped (Chunk c' cs)