{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module PFile.Profile.Internal.Registry
( pushAll
, push
, showPushError
, PushError (..)
, pop
, showPopError
, PopError (..)
, linkAll
, link
, showLinkError
, LinkError (..)
, unpackAll
, unpack
, showUnpackError
, UnpackError (..)
) where
import Control.Monad.Writer (MonadWriter (..))
import PFile.Env (Env)
import PFile.Error (modifyError)
import qualified PFile.Log as Log
import qualified PFile.Mount as Mount
import PFile.Path
( CopyError
, copy
, createLink
, showCopyError
)
import qualified PFile.Path as Path
import PFile.Profile.Internal.Profile (Entry, Name (..), absoluteRoot)
import qualified PFile.Profile.Internal.Profile as Entry (Entry (..))
import qualified PFile.Profile.LinkHandling as LinkHandling
import Protolude hiding (link)
pushAll ::
( MonadReader Env m
, MonadError PushError m
, MonadWriter [Entry] m
, MonadIO m
)
=> LinkHandling.Strategy
-> Name
-> [Path.Absolute]
-> m ()
pushAll :: forall (m :: * -> *).
(MonadReader Env m, MonadError PushError m, MonadWriter [Entry] m,
MonadIO m) =>
Strategy -> Name -> [Absolute] -> m ()
pushAll Strategy
linkHandlingStrategy Name
name = (Absolute -> m ()) -> [Absolute] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ \Absolute
originPath ->
Strategy -> Name -> Absolute -> m Mount
forall (m :: * -> *).
(MonadReader Env m, MonadError PushError m, MonadIO m) =>
Strategy -> Name -> Absolute -> m Mount
push Strategy
linkHandlingStrategy Name
name Absolute
originPath
m Mount -> (Mount -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Mount
mountPath -> [Entry] -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Entry.Entry {Mount
mountPath :: Mount
mountPath :: Mount
Entry.mountPath, Absolute
originPath :: Absolute
originPath :: Absolute
Entry.originPath}]
push ::
(MonadReader Env m, MonadError PushError m, MonadIO m)
=> LinkHandling.Strategy
-> Name
-> Path.Absolute
-> m Mount.Mount
push :: forall (m :: * -> *).
(MonadReader Env m, MonadError PushError m, MonadIO m) =>
Strategy -> Name -> Absolute -> m Mount
push Strategy
linkHandlingStrategy Name
name Absolute
originPath = do
Maybe Type
type_ <- Absolute -> m (Maybe Type)
forall (m :: * -> *). MonadIO m => Absolute -> m (Maybe Type)
Path.typeOf Absolute
originPath
Text -> m ()
forall (m :: * -> *).
(MonadReader Env m, MonadIO m) =>
Text -> m ()
Log.info
(Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Push "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Absolute -> Text
Path.showAbsolute Absolute
originPath
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (Type -> Text) -> Maybe Type -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"unknown" Type -> Text
Path.showType Maybe Type
type_ Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" into profile \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
unName Name
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" with link handling strategy "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Strategy -> Text
LinkHandling.showStrategy Strategy
linkHandlingStrategy Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
Root
root <- Name -> m Root
forall (m :: * -> *). MonadReader Env m => Name -> m Root
absoluteRoot Name
name
Mount
mountPath <- Strategy -> Root -> Absolute -> ExceptT MountError m Mount
forall (m :: * -> *).
(MonadError MountError m, MonadIO m) =>
Strategy -> Root -> Absolute -> m Mount
Mount.mount Strategy
linkHandlingStrategy Root
root Absolute
originPath
ExceptT MountError m Mount
-> (ExceptT MountError m Mount -> m Mount) -> m Mount
forall a b. a -> (a -> b) -> b
& (MountError -> PushError) -> ExceptT MountError m Mount -> m Mount
forall e2 (m :: * -> *) e1 a.
MonadError e2 m =>
(e1 -> e2) -> ExceptT e1 m a -> m a
modifyError MountError -> PushError
PushError
Text -> m ()
forall (m :: * -> *).
(MonadReader Env m, MonadIO m) =>
Text -> m ()
Log.info
(Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Pushed "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Absolute -> Text
Path.showAbsolute Absolute
originPath
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" into profile \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
unName Name
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
Mount -> m Mount
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Mount
mountPath
showPushError :: PushError -> Text
showPushError :: PushError -> Text
showPushError = \case
PushError MountError
cause -> MountError -> Text
Mount.showMountError MountError
cause
newtype PushError
= PushError Mount.MountError
pop ::
(MonadReader Env m, MonadError PopError m, MonadIO m)
=> Name
-> Mount.Mount
-> m Path.Absolute
pop :: forall (m :: * -> *).
(MonadReader Env m, MonadError PopError m, MonadIO m) =>
Name -> Mount -> m Absolute
pop Name
name Mount
mountPath = do
Maybe Type
type_ <- Absolute -> m (Maybe Type)
forall (m :: * -> *). MonadIO m => Absolute -> m (Maybe Type)
Path.typeOf (Absolute -> m (Maybe Type))
-> (Mount -> Absolute) -> Mount -> m (Maybe Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mount -> Absolute
Mount.absolute (Mount -> m (Maybe Type)) -> Mount -> m (Maybe Type)
forall a b. (a -> b) -> a -> b
$ Mount
mountPath
Text -> m ()
forall (m :: * -> *).
(MonadReader Env m, MonadIO m) =>
Text -> m ()
Log.info
(Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Pop "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Absolute -> Text
Path.showAbsolute (Mount -> Absolute
Mount.absolute Mount
mountPath)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (Type -> Text) -> Maybe Type -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"unknown" Type -> Text
Path.showType Maybe Type
type_ Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from profile \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
unName Name
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
Root
root <- Name -> m Root
forall (m :: * -> *). MonadReader Env m => Name -> m Root
absoluteRoot Name
name
Absolute
originPath <- Root -> Mount -> ExceptT UnmountError m Absolute
forall (m :: * -> *).
(MonadError UnmountError m, MonadIO m) =>
Root -> Mount -> m Absolute
Mount.unmount Root
root Mount
mountPath
ExceptT UnmountError m Absolute
-> (ExceptT UnmountError m Absolute -> m Absolute) -> m Absolute
forall a b. a -> (a -> b) -> b
& (UnmountError -> PopError)
-> ExceptT UnmountError m Absolute -> m Absolute
forall e2 (m :: * -> *) e1 a.
MonadError e2 m =>
(e1 -> e2) -> ExceptT e1 m a -> m a
modifyError UnmountError -> PopError
PopError
Text -> m ()
forall (m :: * -> *).
(MonadReader Env m, MonadIO m) =>
Text -> m ()
Log.info
(Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Popped "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Absolute -> Text
Path.showAbsolute (Mount -> Absolute
Mount.absolute Mount
mountPath)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from profile \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
unName Name
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
Absolute -> m Absolute
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Absolute
originPath
showPopError :: PopError -> Text
showPopError :: PopError -> Text
showPopError = \case
PopError UnmountError
cause -> UnmountError -> Text
Mount.showUnmountError UnmountError
cause
newtype PopError
= PopError Mount.UnmountError
linkAll ::
(MonadError LinkError m, MonadWriter [Path.Absolute] m, MonadIO m)
=> [Entry]
-> m ()
linkAll :: forall (m :: * -> *).
(MonadError LinkError m, MonadWriter [Absolute] m, MonadIO m) =>
[Entry] -> m ()
linkAll = (Entry -> m ()) -> [Entry] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ \Entry.Entry {Mount
mountPath :: Entry -> Mount
mountPath :: Mount
Entry.mountPath, Absolute
originPath :: Entry -> Absolute
originPath :: Absolute
Entry.originPath} ->
[Absolute
originPath] [Absolute] -> m () -> m [Absolute]
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Mount -> Absolute -> m ()
forall (m :: * -> *).
(MonadError LinkError m, MonadIO m) =>
Mount -> Absolute -> m ()
link Mount
mountPath Absolute
originPath m [Absolute] -> ([Absolute] -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Absolute] -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
link ::
(MonadError LinkError m, MonadIO m)
=> Mount.Mount
-> Path.Absolute
-> m ()
link :: forall (m :: * -> *).
(MonadError LinkError m, MonadIO m) =>
Mount -> Absolute -> m ()
link Mount
mountPath Absolute
originPath =
Absolute -> Absolute -> ExceptT CreateLinkError m ()
forall (m :: * -> *).
(MonadError CreateLinkError m, MonadIO m) =>
Absolute -> Absolute -> m ()
createLink (Mount -> Absolute
Mount.absolute Mount
mountPath) Absolute
originPath
ExceptT CreateLinkError m ()
-> (ExceptT CreateLinkError m () -> m ()) -> m ()
forall a b. a -> (a -> b) -> b
& (CreateLinkError -> LinkError)
-> ExceptT CreateLinkError m () -> m ()
forall e2 (m :: * -> *) e1 a.
MonadError e2 m =>
(e1 -> e2) -> ExceptT e1 m a -> m a
modifyError CreateLinkError -> LinkError
LinkError
showLinkError :: LinkError -> Text
showLinkError :: LinkError -> Text
showLinkError = \case
LinkError CreateLinkError
cause -> CreateLinkError -> Text
Path.showCreateLinkError CreateLinkError
cause
newtype LinkError
= LinkError Path.CreateLinkError
unpackAll ::
(MonadError UnpackError m, MonadWriter [Path.Absolute] m, MonadIO m)
=> [Entry]
-> m ()
unpackAll :: forall (m :: * -> *).
(MonadError UnpackError m, MonadWriter [Absolute] m, MonadIO m) =>
[Entry] -> m ()
unpackAll = (Entry -> m ()) -> [Entry] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ \Entry.Entry {Mount
mountPath :: Entry -> Mount
mountPath :: Mount
Entry.mountPath, Absolute
originPath :: Entry -> Absolute
originPath :: Absolute
Entry.originPath} ->
[Absolute
originPath] [Absolute] -> m () -> m [Absolute]
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Mount -> Absolute -> m ()
forall (m :: * -> *).
(MonadError UnpackError m, MonadIO m) =>
Mount -> Absolute -> m ()
unpack Mount
mountPath Absolute
originPath m [Absolute] -> ([Absolute] -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Absolute] -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
unpack ::
(MonadError UnpackError m, MonadIO m)
=> Mount.Mount
-> Path.Absolute
-> m ()
unpack :: forall (m :: * -> *).
(MonadError UnpackError m, MonadIO m) =>
Mount -> Absolute -> m ()
unpack Mount
mountPath Absolute
originPath =
Absolute -> Absolute -> ExceptT CopyError m ()
forall (m :: * -> *).
(MonadError CopyError m, MonadIO m) =>
Absolute -> Absolute -> m ()
copy (Mount -> Absolute
Mount.absolute Mount
mountPath) Absolute
originPath
ExceptT CopyError m () -> (ExceptT CopyError m () -> m ()) -> m ()
forall a b. a -> (a -> b) -> b
& (CopyError -> UnpackError) -> ExceptT CopyError m () -> m ()
forall e2 (m :: * -> *) e1 a.
MonadError e2 m =>
(e1 -> e2) -> ExceptT e1 m a -> m a
modifyError (Mount -> Absolute -> CopyError -> UnpackError
UnpackError Mount
mountPath Absolute
originPath)
showUnpackError :: UnpackError -> Text
showUnpackError :: UnpackError -> Text
showUnpackError = \case
UnpackError (Mount.Mount Absolute
src) Absolute
dest CopyError
cause
-> Text
"Unable to unpack " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Absolute -> Text
Path.showAbsolute Absolute
src
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Absolute -> Text
Path.showAbsolute Absolute
dest
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" because of: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CopyError -> Text
showCopyError CopyError
cause
data UnpackError
= UnpackError !Mount.Mount !Path.Absolute !CopyError