{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module PFile.Profile.Internal.List
( list
, showListError
, ListError (..)
, ListOptions (..)
) where
import PFile.Env (Env (..))
import PFile.Error (liftIOWithError)
import qualified PFile.Log as Log
import PFile.Path
( doesPathExist
, listDirectory
, takeBaseName
)
import qualified PFile.Path as Path
import PFile.Profile.Internal.Profile
( Name (..)
, Profile (..)
, State (..)
)
import PFile.Profile.Internal.Serialization (load, showLoadError)
import Protolude hiding (list, state)
list ::
forall m. (MonadReader Env m, MonadError ListError m, MonadIO m)
=> ListOptions
-> m [Profile]
list :: forall (m :: * -> *).
(MonadReader Env m, MonadError ListError m, MonadIO m) =>
ListOptions -> m [Profile]
list ListOptions {Bool
shouldFilterDangling :: ListOptions -> Bool
shouldFilterDangling :: Bool
shouldFilterDangling} = do
Env {Absolute
profilesHomeDirPath :: Env -> Absolute
profilesHomeDirPath :: Absolute
profilesHomeDirPath} <- m Env
forall r (m :: * -> *). MonadReader r m => m r
ask
m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Absolute -> m Bool
forall (m :: * -> *). MonadIO m => Absolute -> m Bool
doesPathExist Absolute
profilesHomeDirPath) (m () -> m ()) -> (ListError -> m ()) -> ListError -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ListError -> m ()
forall a. ListError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
(ListError -> m ()) -> ListError -> m ()
forall a b. (a -> b) -> a -> b
$ Absolute -> ListError
ProfilesHomeDirDoesNotExistError Absolute
profilesHomeDirPath
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
"List profile names in "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Absolute -> Text
Path.showAbsolute Absolute
profilesHomeDirPath
[Name]
names <- Absolute -> IO [Absolute]
forall (m :: * -> *). MonadIO m => Absolute -> m [Absolute]
listDirectory Absolute
profilesHomeDirPath
IO [Absolute] -> (IOException -> ListError) -> m [Absolute]
forall e (m :: * -> *) a.
(MonadError e m, MonadIO m) =>
IO a -> (IOException -> e) -> m a
`liftIOWithError` Absolute -> IOException -> ListError
ListDirectoryError Absolute
profilesHomeDirPath
m [Absolute] -> ([Absolute] -> [Name]) -> m [Name]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Absolute -> Name) -> [Absolute] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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)
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
"Load profiles: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a b. (Show a, StringConv String b) => a -> b
show (Name -> Text
unName (Name -> Text) -> [Name] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
names)
[Profile]
profiles <- [Maybe Profile] -> [Profile]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Profile] -> [Profile]) -> m [Maybe Profile] -> m [Profile]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name] -> (Name -> m (Maybe Profile)) -> m [Maybe Profile]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
names \Name
name ->
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 (Maybe Profile))
-> m (Maybe Profile)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left LoadError
error -> do
Text -> m ()
forall (m :: * -> *).
(MonadReader Env m, MonadIO m) =>
Text -> m ()
Log.warning (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ LoadError -> Text
showLoadError LoadError
error
Maybe Profile -> m (Maybe Profile)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Profile
forall a. Maybe a
Nothing
Right Profile
profile -> Maybe Profile -> m (Maybe Profile)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Profile -> m (Maybe Profile))
-> Maybe Profile -> m (Maybe Profile)
forall a b. (a -> b) -> a -> b
$ Profile -> Maybe Profile
forall a. a -> Maybe a
Just Profile
profile
if Bool
shouldFilterDangling
then do
Text -> m ()
forall (m :: * -> *).
(MonadReader Env m, MonadIO m) =>
Text -> m ()
Log.info Text
"Filter Dangling profiles"
[Profile] -> m [Profile]
filterDangling [Profile]
profiles
else [Profile] -> m [Profile]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Profile]
profiles
where
filterDangling :: [Profile] -> m [Profile]
filterDangling :: [Profile] -> m [Profile]
filterDangling = (Profile -> m Bool) -> [Profile] -> m [Profile]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM \Profile {Name
name :: Name
name :: Profile -> Name
name, State
state :: State
state :: Profile -> State
state} ->
case State
state of
State
Dangling -> do
Text -> m ()
forall (m :: * -> *).
(MonadReader Env m, MonadIO m) =>
Text -> m ()
Log.warning (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Found Dangling 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
"\""
Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
State
Valid -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
showListError :: ListError -> Text
showListError :: ListError -> Text
showListError = \case
ProfilesHomeDirDoesNotExistError Absolute
path
-> Text
"Profiles home directory " 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
" does not exist."
ListDirectoryError Absolute
path IOException
cause
-> Text
"Unable to list profiles home directory " 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
data ListError
= ProfilesHomeDirDoesNotExistError !Path.Absolute
| ListDirectoryError !Path.Absolute !IOException
newtype ListOptions
= ListOptions
{ ListOptions -> Bool
shouldFilterDangling :: Bool
}