{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module PFile.Profile.Internal.Current
( loadCurrent
, showLoadCurrentError
, LoadCurrentError (..)
, setCurrent
, unsetCurrent
, showSetCurrentError
, SetCurrentError (..)
, showUnsetCurrentError
, UnsetCurrentError (..)
) where
import PFile.Env (Env (..))
import PFile.Error
( liftIOWithError
, modifyError
)
import qualified PFile.Log as Log
import PFile.Path
( canonicalizePath
, createDirectoryLink
, takeBaseName
)
import qualified PFile.Path as Path
import PFile.Profile.Internal.Profile
( Name (..)
, Profile (..)
, profileRoot
)
import PFile.Profile.Internal.Serialization
( LoadError
, load
, showLoadError
)
import Protolude
loadCurrent ::
(MonadReader Env m, MonadError LoadCurrentError m, MonadIO m) => m Profile
loadCurrent :: forall (m :: * -> *).
(MonadReader Env m, MonadError LoadCurrentError m, MonadIO m) =>
m Profile
loadCurrent = do
Env {Absolute
currentLinkPath :: Env -> Absolute
currentLinkPath :: Absolute
currentLinkPath} <- m Env
forall r (m :: * -> *). MonadReader r m => m r
ask
Text -> m ()
forall (m :: * -> *).
(MonadReader Env m, MonadIO m) =>
Text -> m ()
Log.info Text
"Canonicalize link pointing at current profile"
Absolute
currentPath <- Absolute -> IO Absolute
forall (m :: * -> *). MonadIO m => Absolute -> m Absolute
canonicalizePath Absolute
currentLinkPath
IO Absolute -> (IOException -> LoadCurrentError) -> m Absolute
forall e (m :: * -> *) a.
(MonadError e m, MonadIO m) =>
IO a -> (IOException -> e) -> m a
`liftIOWithError` Absolute -> IOException -> LoadCurrentError
CanonicalizeCurrentError Absolute
currentLinkPath
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
"Canonicalized link pointing at current profile: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Absolute -> Text
Path.showAbsolute Absolute
currentPath
Absolute
currentPath
Absolute -> (Absolute -> Name) -> Name
forall a b. a -> (a -> b) -> b
& Text -> Name
Name (Text -> Name) -> (Absolute -> Text) -> Absolute -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a b. ConvertText a b => a -> b
toS (String -> Text) -> (Absolute -> String) -> Absolute -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Absolute -> String
takeBaseName
Name
-> (Name -> ExceptT LoadError m Profile)
-> ExceptT LoadError m Profile
forall a b. a -> (a -> b) -> b
& Name -> ExceptT LoadError m Profile
forall (m :: * -> *).
(MonadReader Env m, MonadError LoadError m, MonadIO m) =>
Name -> m Profile
load
ExceptT LoadError m Profile
-> (ExceptT LoadError m Profile -> m Profile) -> m Profile
forall a b. a -> (a -> b) -> b
& (LoadError -> LoadCurrentError)
-> ExceptT LoadError m Profile -> m Profile
forall e2 (m :: * -> *) e1 a.
MonadError e2 m =>
(e1 -> e2) -> ExceptT e1 m a -> m a
modifyError LoadError -> LoadCurrentError
LoadCurrentError
showLoadCurrentError :: LoadCurrentError -> Text
showLoadCurrentError :: LoadCurrentError -> Text
showLoadCurrentError = \case
CanonicalizeCurrentError Absolute
path IOException
cause
-> Text
"Unable to resolve current link " 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
LoadCurrentError LoadError
cause -> LoadError -> Text
showLoadError LoadError
cause
data LoadCurrentError
= CanonicalizeCurrentError !Path.Absolute !IOException
| LoadCurrentError !LoadError
setCurrent ::
(MonadReader Env m, MonadError SetCurrentError m, MonadIO m)
=> Profile
-> m ()
setCurrent :: forall (m :: * -> *).
(MonadReader Env m, MonadError SetCurrentError m, MonadIO m) =>
Profile -> m ()
setCurrent Profile {Name
name :: Name
name :: Profile -> Name
name} = do
Env {Absolute
currentLinkPath :: Env -> Absolute
currentLinkPath :: Absolute
currentLinkPath} <- m Env
forall r (m :: * -> *). MonadReader r m => m r
ask
ExceptT UnsetCurrentError m ()
forall (m :: * -> *).
(MonadReader Env m, MonadError UnsetCurrentError m, MonadIO m) =>
m ()
unsetCurrent
ExceptT UnsetCurrentError m ()
-> (ExceptT UnsetCurrentError m () -> m ()) -> m ()
forall a b. a -> (a -> b) -> b
& (UnsetCurrentError -> SetCurrentError)
-> ExceptT UnsetCurrentError m () -> m ()
forall e2 (m :: * -> *) e1 a.
MonadError e2 m =>
(e1 -> e2) -> ExceptT e1 m a -> m a
modifyError UnsetCurrentError -> SetCurrentError
UnsetCurrentError
Absolute
root <- Name -> m Absolute
forall (m :: * -> *). MonadReader Env m => Name -> m Absolute
profileRoot Name
name
Absolute -> Absolute -> ExceptT CreateDirectoryLinkError m ()
forall (m :: * -> *).
(MonadError CreateDirectoryLinkError m, MonadIO m) =>
Absolute -> Absolute -> m ()
createDirectoryLink Absolute
root Absolute
currentLinkPath
ExceptT CreateDirectoryLinkError m ()
-> (ExceptT CreateDirectoryLinkError m () -> m ()) -> m ()
forall a b. a -> (a -> b) -> b
& (CreateDirectoryLinkError -> SetCurrentError)
-> ExceptT CreateDirectoryLinkError m () -> m ()
forall e2 (m :: * -> *) e1 a.
MonadError e2 m =>
(e1 -> e2) -> ExceptT e1 m a -> m a
modifyError CreateDirectoryLinkError -> SetCurrentError
CurrentLinkError
unsetCurrent ::
(MonadReader Env m, MonadError UnsetCurrentError m, MonadIO m) => m ()
unsetCurrent :: forall (m :: * -> *).
(MonadReader Env m, MonadError UnsetCurrentError m, MonadIO m) =>
m ()
unsetCurrent = do
Env {Absolute
currentLinkPath :: Env -> Absolute
currentLinkPath :: Absolute
currentLinkPath} <- m Env
forall r (m :: * -> *). MonadReader r m => m r
ask
Absolute -> ExceptT RemoveError m ()
forall (m :: * -> *).
(MonadError RemoveError m, MonadIO m) =>
Absolute -> m ()
Path.remove Absolute
currentLinkPath
ExceptT RemoveError m ()
-> (ExceptT RemoveError m () -> m ()) -> m ()
forall a b. a -> (a -> b) -> b
& (RemoveError -> UnsetCurrentError)
-> ExceptT RemoveError m () -> m ()
forall e2 (m :: * -> *) e1 a.
MonadError e2 m =>
(e1 -> e2) -> ExceptT e1 m a -> m a
modifyError RemoveError -> UnsetCurrentError
CurrentLinkRemoveError
showSetCurrentError :: SetCurrentError -> Text
showSetCurrentError :: SetCurrentError -> Text
showSetCurrentError = \case
UnsetCurrentError UnsetCurrentError
cause -> UnsetCurrentError -> Text
showUnsetCurrentError UnsetCurrentError
cause
CurrentLinkError CreateDirectoryLinkError
cause -> CreateDirectoryLinkError -> Text
Path.showCreateDirectoryLinkError CreateDirectoryLinkError
cause
data SetCurrentError
= UnsetCurrentError !UnsetCurrentError
| CurrentLinkError !Path.CreateDirectoryLinkError
showUnsetCurrentError :: UnsetCurrentError -> Text
showUnsetCurrentError :: UnsetCurrentError -> Text
showUnsetCurrentError = \case
CurrentLinkRemoveError RemoveError
cause
-> Text
"Unable to remove current profile link because of: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RemoveError -> Text
Path.showRemoveError RemoveError
cause
newtype UnsetCurrentError
= CurrentLinkRemoveError Path.RemoveError