{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE ScopedTypeVariables #-}

module System.FS.BlockIO.Async (
    asyncHasBlockIO
  ) where

import           Control.Exception
import qualified Control.Exception as E
import           Control.Monad.Primitive
import qualified Data.Vector as V
import qualified Data.Vector.Unboxed as VU
import qualified Data.Vector.Unboxed.Mutable as VUM
import           Foreign.C.Error
import           GHC.IO.Exception
import           GHC.Stack
import           System.FS.API (BufferOffset (..), FsErrorPath, FsPath,
                     Handle (..), HasFS (..), SomeHasFS (..), ioToFsError)
import qualified System.FS.BlockIO.API as API
import           System.FS.BlockIO.API (IOOp (..), IOResult (..), LockMode,
                     ioopHandle)
import           System.FS.IO (HandleIO)
import           System.FS.IO.Handle
import qualified System.IO.BlockIO as I
import           System.IO.Error (ioeSetErrorString, isResourceVanishedError)
import           System.Posix.Types

-- | IO instantiation of 'HasBlockIO', using @blockio-uring@.
asyncHasBlockIO ::
     (Handle HandleIO -> Bool -> IO ())
  -> (Handle HandleIO -> FileOffset -> FileOffset -> API.Advice -> IO ())
  -> (Handle HandleIO -> FileOffset -> FileOffset -> IO ())
  -> (FsPath -> LockMode -> IO (Maybe (API.LockFileHandle IO)))
  -> (Handle HandleIO -> IO ())
  -> (FsPath -> IO ())
  -> (FsPath -> FsPath -> IO ())
  -> HasFS IO HandleIO
  -> API.IOCtxParams
  -> IO (API.HasBlockIO IO HandleIO)
asyncHasBlockIO :: (Handle HandleIO -> Bool -> IO ())
-> (Handle HandleIO -> FileOffset -> FileOffset -> Advice -> IO ())
-> (Handle HandleIO -> FileOffset -> FileOffset -> IO ())
-> (FsPath -> LockMode -> IO (Maybe (LockFileHandle IO)))
-> (Handle HandleIO -> IO ())
-> (FsPath -> IO ())
-> (FsPath -> FsPath -> IO ())
-> HasFS IO HandleIO
-> IOCtxParams
-> IO (HasBlockIO IO HandleIO)
asyncHasBlockIO Handle HandleIO -> Bool -> IO ()
hSetNoCache Handle HandleIO -> FileOffset -> FileOffset -> Advice -> IO ()
hAdvise Handle HandleIO -> FileOffset -> FileOffset -> IO ()
hAllocate FsPath -> LockMode -> IO (Maybe (LockFileHandle IO))
tryLockFile Handle HandleIO -> IO ()
hSynchronise FsPath -> IO ()
synchroniseDirectory FsPath -> FsPath -> IO ()
createHardLink HasFS IO HandleIO
hasFS IOCtxParams
ctxParams = do
  IOCtx
ctx <- IOCtxParams -> IO IOCtx
I.initIOCtx (IOCtxParams -> IOCtxParams
ctxParamsConv IOCtxParams
ctxParams)
  HasBlockIO IO HandleIO -> IO (HasBlockIO IO HandleIO)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HasBlockIO IO HandleIO -> IO (HasBlockIO IO HandleIO))
-> HasBlockIO IO HandleIO -> IO (HasBlockIO IO HandleIO)
forall a b. (a -> b) -> a -> b
$ API.HasBlockIO {
      close :: HasCallStack => IO ()
API.close = IOCtx -> IO ()
I.closeIOCtx IOCtx
ctx
    , submitIO :: HasCallStack =>
Vector (IOOp (PrimState IO) HandleIO) -> IO (Vector IOResult)
API.submitIO = HasFS IO HandleIO
-> IOCtx
-> Vector (IOOp RealWorld HandleIO)
-> IO (Vector IOResult)
submitIO HasFS IO HandleIO
hasFS IOCtx
ctx
    , Handle HandleIO -> Bool -> IO ()
hSetNoCache :: Handle HandleIO -> Bool -> IO ()
hSetNoCache :: Handle HandleIO -> Bool -> IO ()
API.hSetNoCache
    , Handle HandleIO -> FileOffset -> FileOffset -> Advice -> IO ()
hAdvise :: Handle HandleIO -> FileOffset -> FileOffset -> Advice -> IO ()
hAdvise :: Handle HandleIO -> FileOffset -> FileOffset -> Advice -> IO ()
API.hAdvise
    , Handle HandleIO -> FileOffset -> FileOffset -> IO ()
hAllocate :: Handle HandleIO -> FileOffset -> FileOffset -> IO ()
hAllocate :: Handle HandleIO -> FileOffset -> FileOffset -> IO ()
API.hAllocate
    , FsPath -> LockMode -> IO (Maybe (LockFileHandle IO))
tryLockFile :: FsPath -> LockMode -> IO (Maybe (LockFileHandle IO))
tryLockFile :: FsPath -> LockMode -> IO (Maybe (LockFileHandle IO))
API.tryLockFile
    , Handle HandleIO -> IO ()
hSynchronise :: Handle HandleIO -> IO ()
hSynchronise :: Handle HandleIO -> IO ()
API.hSynchronise
    , FsPath -> IO ()
synchroniseDirectory :: FsPath -> IO ()
synchroniseDirectory :: FsPath -> IO ()
API.synchroniseDirectory
    , FsPath -> FsPath -> IO ()
createHardLink :: FsPath -> FsPath -> IO ()
createHardLink :: FsPath -> FsPath -> IO ()
API.createHardLink
    }

ctxParamsConv :: API.IOCtxParams -> I.IOCtxParams
ctxParamsConv :: IOCtxParams -> IOCtxParams
ctxParamsConv API.IOCtxParams{Int
ioctxBatchSizeLimit :: Int
ioctxBatchSizeLimit :: IOCtxParams -> Int
API.ioctxBatchSizeLimit, Int
ioctxConcurrencyLimit :: Int
ioctxConcurrencyLimit :: IOCtxParams -> Int
API.ioctxConcurrencyLimit} =
    I.IOCtxParams {
        ioctxBatchSizeLimit :: Int
I.ioctxBatchSizeLimit   = Int
ioctxBatchSizeLimit
      , ioctxConcurrencyLimit :: Int
I.ioctxConcurrencyLimit = Int
ioctxConcurrencyLimit
      }

submitIO ::
     HasFS IO HandleIO
  -> I.IOCtx
  -> V.Vector (IOOp RealWorld HandleIO)
  -> IO (VU.Vector IOResult)
submitIO :: HasFS IO HandleIO
-> IOCtx
-> Vector (IOOp RealWorld HandleIO)
-> IO (Vector IOResult)
submitIO HasFS IO HandleIO
hasFS IOCtx
ioctx Vector (IOOp RealWorld HandleIO)
ioops = do
    Vector (IOOp IO)
ioops' <- (IOOp RealWorld HandleIO -> IO (IOOp IO))
-> Vector (IOOp RealWorld HandleIO) -> IO (Vector (IOOp IO))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
mapM IOOp RealWorld HandleIO -> IO (IOOp IO)
ioopConv Vector (IOOp RealWorld HandleIO)
ioops
    Vector IOResult
ress <- IOCtx -> Vector (IOOp IO) -> IO (Vector IOResult)
I.submitIO IOCtx
ioctx Vector (IOOp IO)
ioops' IO (Vector IOResult)
-> (IOError -> IO (Vector IOResult)) -> IO (Vector IOResult)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOError -> IO (Vector IOResult)
forall a. IOError -> IO a
rethrowClosedError
    (IOOp RealWorld HandleIO -> IOResult -> IO IOResult)
-> Vector (IOOp RealWorld HandleIO)
-> Vector IOResult
-> IO (Vector IOResult)
forall (m :: * -> *) a b c.
(PrimMonad m, Unbox b, Unbox c) =>
(a -> b -> m c) -> Vector a -> Vector b -> m (Vector c)
hzipWithM HasCallStack => IOOp RealWorld HandleIO -> IOResult -> IO IOResult
IOOp RealWorld HandleIO -> IOResult -> IO IOResult
rethrowErrno Vector (IOOp RealWorld HandleIO)
ioops Vector IOResult
ress
  where
    rethrowClosedError :: IOError -> IO a
    rethrowClosedError :: forall a. IOError -> IO a
rethrowClosedError e :: IOError
e@IOError{} =
        -- Pattern matching on the error is brittle, because the structure of
        -- the exception might change between versions of @blockio-uring@.
        -- Nonetheless, it's better than nothing.
        if IOError -> Bool
isResourceVanishedError IOError
e Bool -> Bool -> Bool
&& IOError -> String
ioe_location IOError
e String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"IOCtx closed"
          then FsError -> IO a
forall e a. Exception e => e -> IO a
throwIO (SomeHasFS IO -> String -> FsError
forall (m :: * -> *).
HasCallStack =>
SomeHasFS m -> String -> FsError
API.mkClosedError (HasFS IO HandleIO -> SomeHasFS IO
forall h (m :: * -> *). Eq h => HasFS m h -> SomeHasFS m
SomeHasFS HasFS IO HandleIO
hasFS) String
"submitIO")
          else IOError -> IO a
forall e a. Exception e => e -> IO a
throwIO IOError
e

    rethrowErrno ::
         HasCallStack
      => IOOp RealWorld HandleIO
      -> I.IOResult
      -> IO IOResult
    rethrowErrno :: HasCallStack => IOOp RealWorld HandleIO -> IOResult -> IO IOResult
rethrowErrno IOOp RealWorld HandleIO
ioop IOResult
res = do
        case IOResult
res of
          I.IOResult ByteCount
c -> IOResult -> IO IOResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteCount -> IOResult
IOResult ByteCount
c)
          I.IOError  Errno
e -> Errno -> IO IOResult
forall a. HasCallStack => Errno -> IO a
throwAsFsError Errno
e
      where
        throwAsFsError :: HasCallStack => Errno -> IO a
        throwAsFsError :: forall a. HasCallStack => Errno -> IO a
throwAsFsError Errno
errno = FsError -> IO a
forall e a. Exception e => e -> IO a
E.throwIO (FsError -> IO a) -> FsError -> IO a
forall a b. (a -> b) -> a -> b
$ HasCallStack => FsErrorPath -> IOError -> FsError
FsErrorPath -> IOError -> FsError
ioToFsError FsErrorPath
fep (Errno -> IOError
fromErrno Errno
errno)

        fep :: FsErrorPath
        fep :: FsErrorPath
fep = HasFS IO HandleIO -> FsPath -> FsErrorPath
forall (m :: * -> *) h. HasFS m h -> FsPath -> FsErrorPath
mkFsErrorPath HasFS IO HandleIO
hasFS (Handle HandleIO -> FsPath
forall h. Handle h -> FsPath
handlePath (IOOp RealWorld HandleIO -> Handle HandleIO
forall s h. IOOp s h -> Handle h
ioopHandle IOOp RealWorld HandleIO
ioop))

        fromErrno :: Errno -> IOError
        fromErrno :: Errno -> IOError
fromErrno Errno
errno = IOError -> String -> IOError
ioeSetErrorString
                            (String -> Errno -> Maybe Handle -> Maybe String -> IOError
errnoToIOError String
"submitIO" Errno
errno Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)
                            (String
"submitIO failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
ioopType)

        ioopType :: String
        ioopType :: String
ioopType = case IOOp RealWorld HandleIO
ioop of
          IOOpRead{}  -> String
"IOOpRead"
          IOOpWrite{} -> String
"IOOpWrite"

ioopConv :: IOOp RealWorld HandleIO -> IO (I.IOOp IO)
ioopConv :: IOOp RealWorld HandleIO -> IO (IOOp IO)
ioopConv (IOOpRead Handle HandleIO
h FileOffset
off MutableByteArray RealWorld
buf BufferOffset
bufOff ByteCount
c) = Handle HandleIO -> IO Fd
handleFd Handle HandleIO
h IO Fd -> (Fd -> IO (IOOp IO)) -> IO (IOOp IO)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Fd
fd ->
    IOOp IO -> IO (IOOp IO)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Fd
-> FileOffset
-> MutableByteArray (PrimState IO)
-> Int
-> ByteCount
-> IOOp IO
forall (m :: * -> *).
Fd
-> FileOffset
-> MutableByteArray (PrimState m)
-> Int
-> ByteCount
-> IOOp m
I.IOOpRead  Fd
fd FileOffset
off MutableByteArray RealWorld
MutableByteArray (PrimState IO)
buf (BufferOffset -> Int
unBufferOffset BufferOffset
bufOff) ByteCount
c)
ioopConv (IOOpWrite Handle HandleIO
h FileOffset
off MutableByteArray RealWorld
buf BufferOffset
bufOff ByteCount
c) = Handle HandleIO -> IO Fd
handleFd Handle HandleIO
h IO Fd -> (Fd -> IO (IOOp IO)) -> IO (IOOp IO)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Fd
fd ->
    IOOp IO -> IO (IOOp IO)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Fd
-> FileOffset
-> MutableByteArray (PrimState IO)
-> Int
-> ByteCount
-> IOOp IO
forall (m :: * -> *).
Fd
-> FileOffset
-> MutableByteArray (PrimState m)
-> Int
-> ByteCount
-> IOOp m
I.IOOpWrite Fd
fd FileOffset
off MutableByteArray RealWorld
MutableByteArray (PrimState IO)
buf (BufferOffset -> Int
unBufferOffset BufferOffset
bufOff) ByteCount
c)

-- This only checks whether the handle is open when we convert to an Fd. After
-- that, the handle could be closed when we're still performing blockio
-- operations.
--
-- TODO: if the handle were to have a reader/writer lock, then we could take the
-- reader lock in 'submitIO'. However, the current implementation of 'Handle'
-- only allows mutually exclusive access to the underlying file descriptor, so it
-- would require a change in @fs-api@. See [fs-sim#49].
handleFd :: Handle HandleIO -> IO Fd
handleFd :: Handle HandleIO -> IO Fd
handleFd Handle HandleIO
h = String -> HandleIO -> (Fd -> IO Fd) -> IO Fd
forall osHandle a.
String -> HandleOS osHandle -> (osHandle -> IO a) -> IO a
withOpenHandle String
"submitIO" (Handle HandleIO -> HandleIO
forall h. Handle h -> h
handleRaw Handle HandleIO
h) Fd -> IO Fd
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

{-# SPECIALISE hzipWithM ::
     (VUM.Unbox b, VUM.Unbox c)
  => (a -> b -> IO c)
  -> V.Vector a
  -> VU.Vector b
  -> IO (VU.Vector c)
  #-}
-- | Heterogeneous blend of `V.zipWithM` and `VU.zipWithM`
--
-- The @vector@ package does not provide functions that take distinct vector
-- containers as arguments, so we write it by hand to prevent having to convert
-- one vector type to the other.
hzipWithM ::
     forall m a b c. (PrimMonad m, VUM.Unbox b, VUM.Unbox c)
  => (a -> b -> m c)
  -> V.Vector a
  -> VU.Vector b
  -> m (VU.Vector c)
hzipWithM :: forall (m :: * -> *) a b c.
(PrimMonad m, Unbox b, Unbox c) =>
(a -> b -> m c) -> Vector a -> Vector b -> m (Vector c)
hzipWithM a -> b -> m c
f Vector a
v1 Vector b
v2 = do
    MVector (PrimState m) c
res <- Int -> m (MVector (PrimState m) c)
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
Int -> m (MVector (PrimState m) a)
VUM.unsafeNew Int
n
    MVector (PrimState m) c -> Int -> m (Vector c)
loop MVector (PrimState m) c
res Int
0
  where
    !n :: Int
n = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Vector a -> Int
forall a. Vector a -> Int
V.length Vector a
v1) (Vector b -> Int
forall a. Unbox a => Vector a -> Int
VU.length Vector b
v2)

    loop :: VUM.MVector (PrimState m) c -> Int -> m (VU.Vector c)
    loop :: MVector (PrimState m) c -> Int -> m (Vector c)
loop !MVector (PrimState m) c
res !Int
i
      | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n = MVector (PrimState m) c -> m (Vector c)
forall a (m :: * -> *).
(Unbox a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
VU.unsafeFreeze MVector (PrimState m) c
res
      | Bool
otherwise = do
          let !x :: a
x = Vector a
v1 Vector a -> Int -> a
forall a. Vector a -> Int -> a
`V.unsafeIndex` Int
i
              !y :: b
y = Vector b
v2 Vector b -> Int -> b
forall a. Unbox a => Vector a -> Int -> a
`VU.unsafeIndex` Int
i
          !c
z <- a -> b -> m c
f a
x b
y
          MVector (PrimState m) c -> Int -> c -> m ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
VUM.write MVector (PrimState m) c
res Int
i c
z
          MVector (PrimState m) c -> Int -> m (Vector c)
loop MVector (PrimState m) c
res (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)