{- |
Module:      PFile.Profile.Internal.Lifetime
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 managing profiles lifetime.
-}

{-# LANGUAGE BlockArguments      #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}

module PFile.Profile.Internal.Lifetime
  ( create
  , showCreateError
  , CreateError (..)
  , showCreateRollbackCause
  , CreateRollbackCause (..)
  , CreateOptions (..)
  ) where

import           Control.Monad.Writer                 (execWriterT)
import           PFile.Env                            (Env)
import           PFile.Error
  ( fallback
  , modifyError
  , tellError
  )
import qualified PFile.Log                            as Log
import qualified PFile.Mount                          as Mount
import qualified PFile.Path                           as Path
import           PFile.Profile.Internal.Profile
  ( Entry (..)
  , Name (..)
  , Profile (..)
  , State (..)
  , profileRoot
  )
import           PFile.Profile.Internal.Registry
  ( PopError
  , PushError
  , pop
  , pushAll
  , showPopError
  , showPushError
  )
import           PFile.Profile.Internal.Serialization
  ( DumpError
  , dump
  , load
  , showDumpError
  , showLoadError
  )
import qualified PFile.Profile.LinkHandling           as LinkHandling
import           Protolude                            hiding (state)

-- | Create a new profile called 'PFile.Profile.Internal.Profile.Name' with
-- a list of 'PFile.Path.Absolute' filesystem's objects to be
-- 'PFile.Profile.Internal.Registry.push'ed inside of
-- a 'PFile.Env.profilesHomeDirPath' directory. When an error is encountered
-- during 'PFile.Profile.Internal.Registry.pushAll', 'create' attempts to
-- rollback. If the rollback fails, the profile is considered
-- 'PFile.Profile.Internal.Profile.Dangling'. Only
-- 'PFile.Profile.Internal.Profile.Valid' profiles are returned.
--
-- @since 0.1.0.0
create ::
     forall m. (MonadReader Env m, MonadError CreateError m, MonadIO m)
  => CreateOptions
  -- ^ Options that control 'create' behaviour (currently only
  -- 'linkHandlingStrategy').
  -> Name
  -- ^ 'PFile.Profile.Internal.Profile.Name' of a profile to be created. The
  -- name will be used as a directory name for the profile in
  -- 'PFile.Env.profilesHomeDirPath'.
  -> [Path.Absolute]
  -- ^ List of 'PFile.Path.Absolute' paths of filesystem's objects to be
  -- 'PFile.Profile.Internal.Registry.push'ed into a profile.
  -> m Profile
create :: forall (m :: * -> *).
(MonadReader Env m, MonadError CreateError m, MonadIO m) =>
CreateOptions -> Name -> [Absolute] -> m Profile
create CreateOptions {Strategy
linkHandlingStrategy :: CreateOptions -> Strategy
linkHandlingStrategy :: Strategy
linkHandlingStrategy} Name
name [Absolute]
originPaths = do
  Name -> ExceptT LoadError m Profile
forall (m :: * -> *).
(MonadReader Env m, MonadError LoadError m, MonadIO m) =>
Name -> m Profile
load Name
name ExceptT LoadError m Profile
-> (ExceptT LoadError m Profile -> m (Either LoadError Profile))
-> m (Either LoadError Profile)
forall a b. a -> (a -> b) -> b
& ExceptT LoadError m Profile -> m (Either LoadError Profile)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT m (Either LoadError Profile)
-> (Either LoadError Profile -> 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
>>= (LoadError -> m ())
-> (Profile -> m ()) -> Either LoadError Profile -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    (Text -> m ()
forall (m :: * -> *).
(MonadReader Env m, MonadIO m) =>
Text -> m ()
Log.info (Text -> m ()) -> (LoadError -> Text) -> LoadError -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadError -> Text
showLoadError)
    (m () -> Profile -> m ()
forall a b. a -> b -> a
const (m () -> Profile -> m ())
-> (CreateError -> m ()) -> CreateError -> Profile -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CreateError -> m ()
forall a. CreateError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CreateError -> Profile -> m ()) -> CreateError -> Profile -> m ()
forall a b. (a -> b) -> a -> b
$ Name -> CreateError
ProfileAlreadyExistsError Name
name)
  [Entry]
entries <- Strategy
-> Name
-> [Absolute]
-> ExceptT
     PushError (ExceptT CreateRollbackCause (WriterT [Entry] m)) ()
forall (m :: * -> *).
(MonadReader Env m, MonadError PushError m, MonadWriter [Entry] m,
 MonadIO m) =>
Strategy -> Name -> [Absolute] -> m ()
pushAll Strategy
linkHandlingStrategy Name
name [Absolute]
originPaths
    ExceptT
  PushError (ExceptT CreateRollbackCause (WriterT [Entry] m)) ()
-> (ExceptT
      PushError (ExceptT CreateRollbackCause (WriterT [Entry] m)) ()
    -> m [Entry])
-> m [Entry]
forall a b. a -> (a -> b) -> b
& (CreateRollbackCause -> [Entry] -> m ())
-> ExceptT CreateRollbackCause (WriterT [Entry] m) () -> m [Entry]
forall (m :: * -> *) e w b a.
Monad m =>
(e -> w -> m b) -> ExceptT e (WriterT w m) a -> m w
fallback CreateRollbackCause -> [Entry] -> m ()
rollbackMounts (ExceptT CreateRollbackCause (WriterT [Entry] m) () -> m [Entry])
-> (ExceptT
      PushError (ExceptT CreateRollbackCause (WriterT [Entry] m)) ()
    -> ExceptT CreateRollbackCause (WriterT [Entry] m) ())
-> ExceptT
     PushError (ExceptT CreateRollbackCause (WriterT [Entry] m)) ()
-> m [Entry]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PushError -> CreateRollbackCause)
-> ExceptT
     PushError (ExceptT CreateRollbackCause (WriterT [Entry] m)) ()
-> ExceptT CreateRollbackCause (WriterT [Entry] m) ()
forall e2 (m :: * -> *) e1 a.
MonadError e2 m =>
(e1 -> e2) -> ExceptT e1 m a -> m a
modifyError PushError -> CreateRollbackCause
PushError
  let profile :: Profile
profile = Profile {Name
name :: Name
name :: Name
name, state :: State
state = State
Valid, [Entry]
entries :: [Entry]
entries :: [Entry]
entries}
  Profile -> ExceptT DumpError m ()
forall (m :: * -> *).
(MonadReader Env m, MonadError DumpError m, MonadIO m) =>
Profile -> m ()
dump Profile
profile ExceptT DumpError m ()
-> (ExceptT DumpError m () -> m (Either DumpError ()))
-> m (Either DumpError ())
forall a b. a -> (a -> b) -> b
& ExceptT DumpError m () -> m (Either DumpError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT m (Either DumpError ()) -> (Either DumpError () -> 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
>>= ((DumpError -> m ())
 -> (() -> m ()) -> Either DumpError () -> m ())
-> (() -> m ())
-> (DumpError -> m ())
-> Either DumpError ()
-> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (DumpError -> m ()) -> (() -> m ()) -> Either DumpError () -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    \DumpError
error -> CreateRollbackCause -> [Entry] -> m ()
rollbackMounts (DumpError -> CreateRollbackCause
DumpError DumpError
error) [Entry]
entries
  Profile -> m Profile
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Profile
profile
  where
    rollbackMounts :: CreateRollbackCause -> [Entry] -> m ()
    rollbackMounts :: CreateRollbackCause -> [Entry] -> m ()
rollbackMounts CreateRollbackCause
cause [Entry]
entries = do
      Absolute
root <- Name -> m Absolute
forall (m :: * -> *). MonadReader Env m => Name -> m Absolute
profileRoot Name
name
      [Entry]
entries
        [Entry]
-> ([Entry] -> WriterT [(Entry, PopError)] m ())
-> WriterT [(Entry, PopError)] m ()
forall a b. a -> (a -> b) -> b
& (Entry -> WriterT [(Entry, PopError)] m ())
-> [Entry] -> WriterT [(Entry, PopError)] m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\Entry
entry -> Name
-> Mount
-> ExceptT PopError (WriterT [(Entry, PopError)] m) Absolute
forall (m :: * -> *).
(MonadReader Env m, MonadError PopError m, MonadIO m) =>
Name -> Mount -> m Absolute
pop Name
name (Entry -> Mount
mountPath Entry
entry) ExceptT PopError (WriterT [(Entry, PopError)] m) Absolute
-> (ExceptT PopError (WriterT [(Entry, PopError)] m) Absolute
    -> WriterT [(Entry, PopError)] m ())
-> WriterT [(Entry, PopError)] m ()
forall a b. a -> (a -> b) -> b
& (PopError -> (Entry, PopError))
-> ExceptT PopError (WriterT [(Entry, PopError)] m) Absolute
-> WriterT [(Entry, PopError)] m ()
forall e2 (m :: * -> *) e1 a.
MonadWriter [e2] m =>
(e1 -> e2) -> ExceptT e1 m a -> m ()
tellError (Entry
entry, ))
        WriterT [(Entry, PopError)] m ()
-> (WriterT [(Entry, PopError)] m () -> m [(Entry, PopError)])
-> m [(Entry, PopError)]
forall a b. a -> (a -> b) -> b
& WriterT [(Entry, PopError)] m () -> m [(Entry, PopError)]
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT m [(Entry, PopError)] -> ([(Entry, PopError)] -> 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
>>= \case
          errors :: [(Entry, PopError)]
errors@((Entry, PopError)
_:[(Entry, PopError)]
_) ->
            -- Since we were unable to rollback all the 'mount' calls, some of
            -- the paths are still in the profile. Thus, we should:
            --
            -- * allow user to retrieve the paths from the created profile,
            -- * dump the profile as "dangling", since it wasn't fully created
            --
            -- 'dump' of "dangling" profile could also fail. In this case, the
            -- user should be informed appropriately.
            Profile -> ExceptT DumpError m ()
forall (m :: * -> *).
(MonadReader Env m, MonadError DumpError m, MonadIO m) =>
Profile -> m ()
dump Profile {Name
name :: Name
name :: Name
name, state :: State
state = State
Dangling, entries :: [Entry]
entries = (Entry, PopError) -> Entry
forall a b. (a, b) -> a
fst ((Entry, PopError) -> Entry) -> [(Entry, PopError)] -> [Entry]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Entry, PopError)]
errors}
              ExceptT DumpError m ()
-> (ExceptT DumpError m () -> m (Maybe DumpError))
-> m (Maybe DumpError)
forall a b. a -> (a -> b) -> b
&   (Either DumpError () -> Maybe DumpError)
-> m (Either DumpError ()) -> m (Maybe DumpError)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either DumpError () -> Maybe DumpError
forall l r. Either l r -> Maybe l
leftToMaybe (m (Either DumpError ()) -> m (Maybe DumpError))
-> (ExceptT DumpError m () -> m (Either DumpError ()))
-> ExceptT DumpError m ()
-> m (Maybe DumpError)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT DumpError m () -> m (Either DumpError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
              m (Maybe DumpError)
-> (Maybe DumpError -> CreateError) -> m CreateError
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> CreateRollbackCause
-> [(Entry, PopError)]
-> Absolute
-> Maybe DumpError
-> CreateError
PushRollbackError CreateRollbackCause
cause [(Entry, PopError)]
errors Absolute
root
              m CreateError -> (CreateError -> 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
>>= CreateError -> m ()
forall a. CreateError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
          [] -> do
            -- Since we were able to rollback all the 'mount' calls, we can
            -- remove partially created profile and then interrupt.
            Absolute -> ExceptT RemoveError m ()
forall (m :: * -> *).
(MonadError RemoveError m, MonadIO m) =>
Absolute -> m ()
Path.remove Absolute
root
              ExceptT RemoveError m ()
-> (ExceptT RemoveError m () -> m ()) -> m ()
forall a b. a -> (a -> b) -> b
& m (Either RemoveError ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Either RemoveError ()) -> m ())
-> (ExceptT RemoveError m () -> m (Either RemoveError ()))
-> ExceptT RemoveError m ()
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT RemoveError m () -> m (Either RemoveError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
            CreateError -> m ()
forall a. CreateError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CreateError -> m ()) -> CreateError -> m ()
forall a b. (a -> b) -> a -> b
$ CreateRollbackCause -> CreateError
PushCreateError CreateRollbackCause
cause

showCreateError :: CreateError -> Text
showCreateError :: CreateError -> Text
showCreateError = \case
  ProfileAlreadyExistsError (Name Text
name)
    -> Text
"Profile named \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" already exists."
  PushRollbackError CreateRollbackCause
rollbackCause [(Entry, PopError)]
rollbackErrors Absolute
root Maybe DumpError
maybeDumpError
    -> Text
"`new` has failed"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" with the following error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CreateRollbackCause -> Text
showCreateRollbackCause CreateRollbackCause
rollbackCause
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\nAttempt to unmount paths has failed"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" with the following errors:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [(Entry, PopError)] -> Text
showRollbackErrors [(Entry, PopError)]
rollbackErrors
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Dangling profile with mounted paths could be found here: "
    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 -> (DumpError -> Text) -> Maybe DumpError -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"." DumpError -> Text
showDumpDanglingError Maybe DumpError
maybeDumpError
  PushCreateError CreateRollbackCause
cause -> CreateRollbackCause -> Text
showCreateRollbackCause CreateRollbackCause
cause
  where
    showRollbackErrors :: [(Entry, PopError)] -> Text
    showRollbackErrors :: [(Entry, PopError)] -> Text
showRollbackErrors = [Text] -> Text
unlines ([Text] -> Text)
-> ([(Entry, PopError)] -> [Text]) -> [(Entry, PopError)] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Entry, PopError) -> Text) -> [(Entry, PopError)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      \(Entry {mountPath :: Entry -> Mount
mountPath = Mount.Mount Absolute
mountPath, Absolute
originPath :: Absolute
originPath :: Entry -> Absolute
originPath}, PopError
error)
        -> 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
<> Absolute -> Text
Path.showAbsolute Absolute
mountPath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ("
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PopError -> Text
showPopError PopError
error Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

    showDumpDanglingError :: DumpError -> Text
    showDumpDanglingError :: DumpError -> Text
showDumpDanglingError DumpError
cause
      =  Text
"\nThe profile was not marked as dangling, so you would have to"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" remove it (and recover entries stored in it) manually: "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> DumpError -> Text
showDumpError DumpError
cause

-- | Error thrown by 'create'.
--
-- @since 0.1.0.0
data CreateError
  = ProfileAlreadyExistsError !Name
  -- ^ 'PFile.Profile.Internal.Profile.Profile with
  -- 'PFile.Profile.Internal.Profile.Name' was found in
  -- 'PFile.Env.profilesHomeDirPath'.
  | PushRollbackError
  -- ^ 'create' attempted to rollback due to 'CreateRollbackCause'. The
  -- rollback has failed with a list of
  -- 'PFile.Profile.Internal.Registry.PopError's. Since the rollback has
  -- failed, the profile passed to 'create' is considered
  -- 'PFile.Profile.Internal.Profile.Dangling'.
    !CreateRollbackCause
    -- ^ Cause of rollback.
    ![(Entry, PopError)]
    -- ^ List of errors encountered during rollback.
    !Path.Absolute
    -- ^ Path to a profile's root directory.
    !(Maybe DumpError)
    -- ^ Possible error that could appear during
    -- 'PFile.Profile.Internal.Serialization.dump' attempt of the profile.
  | PushCreateError !CreateRollbackCause
  -- ^ 'create' attempted to rollback due to 'CreateRollbackCause'. The
  -- rollback has succeeded. The profile passed to 'create' was not created.

showCreateRollbackCause :: CreateRollbackCause -> Text
showCreateRollbackCause :: CreateRollbackCause -> Text
showCreateRollbackCause = \case
  PushError PushError
cause -> PushError -> Text
showPushError PushError
cause
  DumpError DumpError
cause -> DumpError -> Text
showDumpError DumpError
cause

-- | 'create' rollback cause.
--
-- @since 0.1.0.0
data CreateRollbackCause
  = PushError !PushError
  -- ^ Error was encountered during 'PFile.Profile.Internal.Registry.pushAll'.
  | DumpError !DumpError
  -- ^ Error was encountered during
  -- 'PFile.Profile.Internal.Serialization.dump'.

-- | 'create' options.
--
-- @since 0.1.0.0
newtype CreateOptions
  = CreateOptions
      { CreateOptions -> Strategy
linkHandlingStrategy :: LinkHandling.Strategy
      -- ^ 'PFile.Profile.LinkHandling.Strategy' to be used when
      -- 'PFile.Profile.Internal.Registry.push'ing a link into a profile.
      }