-- | IO implementation of the 'HasFS' class
module Ouroboros.Consensus.Storage.FS.IO (
    -- * IO implementation & monad
    HandleIO
  , ioHasFS
  ) where

import           Control.Concurrent.MVar
import qualified Control.Exception as E
import qualified Data.ByteString.Unsafe as BS
import qualified Data.Set as Set
import           Foreign (castPtr)
import           GHC.Stack
import qualified System.Directory as Dir

import           Ouroboros.Consensus.Storage.FS.API
import           Ouroboros.Consensus.Storage.FS.API.Types
import qualified Ouroboros.Consensus.Storage.FS.Handle as H
import qualified Ouroboros.Consensus.Storage.IO as F

{-------------------------------------------------------------------------------
  I/O implementation of HasFS
-------------------------------------------------------------------------------}

-- | File handlers for the IO instance for HasFS
--
-- We store the path the handle points to for better error messages
type HandleIO = F.FHandle

ioHasFS :: MountPoint -> HasFS IO HandleIO
ioHasFS :: MountPoint -> HasFS IO HandleIO
ioHasFS MountPoint
mount = HasFS :: forall (m :: * -> *) h.
m String
-> (HasCallStack => FsPath -> OpenMode -> m (Handle h))
-> (HasCallStack => Handle h -> m ())
-> (HasCallStack => Handle h -> m Bool)
-> (HasCallStack => Handle h -> SeekMode -> Int64 -> m ())
-> (HasCallStack => Handle h -> Word64 -> m ByteString)
-> (HasCallStack =>
    Handle h -> Word64 -> AbsOffset -> m ByteString)
-> (HasCallStack => Handle h -> ByteString -> m Word64)
-> (HasCallStack => Handle h -> Word64 -> m ())
-> (HasCallStack => Handle h -> m Word64)
-> (HasCallStack => FsPath -> m ())
-> (HasCallStack => Bool -> FsPath -> m ())
-> (HasCallStack => FsPath -> m (Set String))
-> (HasCallStack => FsPath -> m Bool)
-> (HasCallStack => FsPath -> m Bool)
-> (HasCallStack => FsPath -> m ())
-> (HasCallStack => FsPath -> FsPath -> m ())
-> (FsPath -> FsErrorPath)
-> HasFS m h
HasFS {
      -- TODO(adn) Might be useful to implement this properly by reading all
      -- the stuff available at the 'MountPoint'.
      dumpState :: IO String
dumpState = String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"<dumpState@IO>"
    , hOpen :: HasCallStack => FsPath -> OpenMode -> IO (Handle HandleIO)
hOpen = \FsPath
fp OpenMode
openMode -> do
        let path :: String
path = FsPath -> String
root FsPath
fp
        Fd
osHandle <- FsPath -> IO Fd -> IO Fd
forall a. HasCallStack => FsPath -> IO a -> IO a
rethrowFsError FsPath
fp (IO Fd -> IO Fd) -> IO Fd -> IO Fd
forall a b. (a -> b) -> a -> b
$
            String -> OpenMode -> IO Fd
F.open String
path OpenMode
openMode
        MVar (Maybe Fd)
hVar <- Maybe Fd -> IO (MVar (Maybe Fd))
forall a. a -> IO (MVar a)
newMVar (Maybe Fd -> IO (MVar (Maybe Fd)))
-> Maybe Fd -> IO (MVar (Maybe Fd))
forall a b. (a -> b) -> a -> b
$ Fd -> Maybe Fd
forall a. a -> Maybe a
Just Fd
osHandle
        Handle HandleIO -> IO (Handle HandleIO)
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle HandleIO -> IO (Handle HandleIO))
-> Handle HandleIO -> IO (Handle HandleIO)
forall a b. (a -> b) -> a -> b
$ HandleIO -> FsPath -> Handle HandleIO
forall h. h -> FsPath -> Handle h
Handle (String -> MVar (Maybe Fd) -> HandleIO
forall osHandle.
String -> MVar (Maybe osHandle) -> HandleOS osHandle
H.HandleOS String
path MVar (Maybe Fd)
hVar) FsPath
fp
    , hClose :: HasCallStack => Handle HandleIO -> IO ()
hClose = \(Handle HandleIO
h FsPath
fp) -> FsPath -> IO () -> IO ()
forall a. HasCallStack => FsPath -> IO a -> IO a
rethrowFsError FsPath
fp (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        HandleIO -> IO ()
F.close HandleIO
h
    , hIsOpen :: HasCallStack => Handle HandleIO -> IO Bool
hIsOpen = HandleIO -> IO Bool
forall osHandle. HandleOS osHandle -> IO Bool
H.isOpenHandleOS (HandleIO -> IO Bool)
-> (Handle HandleIO -> HandleIO) -> Handle HandleIO -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle HandleIO -> HandleIO
forall h. Handle h -> h
handleRaw
    , hSeek :: HasCallStack => Handle HandleIO -> SeekMode -> Int64 -> IO ()
hSeek = \(Handle HandleIO
h FsPath
fp) SeekMode
mode Int64
o -> FsPath -> IO () -> IO ()
forall a. HasCallStack => FsPath -> IO a -> IO a
rethrowFsError FsPath
fp (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        HandleIO -> SeekMode -> Int64 -> IO ()
F.seek HandleIO
h SeekMode
mode Int64
o
    , hGetSome :: HasCallStack => Handle HandleIO -> Word64 -> IO ByteString
hGetSome = \(Handle HandleIO
h FsPath
fp) Word64
n -> FsPath -> IO ByteString -> IO ByteString
forall a. HasCallStack => FsPath -> IO a -> IO a
rethrowFsError FsPath
fp (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$
        HandleIO -> Word64 -> IO ByteString
F.read HandleIO
h Word64
n
    , hGetSomeAt :: HasCallStack =>
Handle HandleIO -> Word64 -> AbsOffset -> IO ByteString
hGetSomeAt = \(Handle HandleIO
h FsPath
fp) Word64
n AbsOffset
o -> FsPath -> IO ByteString -> IO ByteString
forall a. HasCallStack => FsPath -> IO a -> IO a
rethrowFsError FsPath
fp (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$
        HandleIO -> Word64 -> Word64 -> IO ByteString
F.pread HandleIO
h Word64
n (AbsOffset -> Word64
unAbsOffset AbsOffset
o)
    , hTruncate :: HasCallStack => Handle HandleIO -> Word64 -> IO ()
hTruncate = \(Handle HandleIO
h FsPath
fp) Word64
sz -> FsPath -> IO () -> IO ()
forall a. HasCallStack => FsPath -> IO a -> IO a
rethrowFsError FsPath
fp (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        HandleIO -> Word64 -> IO ()
F.truncate HandleIO
h Word64
sz
    , hGetSize :: HasCallStack => Handle HandleIO -> IO Word64
hGetSize = \(Handle HandleIO
h FsPath
fp) -> FsPath -> IO Word64 -> IO Word64
forall a. HasCallStack => FsPath -> IO a -> IO a
rethrowFsError FsPath
fp (IO Word64 -> IO Word64) -> IO Word64 -> IO Word64
forall a b. (a -> b) -> a -> b
$
        HandleIO -> IO Word64
F.getSize HandleIO
h
    , hPutSome :: HasCallStack => Handle HandleIO -> ByteString -> IO Word64
hPutSome = \(Handle HandleIO
h FsPath
fp) ByteString
bs -> FsPath -> IO Word64 -> IO Word64
forall a. HasCallStack => FsPath -> IO a -> IO a
rethrowFsError FsPath
fp (IO Word64 -> IO Word64) -> IO Word64 -> IO Word64
forall a b. (a -> b) -> a -> b
$ do
        ByteString -> (CStringLen -> IO Word64) -> IO Word64
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO Word64) -> IO Word64)
-> (CStringLen -> IO Word64) -> IO Word64
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
ptr, Int
len) ->
            Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word64) -> IO Word32 -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HandleIO -> Ptr Word8 -> Int64 -> IO Word32
F.write HandleIO
h (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
ptr) (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
    , createDirectory :: HasCallStack => FsPath -> IO ()
createDirectory = \FsPath
fp -> FsPath -> IO () -> IO ()
forall a. HasCallStack => FsPath -> IO a -> IO a
rethrowFsError FsPath
fp (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
Dir.createDirectory (FsPath -> String
root FsPath
fp)
    , listDirectory :: HasCallStack => FsPath -> IO (Set String)
listDirectory = \FsPath
fp -> FsPath -> IO (Set String) -> IO (Set String)
forall a. HasCallStack => FsPath -> IO a -> IO a
rethrowFsError FsPath
fp (IO (Set String) -> IO (Set String))
-> IO (Set String) -> IO (Set String)
forall a b. (a -> b) -> a -> b
$
        [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList ([String] -> Set String) -> IO [String] -> IO (Set String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>  String -> IO [String]
Dir.listDirectory (FsPath -> String
root FsPath
fp)
    , doesDirectoryExist :: HasCallStack => FsPath -> IO Bool
doesDirectoryExist= \FsPath
fp -> FsPath -> IO Bool -> IO Bool
forall a. HasCallStack => FsPath -> IO a -> IO a
rethrowFsError FsPath
fp (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
        String -> IO Bool
Dir.doesDirectoryExist (FsPath -> String
root FsPath
fp)
    , doesFileExist :: HasCallStack => FsPath -> IO Bool
doesFileExist = \FsPath
fp -> FsPath -> IO Bool -> IO Bool
forall a. HasCallStack => FsPath -> IO a -> IO a
rethrowFsError FsPath
fp (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
        String -> IO Bool
Dir.doesFileExist (FsPath -> String
root FsPath
fp)
    , createDirectoryIfMissing :: HasCallStack => Bool -> FsPath -> IO ()
createDirectoryIfMissing = \Bool
createParent FsPath
fp -> FsPath -> IO () -> IO ()
forall a. HasCallStack => FsPath -> IO a -> IO a
rethrowFsError FsPath
fp (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Bool -> String -> IO ()
Dir.createDirectoryIfMissing Bool
createParent (FsPath -> String
root FsPath
fp)
    , removeFile :: HasCallStack => FsPath -> IO ()
removeFile = \FsPath
fp -> FsPath -> IO () -> IO ()
forall a. HasCallStack => FsPath -> IO a -> IO a
rethrowFsError FsPath
fp (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
Dir.removeFile (FsPath -> String
root FsPath
fp)
    , renameFile :: HasCallStack => FsPath -> FsPath -> IO ()
renameFile = \FsPath
fp1 FsPath
fp2 -> FsPath -> IO () -> IO ()
forall a. HasCallStack => FsPath -> IO a -> IO a
rethrowFsError FsPath
fp1 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> String -> IO ()
Dir.renameFile (FsPath -> String
root FsPath
fp1) (FsPath -> String
root FsPath
fp2)
    , mkFsErrorPath :: FsPath -> FsErrorPath
mkFsErrorPath = MountPoint -> FsPath -> FsErrorPath
fsToFsErrorPath MountPoint
mount
    }
  where
    root :: FsPath -> FilePath
    root :: FsPath -> String
root = MountPoint -> FsPath -> String
fsToFilePath MountPoint
mount

    -- | Catch IO exceptions and rethrow them as 'FsError'
    --
    -- See comments for 'ioToFsError'
    rethrowFsError :: HasCallStack => FsPath -> IO a -> IO a
    rethrowFsError :: FsPath -> IO a -> IO a
rethrowFsError 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)
E.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 (m :: * -> *) a. Monad m => a -> m a
return a
a
      where
        handleError :: HasCallStack => IOError -> IO a
        handleError :: IOError -> IO a
handleError IOError
ioErr = 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
errorPath IOError
ioErr

        errorPath :: FsErrorPath
        errorPath :: FsErrorPath
errorPath = MountPoint -> FsPath -> FsErrorPath
fsToFsErrorPath MountPoint
mount FsPath
fp