{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
module Database.Franz.Internal.Fuse where

import Control.Exception hiding (throw)
import Control.Monad (when)
import Control.Retry
import System.Directory
import System.Process (ProcessHandle, spawnProcess, cleanupProcess,
  waitForProcess, getProcessExitCode)

mountFuse :: ([String] -> IO ()) -- logger
  -> (forall x. String -> IO x) -- throw an exception
  -> FilePath -> FilePath -> IO ProcessHandle
mountFuse :: ([String] -> IO ())
-> (forall x. String -> IO x)
-> String
-> String
-> IO ProcessHandle
mountFuse [String] -> IO ()
logger forall x. String -> IO x
throw String
src String
dest = do
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
dest
  [String] -> IO ()
logger [String
"squashfuse", String
"-f", String
src, String
dest]
  IO ProcessHandle
-> (ProcessHandle -> IO ())
-> (ProcessHandle -> IO ProcessHandle)
-> IO ProcessHandle
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError (String -> [String] -> IO ProcessHandle
spawnProcess String
"squashfuse" [String
"-f", String
src, String
dest]) ((ProcessHandle -> String -> IO ())
-> String -> ProcessHandle -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (([String] -> IO ()) -> ProcessHandle -> String -> IO ()
killFuse [String] -> IO ()
logger) String
dest) ((ProcessHandle -> IO ProcessHandle) -> IO ProcessHandle)
-> (ProcessHandle -> IO ProcessHandle) -> IO ProcessHandle
forall a b. (a -> b) -> a -> b
$ \ProcessHandle
fuse -> do
    -- It keeps process handles so that mounted directories are cleaned up
    -- but there's no easy way to tell when squashfuse finished mounting.
    -- Wait until the destination becomes non-empty.
    Bool
notMounted <- RetryPolicyM IO
-> (RetryStatus -> Bool -> IO Bool)
-> (RetryStatus -> IO Bool)
-> IO Bool
forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
retrying (Int -> RetryPolicy
limitRetries Int
5 RetryPolicyM IO -> RetryPolicyM IO -> RetryPolicyM IO
forall a. Semigroup a => a -> a -> a
<> Int -> RetryPolicyM IO
forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
exponentialBackoff Int
100000) ((Bool -> IO Bool) -> RetryStatus -> Bool -> IO Bool
forall a b. a -> b -> a
const Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
      ((RetryStatus -> IO Bool) -> IO Bool)
-> (RetryStatus -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \RetryStatus
status -> ProcessHandle -> IO (Maybe ExitCode)
getProcessExitCode ProcessHandle
fuse IO (Maybe ExitCode) -> (Maybe ExitCode -> IO Bool) -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe ExitCode
Nothing -> do
          [String] -> IO ()
logger [String
"Waiting for squashfuse to mount", String
src, String
":", RetryStatus -> String
forall a. Show a => a -> String
show RetryStatus
status]
          [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([String] -> Bool) -> IO [String] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
listDirectory String
dest
        Just ExitCode
e -> do
          String -> IO ()
removeDirectory String
dest
          String -> IO Bool
forall x. String -> IO x
throw (String -> IO Bool) -> String -> IO Bool
forall a b. (a -> b) -> a -> b
$ String
"squashfuse exited with " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ExitCode -> String
forall a. Show a => a -> String
show ExitCode
e
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
notMounted (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall x. String -> IO x
throw (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Failed to mount " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
src
    ProcessHandle -> IO ProcessHandle
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessHandle
fuse

killFuse :: ([String] -> IO ()) -> ProcessHandle -> FilePath -> IO ()
killFuse :: ([String] -> IO ()) -> ProcessHandle -> String -> IO ()
killFuse [String] -> IO ()
logger ProcessHandle
fuse String
path = do
  (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
cleanupProcess (Maybe Handle
forall a. Maybe a
Nothing, Maybe Handle
forall a. Maybe a
Nothing, Maybe Handle
forall a. Maybe a
Nothing, ProcessHandle
fuse)
  ExitCode
e <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
fuse
  [String] -> IO ()
logger [String
"squashfuse:", ExitCode -> String
forall a. Show a => a -> String
show ExitCode
e]
  String -> IO ()
removeDirectory String
path