{-# 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 ::
(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
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
data MountError
= OriginMissingError !Path.Absolute !IOException
| LinkHandlingMountError !LinkHandling.Error
| OriginLinkRemoveError !Path.RemoveError
| OriginMoveError !Path.MoveError
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
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
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
data UnmountError
= OriginResolveError !OriginResolveError
| MountMissingError !Path.Absolute !IOException
| LinkHandlingUnmountError !LinkHandling.Error
| MountLinkRemoveError !Path.RemoveError
| MountMoveError !Path.MoveError
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
"."
data OriginResolveError
= OriginOutsideOfRootError !Mount !Root
newtype Root
= Root Path.Absolute
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)