{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module PFile.Profile.Internal.Serialization
( load
, showLoadError
, LoadError (..)
, dump
, showDumpError
, DumpError (..)
) where
import Data.Aeson
( eitherDecodeFileStrict
, encodeFile
)
import PFile.Aeson (encodePretty)
import PFile.Env (Env)
import PFile.Error (liftIOWithError, modifyError)
import qualified PFile.Log as Log
import qualified PFile.Path as Path
import PFile.Profile.Internal.Profile
( Name (..)
, Profile (..)
, profileState
)
import Protolude
load ::
(MonadReader Env m, MonadError LoadError m, MonadIO m) => Name -> m Profile
load :: forall (m :: * -> *).
(MonadReader Env m, MonadError LoadError m, MonadIO m) =>
Name -> m Profile
load Name
name = do
Absolute
statePath <- Name -> m Absolute
forall (m :: * -> *). MonadReader Env m => Name -> m Absolute
profileState Name
name
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 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
"\" from state: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Absolute -> Text
Path.showAbsolute Absolute
statePath
Profile
profile <- String -> IO (Either String Profile)
forall a. FromJSON a => String -> IO (Either String a)
eitherDecodeFileStrict (Absolute -> String
Path.unAbsolute Absolute
statePath)
IO (Either String Profile)
-> (IOException -> LoadError) -> m (Either String Profile)
forall e (m :: * -> *) a.
(MonadError e m, MonadIO m) =>
IO a -> (IOException -> e) -> m a
`liftIOWithError` Absolute -> IOException -> LoadError
LoadError Absolute
statePath
m (Either String Profile)
-> (Either String Profile -> m Profile) -> m Profile
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> m Profile)
-> (Profile -> m Profile) -> Either String Profile -> m Profile
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (LoadError -> m Profile
forall a. LoadError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LoadError -> m Profile)
-> (String -> LoadError) -> String -> m Profile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Absolute -> String -> LoadError
DecodeError Absolute
statePath) Profile -> m Profile
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
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
"Loaded 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
"\":\n"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Profile -> Text
forall a. ToJSON a => a -> Text
encodePretty Profile
profile
Profile -> m Profile
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Profile
profile
showLoadError :: LoadError -> Text
showLoadError :: LoadError -> Text
showLoadError = \case
LoadError Absolute
path IOException
cause
-> Text
"Unable to load profile from " 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
DecodeError Absolute
path String
cause
-> Text
"Unable to decode profile from " 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
<> String -> Text
forall a b. ConvertText a b => a -> b
toS String
cause Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"."
data LoadError
= LoadError !Path.Absolute !IOException
| DecodeError !Path.Absolute ![Char]
dump ::
(MonadReader Env m, MonadError DumpError m, MonadIO m) => Profile -> m ()
dump :: forall (m :: * -> *).
(MonadReader Env m, MonadError DumpError m, MonadIO m) =>
Profile -> m ()
dump profile :: Profile
profile@Profile {Name
name :: Name
name :: Profile -> Name
name} = do
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
"Dump 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
"\":\n"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Profile -> Text
forall a. ToJSON a => a -> Text
encodePretty Profile
profile
Absolute
statePath <- Name -> m Absolute
forall (m :: * -> *). MonadReader Env m => Name -> m Absolute
profileState Name
name
Absolute -> ExceptT CreateParentError m ()
forall (m :: * -> *).
(MonadError CreateParentError m, MonadIO m) =>
Absolute -> m ()
Path.createParent Absolute
statePath
ExceptT CreateParentError m ()
-> (ExceptT CreateParentError m () -> m ()) -> m ()
forall a b. a -> (a -> b) -> b
& (CreateParentError -> DumpError)
-> ExceptT CreateParentError m () -> m ()
forall e2 (m :: * -> *) e1 a.
MonadError e2 m =>
(e1 -> e2) -> ExceptT e1 m a -> m a
modifyError CreateParentError -> DumpError
CreateParentInDumpError
String -> Profile -> IO ()
forall a. ToJSON a => String -> a -> IO ()
encodeFile (Absolute -> String
Path.unAbsolute Absolute
statePath) Profile
profile
IO () -> (IOException -> DumpError) -> m ()
forall e (m :: * -> *) a.
(MonadError e m, MonadIO m) =>
IO a -> (IOException -> e) -> m a
`liftIOWithError` Absolute -> IOException -> DumpError
DumpError Absolute
statePath
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
"Dumped 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
"\" to state: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Absolute -> Text
Path.showAbsolute Absolute
statePath
showDumpError :: DumpError -> Text
showDumpError :: DumpError -> Text
showDumpError = \case
CreateParentInDumpError CreateParentError
cause -> CreateParentError -> Text
Path.showCreateParentError CreateParentError
cause
DumpError Absolute
path IOException
cause
-> Text
"Unable to dump profile to " 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 DumpError
= CreateParentInDumpError !Path.CreateParentError
| DumpError !Path.Absolute !IOException