{-# LANGUAGE TypeFamilies  #-}
{-# LANGUAGE UnboxedTuples #-}

module System.FS.BlockIO.IO.Internal (
    IOCtxParams (..)
  , defaultIOCtxParams
  , mkClosedError
  , mkNotPinnedError
  , tryLockFileIO
  , createHardLinkIO
  ) where

import           Control.DeepSeq (NFData (..))
import           Control.Monad.Class.MonadThrow (MonadCatch (bracketOnError),
                     MonadThrow (..), bracketOnError, try)
import           GHC.IO.Exception
                     (IOErrorType (InvalidArgument, ResourceVanished))
import qualified GHC.IO.Handle.Lock as GHC
import           GHC.Stack (HasCallStack)
import qualified System.FS.API as FS
import           System.FS.API (FsError (..), FsPath, HasFS)
import           System.FS.BlockIO.API (LockFileHandle (..))
import           System.FS.IO (HandleIO)
import qualified System.IO as GHC
import           System.IO.Error (ioeSetErrorString, mkIOError)

{-------------------------------------------------------------------------------
  IO context
-------------------------------------------------------------------------------}

-- | Concurrency parameters for initialising the 'IO' context in a 'HasBlockIO'
-- instance.
--
-- [IO context parameters]: These parameters are interpreted differently based
--  on the underlying platform:
--
--  * Linux: Pass the parameters to 'initIOCtx' in the @blockio-uring@ package
--  * MacOS: Ignore the parameters
--  * Windows: Ignore the parameters
--
--  For more information about what these parameters mean and how to configure
--  them, see the @blockio-uring@ package.
data IOCtxParams = IOCtxParams {
                     IOCtxParams -> Int
ioctxBatchSizeLimit   :: !Int,
                     IOCtxParams -> Int
ioctxConcurrencyLimit :: !Int
                   }

instance NFData IOCtxParams where
  rnf :: IOCtxParams -> ()
rnf (IOCtxParams Int
x Int
y) = Int -> ()
forall a. NFData a => a -> ()
rnf Int
x () -> () -> ()
forall a b. a -> b -> b
`seq` Int -> ()
forall a. NFData a => a -> ()
rnf Int
y

-- | Default parameters. Some manual tuning of parameters might be required to
-- achieve higher performance targets (see 'IOCtxParams').
defaultIOCtxParams :: IOCtxParams
defaultIOCtxParams :: IOCtxParams
defaultIOCtxParams = IOCtxParams {
      ioctxBatchSizeLimit :: Int
ioctxBatchSizeLimit   = Int
64,
      ioctxConcurrencyLimit :: Int
ioctxConcurrencyLimit = Int
64 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3
    }

{-------------------------------------------------------------------------------
  Errors
-------------------------------------------------------------------------------}

mkClosedError :: HasCallStack => HasFS m h -> String -> FsError
mkClosedError :: forall (m :: * -> *) h.
HasCallStack =>
HasFS m h -> String -> FsError
mkClosedError HasFS m h
hasFS String
loc =
    HasCallStack => FsErrorPath -> IOError -> FsError
FsErrorPath -> IOError -> FsError
FS.ioToFsError (HasFS m h -> FsPath -> FsErrorPath
forall (m :: * -> *) h. HasFS m h -> FsPath -> FsErrorPath
FS.mkFsErrorPath HasFS m h
hasFS ([String] -> FsPath
FS.mkFsPath [])) IOError
ioerr
  where
    ioerr :: IOError
ioerr =
        IOError -> String -> IOError
ioeSetErrorString
          (IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
ResourceVanished String
loc Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)
          (String
"HasBlockIO closed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
loc)

mkNotPinnedError :: HasCallStack => HasFS m h -> String -> FsError
mkNotPinnedError :: forall (m :: * -> *) h.
HasCallStack =>
HasFS m h -> String -> FsError
mkNotPinnedError HasFS m h
hasFS String
loc =
    HasCallStack => FsErrorPath -> IOError -> FsError
FsErrorPath -> IOError -> FsError
FS.ioToFsError (HasFS m h -> FsPath -> FsErrorPath
forall (m :: * -> *) h. HasFS m h -> FsPath -> FsErrorPath
FS.mkFsErrorPath HasFS m h
hasFS ([String] -> FsPath
FS.mkFsPath [])) IOError
ioerr
  where
    ioerr :: IOError
ioerr =
        IOError -> String -> IOError
ioeSetErrorString
          (IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
InvalidArgument String
loc Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)
          (String
"MutableByteArray is unpinned: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
loc)

{-------------------------------------------------------------------------------
  File locks
-------------------------------------------------------------------------------}

tryLockFileIO :: HasFS IO HandleIO -> FsPath -> GHC.LockMode -> IO (Maybe (LockFileHandle IO))
tryLockFileIO :: HasFS IO HandleIO
-> FsPath -> LockMode -> IO (Maybe (LockFileHandle IO))
tryLockFileIO HasFS IO HandleIO
hfs FsPath
fsp LockMode
mode = do
    String
fp <- HasFS IO HandleIO -> FsPath -> IO String
forall (m :: * -> *) h. HasFS m h -> FsPath -> m String
FS.unsafeToFilePath HasFS IO HandleIO
hfs FsPath
fsp -- shouldn't fail because we are in IO
    HasFS IO HandleIO
-> FsPath
-> IO (Maybe (LockFileHandle IO))
-> IO (Maybe (LockFileHandle IO))
forall a.
HasCallStack =>
HasFS IO HandleIO -> FsPath -> IO a -> IO a
rethrowFsErrorIO HasFS IO HandleIO
hfs FsPath
fsp (IO (Maybe (LockFileHandle IO)) -> IO (Maybe (LockFileHandle IO)))
-> IO (Maybe (LockFileHandle IO)) -> IO (Maybe (LockFileHandle IO))
forall a b. (a -> b) -> a -> b
$
      IO Handle
-> (Handle -> IO ())
-> (Handle -> IO (Maybe (LockFileHandle IO)))
-> IO (Maybe (LockFileHandle IO))
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
forall (m :: * -> *) a b c.
MonadCatch m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracketOnError (String -> IOMode -> IO Handle
GHC.openFile String
fp IOMode
GHC.WriteMode) Handle -> IO ()
GHC.hClose ((Handle -> IO (Maybe (LockFileHandle IO)))
 -> IO (Maybe (LockFileHandle IO)))
-> (Handle -> IO (Maybe (LockFileHandle IO)))
-> IO (Maybe (LockFileHandle IO))
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
        IO Bool
-> (Bool -> IO ())
-> (Bool -> IO (Maybe (LockFileHandle IO)))
-> IO (Maybe (LockFileHandle IO))
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
forall (m :: * -> *) a b c.
MonadCatch m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracketOnError (Handle -> LockMode -> IO Bool
GHC.hTryLock Handle
h LockMode
mode) (\Bool
_ -> Handle -> IO ()
GHC.hUnlock Handle
h) ((Bool -> IO (Maybe (LockFileHandle IO)))
 -> IO (Maybe (LockFileHandle IO)))
-> (Bool -> IO (Maybe (LockFileHandle IO)))
-> IO (Maybe (LockFileHandle IO))
forall a b. (a -> b) -> a -> b
$ \Bool
b -> do
          if Bool
b then
            Maybe (LockFileHandle IO) -> IO (Maybe (LockFileHandle IO))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (LockFileHandle IO) -> IO (Maybe (LockFileHandle IO)))
-> Maybe (LockFileHandle IO) -> IO (Maybe (LockFileHandle IO))
forall a b. (a -> b) -> a -> b
$ LockFileHandle IO -> Maybe (LockFileHandle IO)
forall a. a -> Maybe a
Just LockFileHandle { hUnlock :: IO ()
hUnlock = HasFS IO HandleIO -> FsPath -> IO () -> IO ()
forall a.
HasCallStack =>
HasFS IO HandleIO -> FsPath -> IO a -> IO a
rethrowFsErrorIO HasFS IO HandleIO
hfs FsPath
fsp (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                  Handle -> IO ()
GHC.hUnlock Handle
h
                    IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
forall (m :: * -> *) a b. MonadThrow m => m a -> m b -> m a
`finally` Handle -> IO ()
GHC.hClose Handle
h
                }
          else
            Maybe (LockFileHandle IO) -> IO (Maybe (LockFileHandle IO))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (LockFileHandle IO) -> IO (Maybe (LockFileHandle IO)))
-> Maybe (LockFileHandle IO) -> IO (Maybe (LockFileHandle IO))
forall a b. (a -> b) -> a -> b
$ Maybe (LockFileHandle IO)
forall a. Maybe a
Nothing

-- This is copied/adapted from System.FS.IO
rethrowFsErrorIO :: HasCallStack => HasFS IO HandleIO -> FsPath -> IO a -> IO a
rethrowFsErrorIO :: forall a.
HasCallStack =>
HasFS IO HandleIO -> FsPath -> IO a -> IO a
rethrowFsErrorIO HasFS IO HandleIO
hfs FsPath
fp IO a
action = do
    Either IOError a
res <- IO a -> IO (Either IOError a)
forall e a. Exception e => IO a -> IO (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try IO a
action
    case Either IOError a
res of
      Left IOError
err -> IOError -> IO a
forall a. HasCallStack => IOError -> IO a
handleError IOError
err
      Right a
a  -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  where
    handleError :: HasCallStack => IOError -> IO a
    handleError :: forall a. HasCallStack => IOError -> IO a
handleError IOError
ioErr =
      FsError -> IO a
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FsError -> IO a) -> FsError -> IO a
forall a b. (a -> b) -> a -> b
$ HasCallStack => FsErrorPath -> IOError -> FsError
FsErrorPath -> IOError -> FsError
FS.ioToFsError (HasFS IO HandleIO -> FsPath -> FsErrorPath
forall (m :: * -> *) h. HasFS m h -> FsPath -> FsErrorPath
FS.mkFsErrorPath HasFS IO HandleIO
hfs FsPath
fp) IOError
ioErr

{-------------------------------------------------------------------------------
  Hard links
-------------------------------------------------------------------------------}

createHardLinkIO ::
     HasFS IO HandleIO
  -> (FilePath -> FilePath -> IO ())
  -> (FsPath -> FsPath -> IO ())
createHardLinkIO :: HasFS IO HandleIO
-> (String -> String -> IO ()) -> FsPath -> FsPath -> IO ()
createHardLinkIO HasFS IO HandleIO
hfs String -> String -> IO ()
f = \FsPath
source FsPath
target -> do
    String
source' <- HasFS IO HandleIO -> FsPath -> IO String
forall (m :: * -> *) h. HasFS m h -> FsPath -> m String
FS.unsafeToFilePath HasFS IO HandleIO
hfs FsPath
source -- shouldn't fail because we are in IO
    String
target' <- HasFS IO HandleIO -> FsPath -> IO String
forall (m :: * -> *) h. HasFS m h -> FsPath -> m String
FS.unsafeToFilePath HasFS IO HandleIO
hfs FsPath
target -- shouldn't fail because we are in IO
    String -> String -> IO ()
f String
source' String
target'