{- |
Module:      PFile.Mount
Copyright:   (c) 2024 Illia Shkroba
License:     BSD3
Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>
Stability:   unstable
Portability: non-portable (Non-Unix systems are not supported)

Types and functions for mounting filesystem's objects under some "root"
directory.
-}

{-# LANGUAGE BlockArguments             #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE OverloadedStrings          #-}

module PFile.Mount
  ( mount
  , mountPath
  , showMountError
  , MountError (..)
  , unmount
  , originPath
  , showUnmountError
  , UnmountError (..)
  , showOriginResolveError
  , OriginResolveError (..)
  , Root (..)
  , Mount (..)
  ) where

import           Data.Aeson                 (FromJSON, ToJSON)
import           PFile.Error                (liftIOWithError, modifyError)
import           PFile.Path
  ( dropDrive
  , makeRelative
  , move
  , pathIsSymbolicLink
  , (<//>)
  )
import qualified PFile.Path                 as Path
import qualified PFile.Profile.LinkHandling as LinkHandling
import           Protolude
import           System.FilePath            (joinDrive, takeDrive)

-- | Mount a 'PFile.Path.Absolute' inside of a 'Root' with a chosen
-- 'PFile.Profile.LinkHandling.Strategy' for links. 'mount' does the following:
--
-- 1. Moves (renames) 'PFile.Path.Absolute' into 'mountPath' under 'Root'. If
--    the move fails due to cross-device move attempt, the
--    'PFile.Path.Absolute' is copied instead.
-- 2. Removes 'PFile.Path.Absolute' at its original location.
-- 3. Handles links with 'PFile.Profile.LinkHandling.handle'.
--
-- @since 0.1.0.0
mount ::
     (MonadError MountError m, MonadIO m)
  => LinkHandling.Strategy
  -> Root
  -> Path.Absolute
  -> m Mount
mount :: forall (m :: * -> *).
(MonadError MountError m, MonadIO m) =>
Strategy -> Root -> Absolute -> m Mount
mount Strategy
linkHandlingStrategy Root
root Absolute
src = do
  m Bool -> m () -> m () -> m ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Absolute -> IO Bool
forall (m :: * -> *). MonadIO m => Absolute -> m Bool
pathIsSymbolicLink Absolute
src IO Bool -> (IOException -> MountError) -> m Bool
forall e (m :: * -> *) a.
(MonadError e m, MonadIO m) =>
IO a -> (IOException -> e) -> m a
`liftIOWithError` Absolute -> IOException -> MountError
OriginMissingError Absolute
src)
    do
      Strategy -> Absolute -> Absolute -> ExceptT Error m ()
forall (m :: * -> *).
(MonadError Error m, MonadIO m) =>
Strategy -> Absolute -> Absolute -> m ()
LinkHandling.handle Strategy
linkHandlingStrategy Absolute
src Absolute
dest
        ExceptT Error m () -> (ExceptT Error m () -> m ()) -> m ()
forall a b. a -> (a -> b) -> b
& (Error -> MountError) -> ExceptT Error m () -> m ()
forall e2 (m :: * -> *) e1 a.
MonadError e2 m =>
(e1 -> e2) -> ExceptT e1 m a -> m a
modifyError Error -> MountError
LinkHandlingMountError
      Absolute -> ExceptT RemoveError m ()
forall (m :: * -> *).
(MonadError RemoveError m, MonadIO m) =>
Absolute -> m ()
Path.remove Absolute
src
        ExceptT RemoveError m ()
-> (ExceptT RemoveError m () -> m ()) -> m ()
forall a b. a -> (a -> b) -> b
& (RemoveError -> MountError) -> ExceptT RemoveError m () -> m ()
forall e2 (m :: * -> *) e1 a.
MonadError e2 m =>
(e1 -> e2) -> ExceptT e1 m a -> m a
modifyError RemoveError -> MountError
OriginLinkRemoveError
    (Absolute -> Absolute -> ExceptT MoveError m ()
forall (m :: * -> *).
(MonadError MoveError m, MonadIO m) =>
Absolute -> Absolute -> m ()
move Absolute
src Absolute
dest ExceptT MoveError m () -> (ExceptT MoveError m () -> m ()) -> m ()
forall a b. a -> (a -> b) -> b
& (MoveError -> MountError) -> ExceptT MoveError m () -> m ()
forall e2 (m :: * -> *) e1 a.
MonadError e2 m =>
(e1 -> e2) -> ExceptT e1 m a -> m a
modifyError MoveError -> MountError
OriginMoveError)
  Mount -> m Mount
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Mount -> m Mount) -> Mount -> m Mount
forall a b. (a -> b) -> a -> b
$ Absolute -> Mount
Mount Absolute
dest
  where
    Mount Absolute
dest = Root -> Absolute -> Mount
mountPath Root
root Absolute
src

-- | Mount path of a 'PFile.Path.Absolute' inside of a 'Root'. 'mountPath' uses
-- 'PFile.Path.dropDrive' on the 'PFile.Path.Absolute' and then appends the
-- result to the 'Root'. For example:
--
-- >>> mountPath (Root $ Path.Absolute "/a/b/c/") (Path.Absolute "/d/e/f.txt") == Mount (Path.Absolute "/a/b/c/d/e/f.txt")
-- True
--
-- @since 0.1.0.0
mountPath :: Root -> Path.Absolute -> Mount
mountPath :: Root -> Absolute -> Mount
mountPath (Root Absolute
root) Absolute
path = Absolute -> Mount
Mount (Absolute -> Mount) -> Absolute -> Mount
forall a b. (a -> b) -> a -> b
$ Absolute
root Absolute -> String -> Absolute
<//> Absolute -> String
dropDrive Absolute
path

showMountError :: MountError -> Text
showMountError :: MountError -> Text
showMountError = \case
  OriginMissingError Absolute
path IOException
cause
    -> Text
"Unable to find origin file " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Absolute -> Text
Path.showAbsolute Absolute
path
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" because of: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IOException -> Text
forall a b. (Show a, StringConv String b) => a -> b
show IOException
cause
  LinkHandlingMountError Error
cause -> Error -> Text
LinkHandling.showError Error
cause
  OriginLinkRemoveError RemoveError
cause
    -> Text
"Unable to remove link because of: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RemoveError -> Text
Path.showRemoveError RemoveError
cause
  OriginMoveError MoveError
cause -> MoveError -> Text
Path.showMoveError MoveError
cause

-- | Error thrown by 'mount'.
--
-- @since 0.1.0.0
data MountError
  = OriginMissingError !Path.Absolute !IOException
  -- ^ 'PFile.Path.Absolute' is missing. 'IOException' is captured from
  -- 'pathIsSymbolicLink'.
  | LinkHandlingMountError !LinkHandling.Error
  -- ^ Error was encountered during 'PFile.Profile.LinkHandling.handle'.
  | OriginLinkRemoveError !Path.RemoveError
  -- ^ Unable to remove 'PFile.Path.Absolute'. This error is thrown after the
  -- 'PFile.Path.Absolute' got copied under 'Root'.
  | OriginMoveError !Path.MoveError
  -- ^ Error was encountered during 'PFile.Path.move'.

-- | Unmount a 'Mount' from a 'Root' back to its original location. 'unmount'
-- does the following:
--
-- 1. Moves (renames) 'Mount' into 'originPath' from the 'Root'. If the move
--    fails due to cross-device move attempt, the 'Mount' is copied instead.
-- 2. Removes 'Mount' at its original location.
-- 3. Handles links with 'PFile.Profile.LinkHandling.handle
--    PFile.Profile.LinkHandling.CopyLink'.
--
-- @since 0.1.0.0
unmount ::
     (MonadError UnmountError m, MonadIO m) => Root -> Mount -> m Path.Absolute
unmount :: forall (m :: * -> *).
(MonadError UnmountError m, MonadIO m) =>
Root -> Mount -> m Absolute
unmount Root
root (Mount Absolute
src) = do
  Absolute
dest <- Root -> Mount -> ExceptT OriginResolveError m Absolute
forall (m :: * -> *).
MonadError OriginResolveError m =>
Root -> Mount -> m Absolute
originPath Root
root (Absolute -> Mount
Mount Absolute
src)
    ExceptT OriginResolveError m Absolute
-> (ExceptT OriginResolveError m Absolute -> m Absolute)
-> m Absolute
forall a b. a -> (a -> b) -> b
& (OriginResolveError -> UnmountError)
-> ExceptT OriginResolveError m Absolute -> m Absolute
forall e2 (m :: * -> *) e1 a.
MonadError e2 m =>
(e1 -> e2) -> ExceptT e1 m a -> m a
modifyError OriginResolveError -> UnmountError
OriginResolveError
  m Bool -> m () -> m () -> m ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Absolute -> IO Bool
forall (m :: * -> *). MonadIO m => Absolute -> m Bool
pathIsSymbolicLink Absolute
src IO Bool -> (IOException -> UnmountError) -> m Bool
forall e (m :: * -> *) a.
(MonadError e m, MonadIO m) =>
IO a -> (IOException -> e) -> m a
`liftIOWithError` Absolute -> IOException -> UnmountError
MountMissingError Absolute
src)
    do
      Strategy -> Absolute -> Absolute -> ExceptT Error m ()
forall (m :: * -> *).
(MonadError Error m, MonadIO m) =>
Strategy -> Absolute -> Absolute -> m ()
LinkHandling.handle Strategy
LinkHandling.CopyLink Absolute
src Absolute
dest
        ExceptT Error m () -> (ExceptT Error m () -> m ()) -> m ()
forall a b. a -> (a -> b) -> b
& (Error -> UnmountError) -> ExceptT Error m () -> m ()
forall e2 (m :: * -> *) e1 a.
MonadError e2 m =>
(e1 -> e2) -> ExceptT e1 m a -> m a
modifyError Error -> UnmountError
LinkHandlingUnmountError
      Absolute -> ExceptT RemoveError m ()
forall (m :: * -> *).
(MonadError RemoveError m, MonadIO m) =>
Absolute -> m ()
Path.remove Absolute
src
        ExceptT RemoveError m ()
-> (ExceptT RemoveError m () -> m ()) -> m ()
forall a b. a -> (a -> b) -> b
& (RemoveError -> UnmountError) -> ExceptT RemoveError m () -> m ()
forall e2 (m :: * -> *) e1 a.
MonadError e2 m =>
(e1 -> e2) -> ExceptT e1 m a -> m a
modifyError RemoveError -> UnmountError
MountLinkRemoveError
    (Absolute -> Absolute -> ExceptT MoveError m ()
forall (m :: * -> *).
(MonadError MoveError m, MonadIO m) =>
Absolute -> Absolute -> m ()
move Absolute
src Absolute
dest ExceptT MoveError m () -> (ExceptT MoveError m () -> m ()) -> m ()
forall a b. a -> (a -> b) -> b
& (MoveError -> UnmountError) -> ExceptT MoveError m () -> m ()
forall e2 (m :: * -> *) e1 a.
MonadError e2 m =>
(e1 -> e2) -> ExceptT e1 m a -> m a
modifyError MoveError -> UnmountError
MountMoveError)
  Absolute -> m Absolute
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Absolute
dest

-- | Origin path of a 'Mount' outside of a 'Root'. 'originPath' is an inverse
-- of 'mountPath'. Here is an example usage:
--
-- >>> r = originPath (Root $ Path.Absolute "/a/b/c/") (Mount $ Path.Absolute "/a/b/c/d/e/f.txt") & runExcept
-- >>> r & either (const False) (== Path.Absolute "/d/e/f.txt")
-- True
--
-- 'originPath' works only for Posix paths. Windows paths are not supported
-- currently.
--
-- @since 0.1.0.0
originPath :: MonadError OriginResolveError m => Root -> Mount -> m Path.Absolute
originPath :: forall (m :: * -> *).
MonadError OriginResolveError m =>
Root -> Mount -> m Absolute
originPath (Root Absolute
root) (Mount Absolute
path) = do
  let relativePath :: String
relativePath = Absolute -> Absolute -> String
makeRelative Absolute
root Absolute
path
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
relativePath String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Absolute -> String
Path.unAbsolute Absolute
path) (m () -> m ())
-> (OriginResolveError -> m ()) -> OriginResolveError -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OriginResolveError -> m ()
forall a. OriginResolveError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
    (OriginResolveError -> m ()) -> OriginResolveError -> m ()
forall a b. (a -> b) -> a -> b
$ Mount -> Root -> OriginResolveError
OriginOutsideOfRootError (Absolute -> Mount
Mount Absolute
path) (Absolute -> Root
Root Absolute
root)
  String
relativePath
     -- Dirty hack that works for Posix paths
    String -> (String -> String) -> String
forall a b. a -> (a -> b) -> b
& String -> String -> String
joinDrive (String -> String
takeDrive (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Absolute -> String
Path.unAbsolute Absolute
root)
    String -> (String -> m Absolute) -> m Absolute
forall a b. a -> (a -> b) -> b
& Absolute -> m Absolute
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Absolute -> m Absolute)
-> (String -> Absolute) -> String -> m Absolute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Absolute
Path.Absolute

showUnmountError :: UnmountError -> Text
showUnmountError :: UnmountError -> Text
showUnmountError = \case
  OriginResolveError OriginResolveError
cause -> OriginResolveError -> Text
showOriginResolveError OriginResolveError
cause
  MountMissingError Absolute
path IOException
cause
    -> Text
"Unable to find mount file " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Absolute -> Text
Path.showAbsolute Absolute
path
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" because of: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IOException -> Text
forall a b. (Show a, StringConv String b) => a -> b
show IOException
cause
  LinkHandlingUnmountError Error
cause -> Error -> Text
LinkHandling.showError Error
cause
  MountLinkRemoveError RemoveError
cause
    -> Text
"Unable to remove link because of: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RemoveError -> Text
Path.showRemoveError RemoveError
cause
  MountMoveError MoveError
cause -> MoveError -> Text
Path.showMoveError MoveError
cause

-- | Error thrown by 'unmount'.
--
-- @since 0.1.0.0
data UnmountError
  = OriginResolveError !OriginResolveError
  -- ^ Error was encountered during 'originPath'.
  | MountMissingError !Path.Absolute !IOException
  -- ^ 'Mount' is missing. 'IOException' is captured from 'pathIsSymbolicLink'.
  | LinkHandlingUnmountError !LinkHandling.Error
  -- ^ Error was encountered during 'PFile.Profile.LinkHandling.handle'.
  | MountLinkRemoveError !Path.RemoveError
  -- ^ Unable to remove 'Mount'. This error is thrown after the 'Mount' got
  -- copied back to its original location.
  | MountMoveError !Path.MoveError
  -- ^ Error was encountered during 'PFile.Path.move'.

showOriginResolveError :: OriginResolveError -> Text
showOriginResolveError :: OriginResolveError -> Text
showOriginResolveError = \case
  OriginOutsideOfRootError (Mount Absolute
path) (Root Absolute
root)
    -> Text
"Expected path " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Absolute -> Text
Path.showAbsolute Absolute
path
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to be relative to: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Absolute -> Text
Path.showAbsolute Absolute
root Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."

-- | Error thrown by 'originPath'.
--
-- @since 0.1.0.0
data OriginResolveError
  = OriginOutsideOfRootError !Mount !Root
  -- ^ 'Mount' is outside of the 'Root'.

-- | Root for 'mount'ed 'PFile.Path.Absolute's.
--
-- @since 0.1.0.0
newtype Root
  = Root Path.Absolute

-- | 'mount'ed 'PFile.Path.Absolute'.
--
-- @since 0.1.0.0
newtype Mount
  = Mount { Mount -> Absolute
absolute :: Path.Absolute }
  deriving (Mount -> Mount -> Bool
(Mount -> Mount -> Bool) -> (Mount -> Mount -> Bool) -> Eq Mount
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Mount -> Mount -> Bool
== :: Mount -> Mount -> Bool
$c/= :: Mount -> Mount -> Bool
/= :: Mount -> Mount -> Bool
Eq)
  deriving newtype (Value -> Parser [Mount]
Value -> Parser Mount
(Value -> Parser Mount)
-> (Value -> Parser [Mount]) -> FromJSON Mount
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
$cparseJSON :: Value -> Parser Mount
parseJSON :: Value -> Parser Mount
$cparseJSONList :: Value -> Parser [Mount]
parseJSONList :: Value -> Parser [Mount]
FromJSON, [Mount] -> Value
[Mount] -> Encoding
Mount -> Value
Mount -> Encoding
(Mount -> Value)
-> (Mount -> Encoding)
-> ([Mount] -> Value)
-> ([Mount] -> Encoding)
-> ToJSON Mount
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: Mount -> Value
toJSON :: Mount -> Value
$ctoEncoding :: Mount -> Encoding
toEncoding :: Mount -> Encoding
$ctoJSONList :: [Mount] -> Value
toJSONList :: [Mount] -> Value
$ctoEncodingList :: [Mount] -> Encoding
toEncodingList :: [Mount] -> Encoding
ToJSON)