-- |Interpreters for 'Persist'
module Ribosome.Interpreter.Persist where

import Data.Aeson (eitherDecodeFileStrict', encodeFile)
import Exon (exon)
import qualified Log
import Path (Abs, Dir, File, Path, Rel, parent, parseRelDir, parseRelFile, toFilePath, (</>))
import Path.IO (createDirIfMissing, doesFileExist)

import qualified Ribosome.Data.PersistError as PersistError
import Ribosome.Data.PersistError (PersistError)
import Ribosome.Data.PersistPathError (PersistPathError)
import qualified Ribosome.Effect.Persist as Persist
import Ribosome.Effect.Persist (Persist)
import Ribosome.Effect.PersistPath (PersistPath, persistRoot)
import Ribosome.Host.Data.BootError (BootError (BootError))
import Ribosome.Host.Interpret (with)
import Ribosome.Host.Path (pathText)

-- |Obtain the root directory or stop.
persistBase ::
  Members [PersistPath !! PersistPathError, Stop PersistError] r =>
  Sem r (Path Abs Dir)
persistBase :: forall (r :: EffectRow).
Members '[PersistPath !! PersistPathError, Stop PersistError] r =>
Sem r (Path Abs Dir)
persistBase =
  (PersistPathError -> PersistError)
-> Sem (PersistPath : r) (Path Abs Dir) -> Sem r (Path Abs Dir)
forall err (eff :: (* -> *) -> * -> *) err' (r :: EffectRow) a.
Members '[Resumable err eff, Stop err'] r =>
(err -> err') -> Sem (eff : r) a -> Sem r a
resumeHoist PersistPathError -> PersistError
PersistError.Path Sem (PersistPath : r) (Path Abs Dir)
forall (r :: EffectRow).
Member PersistPath r =>
Sem r (Path Abs Dir)
persistRoot

-- |Load a file and JSON-decode it.
loadFile ::
  FromJSON a =>
  Members [Stop PersistError, Log, Embed IO] r =>
  Path Abs File ->
  Sem r a
loadFile :: forall a (r :: EffectRow).
(FromJSON a, Members '[Stop PersistError, Log, Embed IO] r) =>
Path Abs File -> Sem r a
loadFile Path Abs File
file = do
  Text -> Sem r ()
forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.debug [exon|Loading persistence file: #{show file}|]
  (String -> PersistError) -> Either String a -> Sem r a
forall err' (r :: EffectRow) err a.
Member (Stop err') r =>
(err -> err') -> Either err a -> Sem r a
stopEitherWith String -> PersistError
decodeFailed (Either String a -> Sem r a) -> Sem r (Either String a) -> Sem r a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PersistError -> Maybe (Either String a) -> Sem r (Either String a)
forall err (r :: EffectRow) a.
Member (Stop err) r =>
err -> Maybe a -> Sem r a
stopNote PersistError
notReadable (Maybe (Either String a) -> Sem r (Either String a))
-> Sem r (Maybe (Either String a)) -> Sem r (Either String a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either String a) -> Sem r (Maybe (Either String a))
forall (r :: EffectRow) a.
Member (Embed IO) r =>
IO a -> Sem r (Maybe a)
tryMaybe (String -> IO (Either String a)
forall a. FromJSON a => String -> IO (Either String a)
eitherDecodeFileStrict' (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
file))
  where
    notReadable :: PersistError
notReadable =
      Text -> PersistError
PersistError.Permission (Path Abs File -> Text
forall b t. Path b t -> Text
pathText Path Abs File
file)
    decodeFailed :: String -> PersistError
decodeFailed =
      Text -> Text -> PersistError
PersistError.Decode (Path Abs File -> Text
forall b t. Path b t -> Text
pathText Path Abs File
file) (Text -> PersistError)
-> (String -> Text) -> String -> PersistError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText

-- |Determine the path to use for a 'Persist' action.
-- If a @subpath@ is given, append it to @dir@, otherwise use @singleFile@.
-- Append the result of the first step to the root dir given by 'PersistPath'.
filepath ::
  Members [PersistPath !! PersistPathError, Stop PersistError] r =>
  Path Rel File ->
  Path Rel Dir ->
  Maybe (Path Rel File) ->
  Sem r (Path Abs File)
filepath :: forall (r :: EffectRow).
Members '[PersistPath !! PersistPathError, Stop PersistError] r =>
Path Rel File
-> Path Rel Dir -> Maybe (Path Rel File) -> Sem r (Path Abs File)
filepath Path Rel File
singleFile Path Rel Dir
dir Maybe (Path Rel File)
subpath = do
  Path Abs Dir
base <- Sem r (Path Abs Dir)
forall (r :: EffectRow).
Members '[PersistPath !! PersistPathError, Stop PersistError] r =>
Sem r (Path Abs Dir)
persistBase
  pure (Path Abs Dir
base Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
-> (Path Rel File -> Path Rel File)
-> Maybe (Path Rel File)
-> Path Rel File
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Path Rel File
singleFile (Path Rel Dir
dir Path Rel Dir -> Path Rel File -> Path Rel File
forall b t. Path b Dir -> Path Rel t -> Path b t
</>) Maybe (Path Rel File)
subpath)

-- |Interpret 'Persist' by writing to the file system.
--
-- Paths are determined as follows:
--
-- - 'PersistPath' defines the root directory for all 'Persist' effects, which might be specific to a plugin, or
-- additionally to entities like the currently edited project (e.g. by directory).
--
-- - The value in the @name@ argument is appended to the root depending on the arguments to the effect constructors.
--
-- - When 'Ribosome.Effect.Persist.store' or 'Ribosome.Effect.Persist.load' are invoked with 'Nothing' for the @subpath@
-- argument, a file named @<name>.json@ is used.
--
-- - When invoked with 'Just' a subpath, a file named @<name>/<subpath>.json@ is used.
--
-- This uses 'Resumable', see [Errors]("Ribosome#errors").
interpretPersist ::
  ToJSON a =>
  FromJSON a =>
  Members [PersistPath !! PersistPathError, Error BootError, Log, Embed IO] r =>
  Text ->
  InterpreterFor (Persist a !! PersistError) r
interpretPersist :: forall a (r :: EffectRow).
(ToJSON a, FromJSON a,
 Members
   '[PersistPath !! PersistPathError, Error BootError, Log, Embed IO]
   r) =>
Text -> InterpreterFor (Persist a !! PersistError) r
interpretPersist Text
name =
  Sem r (Path Rel File, Path Rel Dir)
-> ((Path Rel File, Path Rel Dir)
    -> InterpreterFor (Persist a !! PersistError) r)
-> InterpreterFor (Persist a !! PersistError) r
forall (r :: EffectRow) a (eff :: (* -> *) -> * -> *).
Sem r a -> (a -> InterpreterFor eff r) -> InterpreterFor eff r
with Sem r (Path Rel File, Path Rel Dir)
parse \ (Path Rel File
singleFile, Path Rel Dir
dir) ->
    (forall x (r0 :: EffectRow).
 Persist a (Sem r0) x -> Sem (Stop PersistError : r) x)
-> InterpreterFor (Persist a !! PersistError) r
forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow).
FirstOrder eff "interpretResumable" =>
(forall x (r0 :: EffectRow).
 eff (Sem r0) x -> Sem (Stop err : r) x)
-> InterpreterFor (Resumable err eff) r
interpretResumable \case
      Persist.Store Maybe (Path Rel File)
subpath a
a -> do
        Path Abs File
path <- Path Rel File
-> Path Rel Dir
-> Maybe (Path Rel File)
-> Sem (Stop PersistError : r) (Path Abs File)
forall (r :: EffectRow).
Members '[PersistPath !! PersistPathError, Stop PersistError] r =>
Path Rel File
-> Path Rel Dir -> Maybe (Path Rel File) -> Sem r (Path Abs File)
filepath Path Rel File
singleFile Path Rel Dir
dir Maybe (Path Rel File)
subpath
        let base :: Path Abs Dir
base = Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
path
        PersistError -> Maybe () -> Sem (Stop PersistError : r) ()
forall err (r :: EffectRow) a.
Member (Stop err) r =>
err -> Maybe a -> Sem r a
stopNote (Text -> PersistError
PersistError.Permission (Path Abs Dir -> Text
forall b t. Path b t -> Text
pathText Path Abs Dir
base)) (Maybe () -> Sem (Stop PersistError : r) ())
-> Sem (Stop PersistError : r) (Maybe ())
-> Sem (Stop PersistError : r) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO () -> Sem (Stop PersistError : r) (Maybe ())
forall (r :: EffectRow) a.
Member (Embed IO) r =>
IO a -> Sem r (Maybe a)
tryMaybe (Bool -> Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Bool -> Path b Dir -> m ()
createDirIfMissing Bool
True Path Abs Dir
base)
        IO () -> Sem (Stop PersistError : r) ()
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (String -> a -> IO ()
forall a. ToJSON a => String -> a -> IO ()
encodeFile (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
path) a
a)
      Persist.Load Maybe (Path Rel File)
subpath -> do
        Path Abs File
path <- Path Rel File
-> Path Rel Dir
-> Maybe (Path Rel File)
-> Sem (Stop PersistError : r) (Path Abs File)
forall (r :: EffectRow).
Members '[PersistPath !! PersistPathError, Stop PersistError] r =>
Path Rel File
-> Path Rel Dir -> Maybe (Path Rel File) -> Sem r (Path Abs File)
filepath Path Rel File
singleFile Path Rel Dir
dir Maybe (Path Rel File)
subpath
        Text -> Sem (Stop PersistError : r) ()
forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.debug [exon|Persistence path requested: #{show path}|]
        Sem (Stop PersistError : r) Bool
-> Sem (Stop PersistError : r) (Maybe a)
-> Sem (Stop PersistError : r) (Maybe a)
-> Sem (Stop PersistError : r) (Maybe a)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool)
-> Sem (Stop PersistError : r) (Maybe Bool)
-> Sem (Stop PersistError : r) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Bool -> Sem (Stop PersistError : r) (Maybe Bool)
forall (r :: EffectRow) a.
Member (Embed IO) r =>
IO a -> Sem r (Maybe a)
tryMaybe (Path Abs File -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
path)) (Path Abs File -> Sem (Stop PersistError : r) (Maybe a)
forall a (r :: EffectRow).
(FromJSON a, Members '[Stop PersistError, Log, Embed IO] r) =>
Path Abs File -> Sem r a
loadFile Path Abs File
path) (Maybe a -> Sem (Stop PersistError : r) (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing)
  where
    parse :: Sem r (Path Rel File, Path Rel Dir)
parse =
      BootError
-> Maybe (Path Rel File, Path Rel Dir)
-> Sem r (Path Rel File, Path Rel Dir)
forall e (r :: EffectRow) a.
Member (Error e) r =>
e -> Maybe a -> Sem r a
note (Text -> BootError
BootError [exon|Invalid persist name: #{name}|]) Maybe (Path Rel File, Path Rel Dir)
namePaths
    namePaths :: Maybe (Path Rel File, Path Rel Dir)
namePaths =
      (,) (Path Rel File -> Path Rel Dir -> (Path Rel File, Path Rel Dir))
-> Maybe (Path Rel File)
-> Maybe (Path Rel Dir -> (Path Rel File, Path Rel Dir))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (Text -> String
forall a. ToString a => a -> String
toString [exon|#{name}.json|]) Maybe (Path Rel Dir -> (Path Rel File, Path Rel Dir))
-> Maybe (Path Rel Dir) -> Maybe (Path Rel File, Path Rel Dir)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Maybe (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir (Text -> String
forall a. ToString a => a -> String
toString Text
name)

-- |Interpret 'Persist' by storing nothing.
interpretPersistNull ::
  ∀ a err r .
  InterpreterFor (Persist a !! err) r
interpretPersistNull :: forall a err (r :: EffectRow). InterpreterFor (Persist a !! err) r
interpretPersistNull =
  (forall x (r0 :: EffectRow).
 Persist a (Sem r0) x -> Sem (Stop err : r) x)
-> InterpreterFor (Resumable err (Persist a)) r
forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow).
FirstOrder eff "interpretResumable" =>
(forall x (r0 :: EffectRow).
 eff (Sem r0) x -> Sem (Stop err : r) x)
-> InterpreterFor (Resumable err eff) r
interpretResumable \case
    Persist.Store Maybe (Path Rel File)
_ a
_ ->
      Sem (Stop err : r) x
forall (f :: * -> *). Applicative f => f ()
unit
    Persist.Load Maybe (Path Rel File)
_ ->
      Maybe a -> Sem (Stop err : r) (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing