-- | Patch model state depending on file change event.
module Emanote.Source.Patch (
  patchModel,
  filePatterns,
  ignorePatterns,
) where

import Control.Exception (throwIO)
import Control.Monad.Logger (LoggingT (runLoggingT), MonadLogger, MonadLoggerIO (askLoggerIO))
import Data.ByteString qualified as BS
import Data.List.NonEmpty qualified as NEL
import Data.Time (defaultTimeLocale, formatTime, getCurrentTime)
import Emanote.Model qualified as M
import Emanote.Model.Note qualified as N
import Emanote.Model.SData qualified as SD
import Emanote.Model.Stork.Index qualified as Stork
import Emanote.Model.Type (ModelEma)
import Emanote.Prelude (
  BadInput (BadInput),
  log,
  logD,
 )
import Emanote.Route qualified as R
import Emanote.Source.Loc (Loc, LocLayers, locPath, locResolve, primaryLayer)
import Emanote.Source.Pattern (filePatterns, ignorePatterns)
import Heist.Extra.TemplateState qualified as T
import Optics.Operators ((%~))
import Relude
import Relude.Extra (traverseToSnd)
import System.UnionMount qualified as UM
import UnliftIO.Concurrent (threadDelay)
import UnliftIO.Directory (doesDirectoryExist)

-- | Map a filesystem change to the corresponding model change.
patchModel ::
  (MonadIO m, MonadLogger m, MonadLoggerIO m) =>
  LocLayers ->
  (N.Note -> N.Note) ->
  Stork.IndexVar ->
  -- | Type of the file being changed
  R.FileType R.SourceExt ->
  -- | Path to the file being changed
  FilePath ->
  -- | Specific change to the file, along with its paths from other "layers"
  UM.FileAction (NonEmpty (Loc, FilePath)) ->
  m (ModelEma -> ModelEma)
patchModel :: forall (m :: Type -> Type).
(MonadIO m, MonadLogger m, MonadLoggerIO m) =>
LocLayers
-> (Note -> Note)
-> IndexVar
-> FileType SourceExt
-> FilePath
-> FileAction (NonEmpty (Loc, FilePath))
-> m (ModelEma -> ModelEma)
patchModel LocLayers
layers Note -> Note
noteF IndexVar
storkIndexTVar FileType SourceExt
fpType FilePath
fp FileAction (NonEmpty (Loc, FilePath))
action = do
  Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logger <- forall (m :: Type -> Type).
MonadLoggerIO m =>
m (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
askLoggerIO
  UTCTime
now <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  -- Prefix all patch logging with timestamp.
  let newLogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
newLogger Loc
loc LogSource
src LogLevel
lvl LogStr
s =
        Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logger Loc
loc LogSource
src LogLevel
lvl forall a b. (a -> b) -> a -> b
$ forall a. IsString a => FilePath -> a
fromString (forall t. FormatTime t => TimeLocale -> FilePath -> t -> FilePath
formatTime TimeLocale
defaultTimeLocale FilePath
"[%H:%M:%S] " UTCTime
now) forall a. Semigroup a => a -> a -> a
<> LogStr
s
  forall (m :: Type -> Type) a.
LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT (forall (m :: Type -> Type).
(MonadIO m, MonadLogger m) =>
LocLayers
-> (Note -> Note)
-> IndexVar
-> FileType SourceExt
-> FilePath
-> FileAction (NonEmpty (Loc, FilePath))
-> m (ModelEma -> ModelEma)
patchModel' LocLayers
layers Note -> Note
noteF IndexVar
storkIndexTVar FileType SourceExt
fpType FilePath
fp FileAction (NonEmpty (Loc, FilePath))
action) Loc -> LogSource -> LogLevel -> LogStr -> IO ()
newLogger

-- | Map a filesystem change to the corresponding model change.
patchModel' ::
  (MonadIO m, MonadLogger m) =>
  LocLayers ->
  (N.Note -> N.Note) ->
  Stork.IndexVar ->
  -- | Type of the file being changed
  R.FileType R.SourceExt ->
  -- | Path to the file being changed
  FilePath ->
  -- | Specific change to the file, along with its paths from other "layers"
  UM.FileAction (NonEmpty (Loc, FilePath)) ->
  m (ModelEma -> ModelEma)
patchModel' :: forall (m :: Type -> Type).
(MonadIO m, MonadLogger m) =>
LocLayers
-> (Note -> Note)
-> IndexVar
-> FileType SourceExt
-> FilePath
-> FileAction (NonEmpty (Loc, FilePath))
-> m (ModelEma -> ModelEma)
patchModel' LocLayers
layers Note -> Note
noteF IndexVar
storkIndexTVar FileType SourceExt
fpType FilePath
fp FileAction (NonEmpty (Loc, FilePath))
action = do
  case FileType SourceExt
fpType of
    R.LMLType LML
lmlType -> do
      case LML -> FilePath -> Maybe LMLRoute
R.mkLMLRouteFromKnownFilePath LML
lmlType FilePath
fp of
        Maybe LMLRoute
Nothing ->
          forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a. a -> a
id -- Impossible
        Just LMLRoute
r -> do
          -- Stork doesn't support incremental building of index, so we must
          -- clear it to pave way for a rebuild later when requested.
          --
          -- From https://github.com/jameslittle230/stork/discussions/112#discussioncomment-252861
          --
          -- > Stork also doesn't support incremental index updates today --
          -- you'd have to re-index everything when users added a new document,
          -- which might be prohibitively long.
          forall (m :: Type -> Type). MonadIO m => IndexVar -> m ()
Stork.clearStorkIndex IndexVar
storkIndexTVar

          case FileAction (NonEmpty (Loc, FilePath))
action of
            UM.Refresh RefreshAction
refreshAction NonEmpty (Loc, FilePath)
overlays -> do
              let fpAbs :: FilePath
fpAbs = (Loc, FilePath) -> FilePath
locResolve forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type) a. IsNonEmpty f a a "head" => f a -> a
head NonEmpty (Loc, FilePath)
overlays
                  -- TODO: This should automatically be computed, instead of being passed.
                  -- We need access to the model though! With dependency management to boot.
                  -- Until this, `layers` is threaded through as a hack.
                  currentLayerPath :: FilePath
currentLayerPath = Loc -> FilePath
locPath forall a b. (a -> b) -> a -> b
$ HasCallStack => LocLayers -> Loc
primaryLayer LocLayers
layers
              ByteString
s <- forall (m :: Type -> Type).
(MonadLogger m, MonadIO m) =>
RefreshAction -> FilePath -> m ByteString
readRefreshedFile RefreshAction
refreshAction FilePath
fpAbs
              Note
note <- forall (m :: Type -> Type).
(MonadIO m, MonadLogger m) =>
FilePath -> LMLRoute -> FilePath -> LogSource -> m Note
N.parseNote FilePath
currentLayerPath LMLRoute
r FilePath
fpAbs (forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 ByteString
s)
              forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type). Note -> ModelT f -> ModelT f
M.modelInsertNote forall a b. (a -> b) -> a -> b
$ Note -> Note
noteF Note
note
            FileAction (NonEmpty (Loc, FilePath))
UM.Delete -> do
              forall (m :: Type -> Type). MonadLogger m => LogSource -> m ()
log forall a b. (a -> b) -> a -> b
$ LogSource
"Removing note: " forall a. Semigroup a => a -> a -> a
<> forall a. ToText a => a -> LogSource
toText FilePath
fp
              forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type). LMLRoute -> ModelT f -> ModelT f
M.modelDeleteNote LMLRoute
r
    FileType SourceExt
R.Yaml ->
      case forall a (ext :: FileType a).
HasExt @a ext =>
FilePath -> Maybe (R @a ext)
R.mkRouteFromFilePath FilePath
fp of
        Maybe (R @SourceExt 'Yaml)
Nothing ->
          forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a. a -> a
id
        Just R @SourceExt 'Yaml
r -> case FileAction (NonEmpty (Loc, FilePath))
action of
          UM.Refresh RefreshAction
refreshAction NonEmpty (Loc, FilePath)
overlays -> do
            NonEmpty (FilePath, ByteString)
yamlContents <- forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a. NonEmpty a -> NonEmpty a
NEL.reverse NonEmpty (Loc, FilePath)
overlays) forall a b. (a -> b) -> a -> b
$ \(Loc, FilePath)
overlay -> do
              let fpAbs :: FilePath
fpAbs = (Loc, FilePath) -> FilePath
locResolve (Loc, FilePath)
overlay
              forall (t :: Type -> Type) a b.
Functor t =>
(a -> t b) -> a -> t (a, b)
traverseToSnd (forall (m :: Type -> Type).
(MonadLogger m, MonadIO m) =>
RefreshAction -> FilePath -> m ByteString
readRefreshedFile RefreshAction
refreshAction) FilePath
fpAbs
            SData
sData <-
              forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
                forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall e a. Exception e => e -> IO a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogSource -> BadInput
BadInput) forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                  R @SourceExt 'Yaml
-> NonEmpty (FilePath, ByteString) -> Either LogSource SData
SD.parseSDataCascading R @SourceExt 'Yaml
r NonEmpty (FilePath, ByteString)
yamlContents
            forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type). SData -> ModelT f -> ModelT f
M.modelInsertData SData
sData
          FileAction (NonEmpty (Loc, FilePath))
UM.Delete -> do
            forall (m :: Type -> Type). MonadLogger m => LogSource -> m ()
log forall a b. (a -> b) -> a -> b
$ LogSource
"Removing data: " forall a. Semigroup a => a -> a -> a
<> forall a. ToText a => a -> LogSource
toText FilePath
fp
            forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type).
R @SourceExt 'Yaml -> ModelT f -> ModelT f
M.modelDeleteData R @SourceExt 'Yaml
r
    FileType SourceExt
R.HeistTpl ->
      case FileAction (NonEmpty (Loc, FilePath))
action of
        UM.Refresh RefreshAction
refreshAction NonEmpty (Loc, FilePath)
overlays -> do
          let fpAbs :: FilePath
fpAbs = (Loc, FilePath) -> FilePath
locResolve forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type) a. IsNonEmpty f a a "head" => f a -> a
head NonEmpty (Loc, FilePath)
overlays
              -- Once we start loading HTML templates, mark the model as "ready"
              -- so Ema will begin rendering content in place of "Loading..."
              -- indicator
              readyOnTemplates :: ModelEma -> ModelEma
readyOnTemplates = forall a. a -> a -> Bool -> a
bool forall a. a -> a
id forall (f :: Type -> Type). ModelT f -> ModelT f
M.modelReadyForView (RefreshAction
refreshAction forall a. Eq a => a -> a -> Bool
== RefreshAction
UM.Existing)
          ModelEma -> ModelEma
act <- do
            ByteString
s <- forall (m :: Type -> Type).
(MonadLogger m, MonadIO m) =>
RefreshAction -> FilePath -> m ByteString
readRefreshedFile RefreshAction
refreshAction FilePath
fpAbs
            forall (m :: Type -> Type). MonadLogger m => LogSource -> m ()
logD forall a b. (a -> b) -> a -> b
$ LogSource
"Read " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show (ByteString -> Int
BS.length ByteString
s) forall a. Semigroup a => a -> a -> a
<> LogSource
" bytes of template"
            forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (encF :: Type -> Type). Lens' (ModelT encF) TemplateState
M.modelHeistTemplate forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ HasCallStack =>
FilePath
-> FilePath -> ByteString -> TemplateState -> TemplateState
T.addTemplateFile FilePath
fpAbs FilePath
fp ByteString
s
          forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ModelEma -> ModelEma
readyOnTemplates forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category @k cat =>
cat a b -> cat b c -> cat a c
>>> ModelEma -> ModelEma
act
        FileAction (NonEmpty (Loc, FilePath))
UM.Delete -> do
          forall (m :: Type -> Type). MonadLogger m => LogSource -> m ()
log forall a b. (a -> b) -> a -> b
$ LogSource
"Removing template: " forall a. Semigroup a => a -> a -> a
<> forall a. ToText a => a -> LogSource
toText FilePath
fp
          forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (encF :: Type -> Type). Lens' (ModelT encF) TemplateState
M.modelHeistTemplate forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ HasCallStack => FilePath -> TemplateState -> TemplateState
T.removeTemplateFile FilePath
fp
    FileType SourceExt
R.AnyExt -> do
      case forall a (ext :: FileType a).
HasExt @a ext =>
FilePath -> Maybe (R @a ext)
R.mkRouteFromFilePath FilePath
fp of
        Maybe (R @SourceExt 'AnyExt)
Nothing ->
          forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a. a -> a
id
        Just R @SourceExt 'AnyExt
r -> case FileAction (NonEmpty (Loc, FilePath))
action of
          UM.Refresh RefreshAction
refreshAction NonEmpty (Loc, FilePath)
overlays -> do
            let fpAbs :: FilePath
fpAbs = (Loc, FilePath) -> FilePath
locResolve forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type) a. IsNonEmpty f a a "head" => f a -> a
head NonEmpty (Loc, FilePath)
overlays
            forall (m :: Type -> Type). MonadIO m => FilePath -> m Bool
doesDirectoryExist FilePath
fpAbs forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Bool
True ->
                -- A directory got added; this is not a static 'file'
                forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a. a -> a
id
              Bool
False -> do
                let logF :: LogSource -> m ()
logF = case RefreshAction
refreshAction of
                      RefreshAction
UM.Existing -> forall (m :: Type -> Type). MonadLogger m => LogSource -> m ()
logD forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogSource
"Registering" <>)
                      RefreshAction
_ -> forall (m :: Type -> Type). MonadLogger m => LogSource -> m ()
log forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogSource
"Re-registering" <>)
                LogSource -> m ()
logF forall a b. (a -> b) -> a -> b
$ LogSource
" file: " forall a. Semigroup a => a -> a -> a
<> forall a. ToText a => a -> LogSource
toText FilePath
fpAbs forall a. Semigroup a => a -> a -> a
<> LogSource
" " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show R @SourceExt 'AnyExt
r
                UTCTime
t <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
                forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type).
UTCTime -> R @SourceExt 'AnyExt -> FilePath -> ModelT f -> ModelT f
M.modelInsertStaticFile UTCTime
t R @SourceExt 'AnyExt
r FilePath
fpAbs
          FileAction (NonEmpty (Loc, FilePath))
UM.Delete -> do
            forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type).
R @SourceExt 'AnyExt -> ModelT f -> ModelT f
M.modelDeleteStaticFile R @SourceExt 'AnyExt
r

readRefreshedFile :: (MonadLogger m, MonadIO m) => UM.RefreshAction -> FilePath -> m ByteString
readRefreshedFile :: forall (m :: Type -> Type).
(MonadLogger m, MonadIO m) =>
RefreshAction -> FilePath -> m ByteString
readRefreshedFile RefreshAction
refreshAction FilePath
fp =
  case RefreshAction
refreshAction of
    RefreshAction
UM.Existing -> do
      forall (m :: Type -> Type). MonadLogger m => LogSource -> m ()
logD forall a b. (a -> b) -> a -> b
$ LogSource
"Loading file: " forall a. Semigroup a => a -> a -> a
<> forall a. ToText a => a -> LogSource
toText FilePath
fp
      forall (m :: Type -> Type). MonadIO m => FilePath -> m ByteString
readFileBS FilePath
fp
    RefreshAction
_ ->
      forall (m :: Type -> Type).
(MonadIO m, MonadLogger m) =>
FilePath -> m ByteString
readFileFollowingFsnotify FilePath
fp

{- | Like `readFileBS` but accounts for file truncation due to us responding
 *immediately* to a fsnotify modify event (which is triggered even before the
 writer *finishes* writing the new contents). We solve this "glitch" by
 delaying the read retry, expecting (hoping really) that *this time* the new
 non-empty contents will come through. 'tis a bit of a HACK though.
-}
readFileFollowingFsnotify :: (MonadIO m, MonadLogger m) => FilePath -> m ByteString
readFileFollowingFsnotify :: forall (m :: Type -> Type).
(MonadIO m, MonadLogger m) =>
FilePath -> m ByteString
readFileFollowingFsnotify FilePath
fp = do
  forall (m :: Type -> Type). MonadLogger m => LogSource -> m ()
log forall a b. (a -> b) -> a -> b
$ LogSource
"Reading file: " forall a. Semigroup a => a -> a -> a
<> forall a. ToText a => a -> LogSource
toText FilePath
fp
  forall (m :: Type -> Type). MonadIO m => FilePath -> m ByteString
readFileBS FilePath
fp forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    ByteString
"" ->
      forall {m :: Type -> Type}.
(MonadIO m, MonadLogger m) =>
Int -> FilePath -> m ByteString
reReadFileBS Int
100 FilePath
fp forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        ByteString
"" ->
          -- Sometimes 100ms is not enough (eg: on WSL), so wait a bit more and
          -- give it another try.
          forall {m :: Type -> Type}.
(MonadIO m, MonadLogger m) =>
Int -> FilePath -> m ByteString
reReadFileBS Int
300 FilePath
fp
        ByteString
s -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ByteString
s
    ByteString
s -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ByteString
s
  where
    -- Wait before reading, logging the given delay.
    reReadFileBS :: Int -> FilePath -> m ByteString
reReadFileBS Int
ms FilePath
filePath = do
      forall (m :: Type -> Type). MonadIO m => Int -> m ()
threadDelay forall a b. (a -> b) -> a -> b
$ Int
1000 forall a. Num a => a -> a -> a
* Int
ms
      forall (m :: Type -> Type). MonadLogger m => LogSource -> m ()
log forall a b. (a -> b) -> a -> b
$ LogSource
"Re-reading (" forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Int
ms forall a. Semigroup a => a -> a -> a
<> LogSource
"ms" forall a. Semigroup a => a -> a -> a
<> LogSource
") file: " forall a. Semigroup a => a -> a -> a
<> forall a. ToText a => a -> LogSource
toText FilePath
filePath
      forall (m :: Type -> Type). MonadIO m => FilePath -> m ByteString
readFileBS FilePath
filePath