emanote 1.0.2.0 → 1.2.0.0
raw patch · 43 files changed
+568/−207 lines, 43 filesdep +feeddep +pandoc-lua-enginedep ~commonmark-extensionsdep ~ema
Dependencies added: feed, pandoc-lua-engine
Dependency ranges changed: commonmark-extensions, ema
Files
- CHANGELOG.md +15/−0
- README.md +1/−0
- default/index.yaml +2/−0
- default/templates/base.tpl +1/−0
- default/templates/components/pandoc.tpl +1/−1
- default/templates/filters/embed-audio.tpl +5/−0
- default/templates/filters/embed-code.tpl +3/−0
- emanote.cabal +8/−4
- src/Emanote.hs +1/−1
- src/Emanote/Model/Graph.hs +6/−6
- src/Emanote/Model/Link/Rel.hs +1/−1
- src/Emanote/Model/Link/Resolve.hs +3/−3
- src/Emanote/Model/Meta.hs +4/−4
- src/Emanote/Model/Note.hs +49/−11
- src/Emanote/Model/Note/Filter.hs +8/−7
- src/Emanote/Model/SData.hs +1/−1
- src/Emanote/Model/StaticFile.hs +76/−0
- src/Emanote/Model/Stork.hs +10/−4
- src/Emanote/Model/Stork/Index.hs +30/−3
- src/Emanote/Model/Type.hs +32/−9
- src/Emanote/Pandoc/BuiltinFilters.hs +3/−11
- src/Emanote/Pandoc/ExternalLink.hs +2/−2
- src/Emanote/Pandoc/Link.hs +1/−1
- src/Emanote/Pandoc/Markdown/Syntax/HashTag.hs +1/−1
- src/Emanote/Pandoc/Renderer/Embed.hs +27/−39
- src/Emanote/Pandoc/Renderer/Query.hs +5/−5
- src/Emanote/Pandoc/Renderer/Url.hs +4/−3
- src/Emanote/Prelude.hs +5/−5
- src/Emanote/Route/Ext.hs +8/−2
- src/Emanote/Route/ModelRoute.hs +21/−9
- src/Emanote/Route/R.hs +13/−5
- src/Emanote/Route/SiteRoute/Class.hs +44/−22
- src/Emanote/Route/SiteRoute/Type.hs +7/−7
- src/Emanote/Source/Dynamic.hs +3/−1
- src/Emanote/Source/Loc.hs +1/−1
- src/Emanote/Source/Patch.hs +12/−5
- src/Emanote/Source/Pattern.hs +3/−3
- src/Emanote/View/Common.hs +5/−6
- src/Emanote/View/Export.hs +1/−1
- src/Emanote/View/Feed.hs +105/−0
- src/Emanote/View/TagIndex.hs +1/−1
- src/Emanote/View/TaskIndex.hs +2/−2
- src/Emanote/View/Template.hs +37/−20
CHANGELOG.md view
@@ -1,5 +1,20 @@ # Revision history for emanote +## 1.2.0.0 (2023-08-24)++- Bug fixes+ - Make Stork recognize orgmode notes ([\#413](https://github.com/srid/emanote/issues/413))+- Features+ - Audio embedding ([\#418](https://github.com/srid/emanote/pull/418))+ - Source code embedding ([\#444](https://github.com/srid/emanote/pull/444))+ - Atom feed ([\#451](https://github.com/srid/emanote/pull/451))+ - Add option to show folders first in the sidebar [\#399](https://github.com/srid/emanote/pull/399)+- UI+ - Remove inline styling of H2 elements+- Misc+ - Update Ema to simplify the live server websocket observation logic+ - Use GHC 9.4 & Pandoc 3+ ## 1.0.2.0 (2023-01-29) - Nix
README.md view
@@ -3,6 +3,7 @@ [](https://en.wikipedia.org/wiki/Affero_General_Public_License) [](https://builtwithnix.org) [](https://app.element.io/#/room/#ema:matrix.org "Chat on Matrix")+[](https://srid.ca/unwoke) Emanote emanates[^def] a structured view of your plain-text notes.
default/index.yaml view
@@ -36,6 +36,8 @@ # Whether this node in the sidebar tree should remain collapsed by default # (unless a route in it is active) collapsed: true+ # Weather this node should put folders before single notes+ folders-first: false stork: # https://stork-search.net/docs/config-ref#frontmatter_handling frontmatter-handling: omit
default/templates/base.tpl view
@@ -21,6 +21,7 @@ </with> <snippet var="page.headHtml" /> </ema:metadata>+ <emaNoteFeedUrl /> <tailwindCssShim /> <style>
default/templates/components/pandoc.tpl view
@@ -98,7 +98,7 @@ <Code class="py-0.5 px-0.5 bg-gray-100" /> <Header> <h1 class="pb-2 mb-2 text-5xl font-bold text-center" />- <h2 class="inline-block mt-6 mb-4 text-4xl font-bold text-gray-700 border-b-2" />+ <h2 class="mt-6 mb-4 text-4xl font-bold text-gray-700 border-b-2" /> <h3 class="mt-6 mb-2 text-3xl font-bold text-gray-700" /> <h4 class="mt-6 mb-2 text-2xl font-bold text-gray-700" /> <h5 class="mt-6 mb-2 text-xl font-bold text-gray-700" />
+ default/templates/filters/embed-audio.tpl view
@@ -0,0 +1,5 @@+<audio controls preload="metadata" src="${ema:url}">+ Your browser doesn't support HTML5 audio. Here is a+ <a class="text-${theme}-600 hover:underline" href="${ema:url}">link to the audio</a>+ instead.+</audio>
+ default/templates/filters/embed-code.tpl view
@@ -0,0 +1,3 @@+<div class="py-0.5 mb-3 text-sm" title="${ema:alt}">+ <pre><code class="${ema:code:language}" ><ema:code:content /></code></pre>+</div>
emanote.cabal view
@@ -1,11 +1,12 @@ cabal-version: 2.4 name: emanote-version: 1.0.2.0+version: 1.2.0.0 license: AGPL-3.0-only copyright: 2022 Sridhar Ratnakumar maintainer: srid@srid.ca author: Sridhar Ratnakumar category: Web+homepage: https://emanote.srid.ca synopsis: Emanate a structured view of your plain-text notes description: Create beautiful websites -- such as personal webpage, blog, wiki, Zettelkasten, notebook, knowledge-base, documentation, etc. from future-proof plain-text notes and arbitrary data -- with live preview that updates in real-time.@@ -97,7 +98,7 @@ , blaze-html , bytestring , commonmark- , commonmark-extensions <0.2.3.3+ , commonmark-extensions >=0.2.3.4 , commonmark-pandoc , commonmark-simple , commonmark-wikilink@@ -106,7 +107,8 @@ , dependent-sum , deriving-aeson , directory- , ema >=0.9+ , ema >=0.10.1+ , feed , filepath , filepattern , fsnotify@@ -128,6 +130,7 @@ , optparse-applicative , pandoc , pandoc-link-context >=1.4.0+ , pandoc-lua-engine , pandoc-types , parsec , path-tree >=0.2@@ -201,6 +204,7 @@ Emanote.View Emanote.View.Common Emanote.View.Export+ Emanote.View.Feed Emanote.View.LiveServerFiles Emanote.View.TagIndex Emanote.View.TaskIndex@@ -223,7 +227,7 @@ build-depends: emanote test-suite test- import: library-common + import: library-common type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs
src/Emanote.hs view
@@ -124,7 +124,7 @@ log "(Tip: use `--allow-broken-links` to ignore this check.)" exitFailure -compileTailwindCss :: MonadUnliftIO m => FilePath -> [FilePath] -> m ()+compileTailwindCss :: (MonadUnliftIO m) => FilePath -> [FilePath] -> m () compileTailwindCss cssPath genPaths = do runStdoutLoggingT $ do log $ "Running Tailwind CSS v3 compiler to generate: " <> toText cssPath
src/Emanote/Model/Graph.hs view
@@ -23,7 +23,7 @@ modelFolgezettelAncestorTree r0 model = fst $ usingState mempty $ go r0 where- go :: MonadState (Set ModelRoute) m => ModelRoute -> m (Forest R.LMLRoute)+ go :: (MonadState (Set ModelRoute) m) => ModelRoute -> m (Forest R.LMLRoute) go r = do let folgezettelBacklinks = backlinkRels r model@@ -36,7 +36,7 @@ -- Folders are automatically made a folgezettel folgezettelFolder = maybeToList $ do- lmlR <- leftToMaybe (R.modelRouteCase r)+ (_, lmlR) <- leftToMaybe (R.modelRouteCase r) guard $ lookupRouteMeta True ("emanote" :| ["folder-folgezettel"]) lmlR model parentLmlRoute model lmlR folgezettelParents =@@ -46,7 +46,7 @@ , folgezettelFolder ] fmap catMaybes . forM folgezettelParents $ \parentR -> do- let parentModelR = R.ModelRoute_LML parentR+ let parentModelR = R.ModelRoute_LML R.LMLView_Html parentR gets (parentModelR `Set.member`) >>= \case True -> pure Nothing False -> do@@ -64,7 +64,7 @@ _ -> Nothing lookupWikiLink :: WL.WikiLink -> Maybe R.LMLRoute lookupWikiLink wl = do- note <- leftToMaybe <=< getFound $ Resolve.resolveWikiLinkMustExist model wl+ (_, note) <- leftToMaybe <=< getFound $ Resolve.resolveWikiLinkMustExist model wl pure $ note ^. MN.noteRoute getFound :: Rel.ResolvedRelTarget a -> Maybe a getFound = \case@@ -94,7 +94,7 @@ backlinkRels r model <&> \rel -> (rel ^. Rel.relFrom, rel ^. Rel.relCtx) where- groupNE :: forall a b. Ord a => [(a, b)] -> [(a, NonEmpty b)]+ groupNE :: forall a b. (Ord a) => [(a, b)] -> [(a, NonEmpty b)] groupNE = Map.toList . foldl' f Map.empty where@@ -112,5 +112,5 @@ frontlinkRels :: ModelRoute -> Model -> [Rel.Rel] frontlinkRels r model = maybeToMonoid $ do- lmlR <- leftToMaybe $ R.modelRouteCase r+ (_, lmlR) <- leftToMaybe $ R.modelRouteCase r pure $ Ix.toList $ (model ^. modelRels) @= lmlR
src/Emanote/Model/Link/Rel.hs view
@@ -77,7 +77,7 @@ unresolvedRelsTo :: ModelRoute -> [UnresolvedRelTarget] unresolvedRelsTo r = let allowedWikiLinks = WL.allowedWikiLinks . R.unRoute- wls = either (R.withLmlRoute allowedWikiLinks) allowedWikiLinks $ R.modelRouteCase r+ wls = either (\(_, r') -> R.withLmlRoute allowedWikiLinks r') allowedWikiLinks $ R.modelRouteCase r in (URTWikiLink <$> toList wls) <> [URTResource r]
src/Emanote/Model/Link/Resolve.hs view
@@ -27,12 +27,12 @@ virtualRoute resolveWikiLinkMustExist ::- Model -> WL.WikiLink -> Rel.ResolvedRelTarget (Either MN.Note SF.StaticFile)+ Model -> WL.WikiLink -> Rel.ResolvedRelTarget (Either (R.LMLView, MN.Note) SF.StaticFile) resolveWikiLinkMustExist model wl = Rel.resolvedRelTargetFromCandidates $ M.modelWikiLinkTargets wl model resolveModelRoute ::- Model -> R.ModelRoute -> Rel.ResolvedRelTarget (Either MN.Note SF.StaticFile)+ Model -> R.ModelRoute -> Rel.ResolvedRelTarget (Either (R.LMLView, MN.Note) SF.StaticFile) resolveModelRoute model lr = bitraverse (`M.modelLookupNoteByRoute` model)@@ -40,6 +40,6 @@ (R.modelRouteCase lr) & maybe Rel.RRTMissing Rel.RRTFound -resourceSiteRoute :: Either MN.Note SF.StaticFile -> SR.SiteRoute+resourceSiteRoute :: Either (R.LMLView, MN.Note) SF.StaticFile -> SR.SiteRoute resourceSiteRoute = either SR.noteFileSiteRoute SR.staticFileSiteRoute
src/Emanote/Model/Meta.hs view
@@ -7,7 +7,7 @@ import Data.Aeson (FromJSON) import Data.Aeson qualified as Aeson import Data.IxSet.Typed qualified as Ix-import Emanote.Model (ModelT, modelLookupNoteByRoute, modelSData)+import Emanote.Model (ModelT, modelLookupNoteByRoute', modelSData) import Emanote.Model.Note (_noteMeta) import Emanote.Model.SData (sdataValue) import Emanote.Model.SData qualified as SData@@ -16,7 +16,7 @@ import Relude -- | Look up a specific key in the meta for a given route.-lookupRouteMeta :: FromJSON a => a -> NonEmpty Text -> R.LMLRoute -> ModelT f -> a+lookupRouteMeta :: (FromJSON a) => a -> NonEmpty Text -> R.LMLRoute -> ModelT f -> a lookupRouteMeta x k r = SData.lookupAeson x k . getEffectiveRouteMeta r @@ -25,12 +25,12 @@ -} getEffectiveRouteMeta :: R.LMLRoute -> ModelT f -> Aeson.Value getEffectiveRouteMeta mr model =- let mNote = modelLookupNoteByRoute mr model+ let mNote = modelLookupNoteByRoute' mr model in getEffectiveRouteMetaWith (maybe Aeson.Null _noteMeta mNote) mr model getEffectiveRouteMetaWith :: Aeson.Value -> R.LMLRoute -> ModelT f -> Aeson.Value getEffectiveRouteMetaWith frontmatter mr model =- let defaultFiles = R.routeInits @('R.Yaml) (R.withLmlRoute coerce mr)+ let defaultFiles = R.routeInits @'R.Yaml (R.withLmlRoute coerce mr) defaults = flip mapMaybe (toList defaultFiles) $ \r -> do v <- getYamlMeta r model guard $ v /= Aeson.Null
src/Emanote/Model/Note.hs view
@@ -19,10 +19,12 @@ import Emanote.Model.Note.Filter (applyPandocFilters) import Emanote.Model.SData qualified as SData import Emanote.Model.Title qualified as Tit+import Emanote.Pandoc.BuiltinFilters (preparePandoc) import Emanote.Pandoc.Markdown.Parser qualified as Markdown import Emanote.Pandoc.Markdown.Syntax.HashTag qualified as HT-import Emanote.Route (FileType (Folder), R) import Emanote.Route qualified as R+import Emanote.Route.Ext (FileType (Folder))+import Emanote.Route.R (R) import Network.URI.Slug (Slug) import Optics.Core ((%), (.~)) import Optics.TH (makeLenses)@@ -32,14 +34,24 @@ import Text.Pandoc.Builder qualified as B import Text.Pandoc.Definition (Pandoc (..)) import Text.Pandoc.Readers.Org (readOrg)+import Text.Pandoc.Scripting (ScriptingEngine) import Text.Pandoc.Walk qualified as W +data Feed = Feed+ { _feedEnable :: Bool+ , _feedTitle :: Maybe Text+ , _feedLimit :: Maybe Word+ }+ deriving stock (Eq, Ord, Show, Generic)+ deriving anyclass (Aeson.ToJSON, Aeson.FromJSON)+ data Note = Note { _noteRoute :: R.LMLRoute , _noteDoc :: Pandoc , _noteMeta :: Aeson.Value , _noteTitle :: Tit.Title , _noteErrors :: [Text]+ , _noteFeed :: Maybe Feed } deriving stock (Eq, Ord, Show, Generic) deriving anyclass (Aeson.ToJSON)@@ -55,6 +67,8 @@ WL.WikiLink , -- HTML route for this note R 'R.Html+ , -- XML route for this note+ R 'R.Xml , -- Ancestor folder routes RAncestor , -- Parent folder@@ -73,6 +87,7 @@ (ixFun $ one . _noteRoute) (ixFun $ toList . noteSelfRefs) (ixFun $ one . noteHtmlRoute)+ (ixFun $ maybeToList . noteXmlRoute) (ixFun noteAncestors) (ixFun $ maybeToList . noteParent) (ixFun noteTags)@@ -107,12 +122,23 @@ noteSlug :: Note -> Maybe (NonEmpty Slug) noteSlug note = do slugPath :: Text <- lookupMeta (one "slug") note- fmap R.unRoute $ R.mkRouteFromFilePath @_ @('R.AnyExt) $ toString slugPath+ fmap R.unRoute $ R.mkRouteFromFilePath @_ @'R.AnyExt $ toString slugPath -lookupMeta :: Aeson.FromJSON a => NonEmpty Text -> Note -> Maybe a+lookupMeta :: (Aeson.FromJSON a) => NonEmpty Text -> Note -> Maybe a lookupMeta k = SData.lookupAeson Nothing k . _noteMeta +noteHasFeed :: Note -> Bool+noteHasFeed = maybe False _feedEnable . _noteFeed++queryNoteFeed :: Aeson.Value -> Maybe Feed+queryNoteFeed meta = do+ feed <- SData.lookupAeson Nothing (one "feed") meta+ let title = SData.lookupAeson Nothing (one "title") feed+ let enable = SData.lookupAeson False (one "enable") feed+ let feedLimit = SData.lookupAeson Nothing (one "limit") feed+ pure $ Feed enable title feedLimit+ queryNoteTitle :: R.LMLRoute -> Pandoc -> Aeson.Value -> (Pandoc, Tit.Title) queryNoteTitle r doc meta = let yamlNoteTitle = fromString <$> SData.lookupAeson Nothing (one "title") meta@@ -145,6 +171,12 @@ withoutH1 x = x +-- | The xml route intended by user for this note.+noteXmlRoute :: Note -> Maybe (R 'R.Xml)+noteXmlRoute note+ | noteHasFeed note = Just (coerce $ noteHtmlRoute note)+ | otherwise = Nothing+ -- | The HTML route intended by user for this note. noteHtmlRoute :: Note -> R 'R.Html noteHtmlRoute note@Note {..} =@@ -159,7 +191,11 @@ lookupNotesByHtmlRoute htmlRoute = Ix.toList . Ix.getEQ htmlRoute -lookupNotesByRoute :: HasCallStack => R.LMLRoute -> IxNote -> Maybe Note+lookupNotesByXmlRoute :: R 'R.Xml -> IxNote -> [Note]+lookupNotesByXmlRoute xmlRoute =+ Ix.toList . Ix.getEQ xmlRoute++lookupNotesByRoute :: (HasCallStack) => R.LMLRoute -> IxNote -> Maybe Note lookupNotesByRoute r ix = do res <- nonEmpty $ Ix.toList $ Ix.getEQ r ix case res of@@ -239,8 +275,9 @@ mkNoteWith :: R.LMLRoute -> Pandoc -> Aeson.Value -> [Text] -> Note mkNoteWith r doc' meta errs = let (doc'', tit) = queryNoteTitle r doc' meta+ feed = queryNoteFeed meta doc = if null errs then doc'' else pandocPrepend (errorDiv errs) doc''- in Note r doc meta tit errs+ in Note r doc meta tit errs feed where -- Prepend to block to the beginning of a Pandoc document (never before H1) pandocPrepend :: B.Block -> Pandoc -> Pandoc@@ -257,16 +294,17 @@ parseNote :: forall m. (MonadIO m, MonadLogger m) =>+ ScriptingEngine -> FilePath -> R.LMLRoute -> FilePath -> Text -> m Note-parseNote pluginBaseDir r fp s = do+parseNote scriptingEngine pluginBaseDir r fp s = do ((doc, meta), errs) <- runWriterT $ do case r of R.LMLRoute_Md _ ->- parseNoteMarkdown pluginBaseDir fp s+ parseNoteMarkdown scriptingEngine pluginBaseDir fp s R.LMLRoute_Org _ -> do parseNoteOrg s pure $ mkNoteWith r doc meta errs@@ -279,10 +317,10 @@ pure (mempty, defaultFrontMatter) Right doc -> -- TODO: Merge Pandoc's Meta in here?- pure (doc, defaultFrontMatter)+ pure (preparePandoc doc, defaultFrontMatter) -parseNoteMarkdown :: (MonadIO m, MonadLogger m) => FilePath -> FilePath -> Text -> WriterT [Text] m (Pandoc, Aeson.Value)-parseNoteMarkdown pluginBaseDir fp md = do+parseNoteMarkdown :: (MonadIO m, MonadLogger m) => ScriptingEngine -> FilePath -> FilePath -> Text -> WriterT [Text] m (Pandoc, Aeson.Value)+parseNoteMarkdown scriptingEngine pluginBaseDir fp md = do case Markdown.parseMarkdown fp md of Left err -> do tell [err]@@ -293,7 +331,7 @@ -- Some are user-defined; some builtin. They operate on Pandoc, or the -- frontmatter meta. let filterPaths = (pluginBaseDir </>) <$> SData.lookupAeson @[FilePath] mempty ("pandoc" :| ["filters"]) frontmatter- doc <- applyPandocFilters filterPaths doc'+ doc <- applyPandocFilters scriptingEngine filterPaths $ preparePandoc doc' let meta = applyNoteMetaFilters doc frontmatter pure (doc, meta) where
src/Emanote/Model/Note/Filter.hs view
@@ -10,10 +10,11 @@ import Text.Pandoc (runIO) import Text.Pandoc.Definition (Pandoc (..)) import Text.Pandoc.Filter qualified as PF+import Text.Pandoc.Scripting (ScriptingEngine) import UnliftIO.Exception (handle) -applyPandocFilters :: (MonadIO m, MonadLogger m, MonadWriter [Text] m) => [FilePath] -> Pandoc -> m Pandoc-applyPandocFilters paths doc = do+applyPandocFilters :: (MonadIO m, MonadLogger m, MonadWriter [Text] m) => ScriptingEngine -> [FilePath] -> Pandoc -> m Pandoc+applyPandocFilters scriptingEngine paths doc = do res <- traverse mkLuaFilter paths forM_ (lefts res) $ \err -> tell [err]@@ -21,11 +22,11 @@ [] -> pure doc filters ->- applyPandocLuaFilters filters doc >>= \case+ applyPandocLuaFilters scriptingEngine filters doc >>= \case Left err -> tell [err] >> pure doc Right x -> pure x -mkLuaFilter :: MonadIO m => FilePath -> m (Either Text PF.Filter)+mkLuaFilter :: (MonadIO m) => FilePath -> m (Either Text PF.Filter) mkLuaFilter relPath = do if takeExtension relPath == ".lua" then do@@ -34,11 +35,11 @@ False -> pure $ Left $ toText $ "Lua filter missing: " <> relPath else pure $ Left $ "Unsupported filter: " <> toText relPath -applyPandocLuaFilters :: (MonadIO m, MonadLogger m) => [PF.Filter] -> Pandoc -> m (Either Text Pandoc)-applyPandocLuaFilters filters x = do+applyPandocLuaFilters :: (MonadIO m, MonadLogger m) => ScriptingEngine -> [PF.Filter] -> Pandoc -> m (Either Text Pandoc)+applyPandocLuaFilters scriptingEngine filters x = do logW $ "[Experimental feature] Applying pandoc filters: " <> show filters -- TODO: Can we constrain this to run Lua code purely (embedded) without using IO?- liftIO (runIOCatchingErrors $ PF.applyFilters def filters ["markdown"] x) >>= \case+ liftIO (runIOCatchingErrors $ PF.applyFilters scriptingEngine def filters ["markdown"] x) >>= \case Left err -> do logE $ "Error applying pandoc filters: " <> show err pure $ Left (show err)
src/Emanote/Model/SData.hs view
@@ -52,7 +52,7 @@ mergeAeson = AesonMerge.lodashMerge -- TODO: Use https://hackage.haskell.org/package/lens-aeson-lookupAeson :: forall a. Aeson.FromJSON a => a -> NonEmpty Text -> Aeson.Value -> a+lookupAeson :: forall a. (Aeson.FromJSON a) => a -> NonEmpty Text -> Aeson.Value -> a lookupAeson x (k :| ks) meta = fromMaybe x $ do Aeson.Object obj <- pure meta
src/Emanote/Model/StaticFile.hs view
@@ -6,16 +6,20 @@ import Commonmark.Extensions.WikiLink qualified as WL import Data.Aeson qualified as Aeson import Data.IxSet.Typed (Indexable (..), IxSet, ixFun, ixList)+import Data.Map.Strict qualified as Map import Data.Time (UTCTime) import Emanote.Route qualified as R import Optics.TH (makeLenses) import Relude+import System.FilePath (takeExtension) data StaticFile = StaticFile { _staticFileRoute :: R.R 'R.AnyExt , _staticFilePath :: FilePath , _staticFileTime :: UTCTime -- ^ Indicates that this file was updated no latter than the given time.+ , _staticFileInfo :: Maybe StaticFileInfo+ -- ^ This file might have its content read } deriving stock (Eq, Ord, Show, Generic) deriving anyclass (Aeson.ToJSON)@@ -36,5 +40,77 @@ . WL.allowedWikiLinks . R.unRoute . _staticFileRoute++data StaticFileInfo where+ StaticFileInfoImage :: StaticFileInfo+ StaticFileInfoAudio :: StaticFileInfo+ StaticFileInfoVideo :: StaticFileInfo+ StaticFileInfoPDF :: StaticFileInfo+ StaticFileInfoCode ::+ -- | File code language name+ CodeLanguage ->+ -- | File content+ Text ->+ StaticFileInfo+ deriving stock (Eq, Show, Ord, Generic)+ deriving anyclass (Aeson.ToJSON)++newtype CodeLanguage = CodeLanguage Text+ deriving stock (Eq, Show, Ord, Generic)+ deriving anyclass (Aeson.ToJSON)++-- | Return the ${name} in the corresponding templates/filters/embed-${name}.tpl+staticFileInfoTemplateName :: (IsString s) => StaticFileInfo -> s+staticFileInfoTemplateName = \case+ StaticFileInfoImage -> "image"+ StaticFileInfoAudio -> "audio"+ StaticFileInfoVideo -> "video"+ StaticFileInfoPDF -> "pdf"+ StaticFileInfoCode _ _ -> "code"++readStaticFileInfo ::+ (Monad m) =>+ FilePath ->+ (FilePath -> m Text) ->+ m (Maybe StaticFileInfo)+readStaticFileInfo fp readFilePath = do+ let extension = toText (takeExtension fp)+ if+ | extension `elem` imageExts ->+ pure $ Just StaticFileInfoImage+ | extension `elem` videoExts ->+ pure $ Just StaticFileInfoVideo+ | extension `elem` audioExts ->+ pure $ Just StaticFileInfoAudio+ | extension == ".pdf" ->+ pure $ Just StaticFileInfoPDF+ | Just lang <- Map.lookup extension codeExts -> do+ code <- readFilePath fp+ pure $ Just $ StaticFileInfoCode lang code+ | otherwise -> return Nothing+ where+ imageExts = [".jpg", ".jpeg", ".png", ".svg", ".gif", ".bmp", ".webp"]+ videoExts = [".mp4", ".webm", ".ogv"]+ audioExts = [".aac", ".caf", ".flac", ".mp3", ".ogg", ".wav", ".wave"]+ codeExts =+ CodeLanguage+ <$> Map.fromList+ [ (".hs", "haskell")+ , (".nix", "nix")+ , (".sh", "bash")+ , (".py", "python")+ , (".js", "javascript")+ , (".java", "java")+ , (".c", "c")+ , (".cpp", "cpp")+ , (".cs", "cs")+ , (".rb", "ruby")+ , (".go", "go")+ , (".swift", "swift")+ , (".kt", "kotlin")+ , (".rs", "rust")+ , (".ts", "typescript")+ , (".php", "php")+ ] makeLenses ''StaticFile
src/Emanote/Model/Stork.hs view
@@ -10,6 +10,7 @@ import Emanote.Model.Stork.Index ( Config (Config), File (File),+ FileType (FileType_Markdown, FileType_PlainText), Handling, Input (Input), readOrBuildStorkIndex,@@ -33,10 +34,15 @@ storkFiles model = let baseDir = Loc.locPath . Loc.primaryLayer $ model ^. M.modelLayers in Ix.toList (model ^. M.modelNotes) <&> \note ->- File- ((baseDir </>) $ R.withLmlRoute R.encodeRoute $ note ^. N.noteRoute)- (SR.siteRouteUrl model $ SR.lmlSiteRoute $ note ^. N.noteRoute)- (Tit.toPlain $ note ^. N.noteTitle)+ let fp = ((baseDir </>) $ R.withLmlRoute R.encodeRoute $ note ^. N.noteRoute)+ ft = case note ^. N.noteRoute of+ R.LMLRoute_Md _ -> FileType_Markdown+ R.LMLRoute_Org _ -> FileType_PlainText+ in File+ fp+ (SR.siteRouteUrl model $ SR.lmlSiteRoute (R.LMLView_Html, note ^. N.noteRoute))+ (Tit.toPlain $ note ^. N.noteTitle)+ ft frontmatterHandling :: Model -> Handling frontmatterHandling model =
src/Emanote/Model/Stork/Index.hs view
@@ -10,6 +10,7 @@ Input (Input), Config (Config), Handling,+ FileType (..), ) where import Control.Monad.Logger (MonadLoggerIO)@@ -27,7 +28,7 @@ -- | In-memory Stork index tracked in a @TVar@ newtype IndexVar = IndexVar (TVar (Maybe LByteString)) -newIndex :: MonadIO m => m IndexVar+newIndex :: (MonadIO m) => m IndexVar newIndex = IndexVar <$> newTVarIO mempty @@ -49,7 +50,7 @@ atomically $ modifyTVar' indexVar $ \_ -> Just index pure index where- timeIt :: MonadIO m => m b -> m (Double, b)+ timeIt :: (MonadIO m) => m b -> m (Double, b) timeIt m = do t0 <- liftIO getCurrentTime !x <- m@@ -60,7 +61,7 @@ storkBin :: FilePath storkBin = $(staticWhich "stork") -runStork :: MonadIO m => Config -> m LByteString+runStork :: (MonadIO m) => Config -> m LByteString runStork config = do let storkToml = handleTomlandBug $ Toml.encode configCodec config (_, !index, _) <-@@ -97,9 +98,21 @@ { filePath :: FilePath , fileUrl :: Text , fileTitle :: Text+ , fileFiletype :: FileType } deriving stock (Eq, Show) +data FileType+ = FileType_PlainText+ | FileType_Markdown+ deriving stock (Eq, Show, Generic)+ deriving+ (FromJSON)+ via CustomJSON+ '[ ConstructorTagModifier '[StripPrefix "FileType_", CamelToSnake]+ ]+ FileType+ data Handling = Handling_Ignore | Handling_Omit@@ -137,6 +150,8 @@ .= fileUrl <*> Toml.text "title" .= fileTitle+ <*> Toml.diwrap (filetypeCodec "filetype")+ .= fileFiletype handlingCodec :: Toml.Key -> TomlCodec Handling handlingCodec = textBy showHandling parseHandling where@@ -151,3 +166,15 @@ "Omit" -> Right Handling_Omit "Parse" -> Right Handling_Parse other -> Left $ "Unsupported value for frontmatter handling: " <> other+ filetypeCodec :: Toml.Key -> TomlCodec FileType+ filetypeCodec = textBy showFileType parseFileType+ where+ showFileType :: FileType -> Text+ showFileType filetype = case filetype of+ FileType_PlainText -> "PlainText"+ FileType_Markdown -> "Markdown"+ parseFileType :: Text -> Either Text FileType+ parseFileType filetype = case filetype of+ "PlainText" -> Right FileType_PlainText+ "Markdown" -> Right FileType_Markdown+ other -> Left $ "Unsupported value for filetype: " <> other
src/Emanote/Model/Type.hs view
@@ -21,12 +21,14 @@ import Emanote.Model.Note ( IxNote, Note,+ noteHasFeed, ) import Emanote.Model.Note qualified as N import Emanote.Model.SData (IxSData, SData, sdataRoute) import Emanote.Model.StaticFile ( IxStaticFile, StaticFile (StaticFile),+ StaticFileInfo, ) import Emanote.Model.Stork.Index qualified as Stork import Emanote.Model.Task (IxTask)@@ -214,11 +216,11 @@ r :: R.R 'AnyExt <- R.mkRouteFromFilePath fp Ix.getOne $ Ix.getEQ r $ m ^. modelStaticFiles -modelInsertStaticFile :: UTCTime -> R.R 'AnyExt -> FilePath -> ModelT f -> ModelT f-modelInsertStaticFile t r fp =+modelInsertStaticFile :: UTCTime -> R.R 'AnyExt -> FilePath -> Maybe StaticFileInfo -> ModelT f -> ModelT f+modelInsertStaticFile t r fp mInfo = modelStaticFiles %~ Ix.updateIx r staticFile where- staticFile = StaticFile r fp t+ staticFile = StaticFile r fp t mInfo modelDeleteStaticFile :: R.R 'AnyExt -> ModelT f -> ModelT f modelDeleteStaticFile r =@@ -232,22 +234,43 @@ modelDeleteData k = modelSData %~ Ix.deleteIx k -modelLookupNoteByRoute :: LMLRoute -> ModelT f -> Maybe Note-modelLookupNoteByRoute r (_modelNotes -> notes) =- N.lookupNotesByRoute r notes+modelLookupNoteByRoute :: (R.LMLView, LMLRoute) -> ModelT f -> Maybe (R.LMLView, Note)+modelLookupNoteByRoute (view, r) (_modelNotes -> notes) = do+ note <- N.lookupNotesByRoute r notes+ case (view, noteHasFeed note) of+ (R.LMLView_Atom, True) -> pure (view, note)+ (R.LMLView_Atom, False) -> Nothing+ (_, _) -> pure (view, note) +-- | Like `modelLookupNoteByRoute`, but for `R.Html` routes only.+modelLookupNoteByRoute' :: LMLRoute -> ModelT f -> Maybe Note+modelLookupNoteByRoute' r =+ fmap snd . modelLookupNoteByRoute (R.LMLView_Html, r)+ modelLookupNoteByHtmlRoute :: R 'R.Html -> ModelT f -> Rel.ResolvedRelTarget Note modelLookupNoteByHtmlRoute r = Rel.resolvedRelTargetFromCandidates . N.lookupNotesByHtmlRoute r . _modelNotes +modelLookupFeedNoteByHtmlRoute :: R 'R.Xml -> ModelT f -> Maybe Note+modelLookupFeedNoteByHtmlRoute r model = case resolvedTarget of+ Rel.RRTFound note+ | noteHasFeed note -> pure note+ | otherwise -> Nothing+ _ -> Nothing+ where+ resolvedTarget =+ Rel.resolvedRelTargetFromCandidates $+ N.lookupNotesByXmlRoute r $+ _modelNotes model+ modelLookupTitle :: LMLRoute -> ModelT f -> Tit.Title modelLookupTitle r =- maybe (Tit.fromRoute r) N._noteTitle . modelLookupNoteByRoute r+ maybe (Tit.fromRoute r) N._noteTitle . modelLookupNoteByRoute' r -- Lookup the wiki-link and return its candidates in the model.-modelWikiLinkTargets :: WL.WikiLink -> Model -> [Either Note StaticFile]+modelWikiLinkTargets :: WL.WikiLink -> Model -> [Either (R.LMLView, Note) StaticFile] modelWikiLinkTargets wl model = let notes = Ix.toList $@@ -255,7 +278,7 @@ staticFiles = Ix.toList $ (model ^. modelStaticFiles) @= wl- in fmap Right staticFiles <> fmap Left notes+ in fmap Right staticFiles <> fmap Left ((R.LMLView_Html,) <$> notes) modelLookupStaticFileByRoute :: R 'AnyExt -> ModelT f -> Maybe StaticFile modelLookupStaticFileByRoute r =
src/Emanote/Pandoc/BuiltinFilters.hs view
@@ -1,24 +1,16 @@ module Emanote.Pandoc.BuiltinFilters (- prepareNoteDoc, preparePandoc, ) where -import Emanote.Model.Note qualified as N import Emanote.Pandoc.ExternalLink (setExternalLinkIcon) import Emanote.Pandoc.Markdown.Syntax.HashTag qualified as HT import Emanote.Route (encodeRoute) import Emanote.Route.SiteRoute.Type (encodeTagIndexR)-import Optics.Core ((^.)) import Relude import Text.Pandoc.Definition qualified as B import Text.Pandoc.Walk qualified as W --- TODO: Run this in `parseNote`?-prepareNoteDoc :: N.Note -> B.Pandoc-prepareNoteDoc note =- preparePandoc $ note ^. N.noteDoc--preparePandoc :: W.Walkable B.Inline b => b -> b+preparePandoc :: (W.Walkable B.Inline b) => b -> b preparePandoc = linkifyInlineTags >>> fixEmojiFontFamily@@ -26,7 +18,7 @@ -- HashTag.hs generates a Span for inline tags. -- Here, we must link them to the special tag index page.-linkifyInlineTags :: W.Walkable B.Inline b => b -> b+linkifyInlineTags :: (W.Walkable B.Inline b) => b -> b linkifyInlineTags = W.walk $ \case inline@(B.Span attr is) ->@@ -43,7 +35,7 @@ -- Undo font-family on emoji spans, so the browser uses an emoji font. -- Ref: https://github.com/jgm/commonmark-hs/blob/3d545d7afa6c91820b4eebf3efeeb80bf1b27128/commonmark-extensions/src/Commonmark/Extensions/Emoji.hs#L30-L33-fixEmojiFontFamily :: W.Walkable B.Inline b => b -> b+fixEmojiFontFamily :: (W.Walkable B.Inline b) => b -> b fixEmojiFontFamily = W.walk $ \case B.Span (id', classes, attrs) is
src/Emanote/Pandoc/ExternalLink.hs view
@@ -11,7 +11,7 @@ -- Add a data-linkicon=external attribute to external links that contain some -- text in their description, provided that they do not already have a -- data-linkicon attribute.-setExternalLinkIcon :: W.Walkable B.Inline b => b -> b+setExternalLinkIcon :: (W.Walkable B.Inline b) => b -> b setExternalLinkIcon = W.walk $ \case B.Link (id', classes, attrs) inlines (url, title)@@ -23,7 +23,7 @@ where -- Inserts an element in a key-value list if the element's key is not -- already in the list.- insert :: Eq a => [(a, b)] -> (a, b) -> [(a, b)]+ insert :: (Eq a) => [(a, b)] -> (a, b) -> [(a, b)] insert as a | fst a `elem` (fst <$> as) = as | otherwise = a : as
src/Emanote/Pandoc/Link.hs view
@@ -25,7 +25,7 @@ {- | Given an inline that is known to be an InlineRef, reconstruct and return its orginal Markdown source. -}-unParseLink :: HasCallStack => B.Inline -> Text+unParseLink :: (HasCallStack) => B.Inline -> Text unParseLink inl = case WL.wikiLinkInlineRendered inl of Just url ->
src/Emanote/Pandoc/Markdown/Syntax/HashTag.hs view
@@ -70,7 +70,7 @@ _ <- symbol '#' tag <- CM.untokenize <$> tagP pure $ hashTag $ TT.Tag tag- tagP :: Monad m => P.ParsecT [CM.Tok] s m [CM.Tok]+ tagP :: (Monad m) => P.ParsecT [CM.Tok] s m [CM.Tok] tagP = do s <- some (noneOfToks disallowed) -- A tag cannot end with a slash (which is a separator in hierarchical tags)
src/Emanote/Pandoc/Renderer/Embed.hs view
@@ -2,14 +2,13 @@ import Commonmark.Extensions.WikiLink qualified as WL import Data.Map.Syntax ((##))-import Data.Text qualified as T import Emanote.Model (Model) import Emanote.Model.Link.Rel qualified as Rel import Emanote.Model.Link.Resolve qualified as Resolve import Emanote.Model.Note qualified as MN+import Emanote.Model.StaticFile (CodeLanguage (..), StaticFileInfo (..), staticFileInfoTemplateName) import Emanote.Model.StaticFile qualified as SF import Emanote.Model.Title qualified as Tit-import Emanote.Pandoc.BuiltinFilters (prepareNoteDoc, preparePandoc) import Emanote.Pandoc.Link qualified as Link import Emanote.Pandoc.Renderer (PandocBlockRenderer, PandocInlineRenderer) import Emanote.Pandoc.Renderer.Url qualified as RenderedUrl@@ -36,8 +35,12 @@ (Rel.URTWikiLink (WL.WikiLinkEmbed, wl), _mAnchor) <- Rel.parseUnresolvedRelTarget parentR (otherAttrs <> one ("title", tit)) url let rRel = Resolve.resolveWikiLinkMustExist model wl- RenderedUrl.renderSomeInlineRefWith Resolve.resourceSiteRoute (is, (url, tit)) rRel model ctx inl $- either (embedResourceRoute model ctx) (const Nothing)+ RenderedUrl.renderSomeInlineRefWith Resolve.resourceSiteRoute (is, (url, tit)) rRel model ctx inl $ \case+ Left (R.LMLView_Html, r) -> embedResourceRoute model ctx r+ Right sf+ | isJust (SF._staticFileInfo sf) ->+ embedStaticFileRoute model (toText $ SF._staticFilePath sf) sf+ _ -> Nothing embedBlockRegularLinkResolvingSplice :: PandocBlockRenderer Model R.LMLRoute embedBlockRegularLinkResolvingSplice model _nf ctx noteRoute node = do@@ -69,42 +72,27 @@ embedResourceRoute :: Model -> HP.RenderCtx -> MN.Note -> Maybe (HI.Splice Identity) embedResourceRoute model ctx note = do pure . runEmbedTemplate "note" $ do- "ema:note:title" ## Tit.titleSplice ctx preparePandoc (MN._noteTitle note)- "ema:note:url" ## HI.textSplice (SR.siteRouteUrl model $ SR.lmlSiteRoute $ note ^. MN.noteRoute)+ "ema:note:title" ## Tit.titleSplice ctx id (MN._noteTitle note)+ "ema:note:url" ## HI.textSplice (SR.siteRouteUrl model $ SR.lmlSiteRoute (R.LMLView_Html, note ^. MN.noteRoute)) "ema:note:pandoc" ##- pandocSplice ctx (prepareNoteDoc note)+ pandocSplice ctx (note ^. MN.noteDoc) embedStaticFileRoute :: Model -> Text -> SF.StaticFile -> Maybe (HI.Splice Identity) embedStaticFileRoute model altText staticFile = do- let fp = staticFile ^. SF.staticFilePath- url = SF.siteRouteUrl model $ SF.staticFileSiteRoute staticFile- if- | any (`T.isSuffixOf` toText fp) imageExts ->- pure . runEmbedTemplate "image" $ do- "ema:url" ## HI.textSplice url- "ema:alt" ## HI.textSplice altText- | any (`T.isSuffixOf` toText fp) videoExts -> do- pure . runEmbedTemplate "video" $ do- "ema:url" ## HI.textSplice url- | ".pdf" `T.isSuffixOf` toText fp -> do- pure . runEmbedTemplate "pdf" $ do- "ema:url" ## HI.textSplice url- | otherwise -> Nothing--imageExts :: [Text]-imageExts =- [ ".jpg"- , ".jpeg"- , ".png"- , ".svg"- , ".gif"- , ".bmp"- , ".webp"- ]--videoExts :: [Text]-videoExts =- [ ".mp4"- , ".webm"- , ".ogv"- ]+ let url = SF.siteRouteUrl model $ SF.staticFileSiteRoute staticFile+ staticFileInfo <- SF._staticFileInfo staticFile+ pure . runEmbedTemplate (staticFileInfoTemplateName staticFileInfo) $ do+ case staticFileInfo of+ StaticFileInfoImage -> do+ "ema:url" ## HI.textSplice url+ "ema:alt" ## HI.textSplice altText+ StaticFileInfoVideo ->+ "ema:url" ## HI.textSplice url+ StaticFileInfoAudio ->+ "ema:url" ## HI.textSplice url+ StaticFileInfoPDF ->+ "ema:url" ## HI.textSplice url+ StaticFileInfoCode (CodeLanguage language) content -> do+ "ema:code:content" ## HI.textSplice content+ "ema:code:language" ## HI.textSplice language+ "ema:alt" ## HI.textSplice altText
src/Emanote/Pandoc/Renderer/Query.hs view
@@ -10,9 +10,8 @@ import Emanote.Model.Note qualified as MN import Emanote.Model.Query qualified as Q import Emanote.Model.Title qualified as Tit-import Emanote.Pandoc.BuiltinFilters (preparePandoc) import Emanote.Pandoc.Renderer (PandocBlockRenderer)-import Emanote.Route (LMLRoute)+import Emanote.Route (LMLRoute, LMLView (LMLView_Html)) import Emanote.Route.SiteRoute qualified as SR import Heist qualified as H import Heist.Extra qualified as HE@@ -38,7 +37,8 @@ "query" ## HI.textSplice (show q) "result" ##- (HI.runChildrenWith . noteSpliceMap ($ ctx) model) `foldMapM` Q.runQuery noteRoute model q+ (HI.runChildrenWith . noteSpliceMap ($ ctx) model)+ `foldMapM` Q.runQuery noteRoute model q -- TODO: Reuse this elsewhere noteSpliceMap ::@@ -47,6 +47,6 @@ MN.Note -> H.Splices (HI.Splice Identity) noteSpliceMap withCtx model note = do- "ema:note:title" ## withCtx $ \ctx -> Tit.titleSplice ctx preparePandoc (MN._noteTitle note)- "ema:note:url" ## HI.textSplice (SR.siteRouteUrl model $ SR.lmlSiteRoute $ note ^. MN.noteRoute)+ "ema:note:title" ## withCtx $ \ctx -> Tit.titleSplice ctx id (MN._noteTitle note)+ "ema:note:url" ## HI.textSplice (SR.siteRouteUrl model $ SR.lmlSiteRoute (LMLView_Html, note ^. MN.noteRoute)) "ema:note:metadata" ## HJ.bindJson (note ^. MN.noteMeta)
src/Emanote/Pandoc/Renderer/Url.hs view
@@ -126,7 +126,7 @@ x -> x replaceLinkNodeWithRoute ::- HasCallStack =>+ (HasCallStack) => Model -> SR.SiteRoute -> ([B.Inline], Text) ->@@ -158,8 +158,9 @@ SR.SiteRoute_VirtualRoute _ -> Nothing SR.SiteRoute_ResourceRoute resR -> case resR of- SR.ResourceRoute_LML lmlR ->- Tit.toInlines . MN._noteTitle <$> M.modelLookupNoteByRoute lmlR model+ SR.ResourceRoute_LML R.LMLView_Html lmlR ->+ Tit.toInlines . MN._noteTitle <$> M.modelLookupNoteByRoute' lmlR model+ SR.ResourceRoute_LML R.LMLView_Atom _ -> Nothing SR.ResourceRoute_StaticFile _ _ -> -- Just append a file: prefix, to existing wiki-link. pure $ B.Str "File:" : [B.Str url]
src/Emanote/Prelude.hs view
@@ -9,7 +9,7 @@ import Relude -- | Monadic version of `chain`-chainM :: Monad m => (b -> m (a -> a)) -> [b] -> m (a -> a)+chainM :: (Monad m) => (b -> m (a -> a)) -> [b] -> m (a -> a) chainM f = fmap chain . mapM f where@@ -28,14 +28,14 @@ -- Logging -------------- -log :: MonadLogger m => Text -> m ()+log :: (MonadLogger m) => Text -> m () log = logInfoNS "emanote" -logD :: MonadLogger m => Text -> m ()+logD :: (MonadLogger m) => Text -> m () logD = logDebugNS "emanote" -logE :: MonadLogger m => Text -> m ()+logE :: (MonadLogger m) => Text -> m () logE = logErrorNS "emanote" -logW :: MonadLogger m => Text -> m ()+logW :: (MonadLogger m) => Text -> m () logW = logWarnNS "emanote"
src/Emanote/Route/Ext.hs view
@@ -15,6 +15,7 @@ data FileType a where LMLType :: LML -> FileType SourceExt Yaml :: FileType SourceExt+ Xml :: FileType () HeistTpl :: FileType SourceExt -- | `AnyExt` has no *known* (at compile time) extension. It is used as a -- "catch all" type to capture files using an arbitrary.@@ -23,9 +24,9 @@ Folder :: FileType () deriving stock (Typeable) -deriving stock instance Eq a => Eq (FileType a)+deriving stock instance (Eq a) => Eq (FileType a) -deriving stock instance Ord a => Ord (FileType a)+deriving stock instance (Ord a) => Ord (FileType a) {- | A lightweight markup language @@ -69,6 +70,11 @@ fileType = Html withExt = flip FP.addExtension ".html" withoutKnownExt = fpWithoutExt ".html"++instance HasExt 'Xml where+ fileType = Xml+ withExt = flip FP.addExtension ".xml"+ withoutKnownExt = fpWithoutExt ".xml" instance HasExt 'HeistTpl where fileType = HeistTpl
src/Emanote/Route/ModelRoute.hs view
@@ -10,6 +10,7 @@ modelRouteCase, mkModelRouteFromFilePath, -- Only LML routes+ LMLView (..), LMLRoute (..), defaultLmlRoute, possibleLmlRoutes,@@ -23,17 +24,21 @@ ) where import Data.Aeson.Types (ToJSON)-import Emanote.Route.Ext (FileType (AnyExt, LMLType), HasExt, LML (Md, Org))+import Emanote.Route.Ext (FileType (AnyExt, LMLType, Xml), HasExt, LML (Md, Org)) import Emanote.Route.R (R) import Emanote.Route.R qualified as R import Relude type StaticFileRoute = R 'AnyExt +data LMLView = LMLView_Html | LMLView_Atom+ deriving stock (Eq, Show, Ord, Generic)+ deriving anyclass (ToJSON)+ -- | A R to anywhere in `Model` data ModelRoute = ModelRoute_StaticFile StaticFileRoute- | ModelRoute_LML LMLRoute+ | ModelRoute_LML LMLView LMLRoute deriving stock (Eq, Show, Ord, Generic) deriving anyclass (ToJSON) @@ -66,25 +71,32 @@ LMLRoute_Md _ -> True _ -> False -withLmlRoute :: (forall lmlType. HasExt ('LMLType lmlType) => R ('LMLType lmlType) -> r) -> LMLRoute -> r+withLmlRoute :: (forall lmlType. (HasExt ('LMLType lmlType)) => R ('LMLType lmlType) -> r) -> LMLRoute -> r withLmlRoute f = either f f . lmlRouteCase modelRouteCase :: ModelRoute ->- Either LMLRoute StaticFileRoute+ Either (LMLView, LMLRoute) StaticFileRoute modelRouteCase = \case- ModelRoute_LML r -> Left r+ ModelRoute_LML view r -> Left (view, r) ModelRoute_StaticFile r -> Right r mkModelRouteFromFilePath :: FilePath -> Maybe ModelRoute mkModelRouteFromFilePath fp =- fmap ModelRoute_LML (mkLMLRouteFromFilePath fp)+ fmap (uncurry ModelRoute_LML) (mkLMLRouteFromFilePath fp) <|> fmap ModelRoute_StaticFile (R.mkRouteFromFilePath fp) -mkLMLRouteFromFilePath :: FilePath -> Maybe LMLRoute+mkLMLRouteFromFilePath :: FilePath -> Maybe (LMLView, LMLRoute) mkLMLRouteFromFilePath fp =- mkLMLRouteFromKnownFilePath Md fp- <|> mkLMLRouteFromKnownFilePath Org fp+ fmap+ (LMLView_Html,)+ ( mkLMLRouteFromKnownFilePath Md fp+ <|> mkLMLRouteFromKnownFilePath Org fp+ )+ <|> ( do+ xmlR <- R.mkRouteFromFilePath @_ @'Xml fp+ pure (LMLView_Atom, LMLRoute_Md $ coerce xmlR)+ ) {- | Like `mkLMLRouteFromFilePath`, but when the file extension is known ahead to be of `lmlType`.
src/Emanote/Route/R.hs view
@@ -17,16 +17,16 @@ newtype R (ext :: FileType a) = R {unRoute :: NonEmpty Slug} deriving stock (Eq, Ord, Typeable, Data) -instance HasExt ext => ToJSON (R ext) where+instance (HasExt ext) => ToJSON (R ext) where toJSON = toJSON . encodeRoute -instance HasExt ext => Show (R ext) where+instance (HasExt ext) => Show (R ext) where show r = toString $ "R[/" <> encodeRoute r <> "]" -- | Convert foo/bar.<ext> to a @R@-mkRouteFromFilePath :: forall a (ext :: FileType a). HasExt ext => FilePath -> Maybe (R ext)+mkRouteFromFilePath :: forall a (ext :: FileType a). (HasExt ext) => FilePath -> Maybe (R ext) mkRouteFromFilePath fp = do base <- withoutKnownExt @_ @ext fp let slugs = fromString . toString . T.dropWhileEnd (== '/') . toText <$> splitPath base@@ -83,11 +83,19 @@ indexRoute = R $ "index" :| [] -- | Convert a route to filepath-encodeRoute :: forall a (ft :: FileType a). HasExt ft => R ft -> FilePath+encodeRoute :: forall a (ft :: FileType a). (HasExt ft) => R ft -> FilePath encodeRoute (R slugs) = let parts = Slug.unSlug <$> slugs in withExt @a @ft $ toString $ T.intercalate "/" (toList parts) +decodeXmlRoute :: FilePath -> Maybe (R 'Xml)+decodeXmlRoute fp = case T.stripSuffix ".xml" (toText fp) of+ Nothing -> Nothing+ Just base -> case T.splitOn "/" base of+ [] -> Nothing+ [""] -> Nothing+ x : xs -> Just $ R $ fmap Slug.decodeSlug (x :| xs)+ -- | Parse our route from html file path decodeHtmlRoute :: FilePath -> R 'Html decodeHtmlRoute fp = do@@ -107,4 +115,4 @@ decodeAnyRoute :: FilePath -> Maybe (R 'AnyExt) decodeAnyRoute =- mkRouteFromFilePath @_ @('AnyExt)+ mkRouteFromFilePath @_ @'AnyExt
src/Emanote/Route/SiteRoute/Class.hs view
@@ -1,6 +1,8 @@ module Emanote.Route.SiteRoute.Class ( decodeVirtualRoute, noteFileSiteRoute,+ noteFileSiteRoute',+ noteFeedSiteRoute, staticFileSiteRoute, lmlSiteRoute, indexRoute,@@ -40,7 +42,12 @@ let htmlRoutes = model ^. M.modelNotes & Ix.toList- <&> noteFileSiteRoute+ <&> noteFileSiteRoute'+ feedRoutes =+ model ^. M.modelNotes+ & Ix.toList+ & filter N.noteHasFeed+ <&> noteFeedSiteRoute staticRoutes = let includeFile f = not (LiveServerFile.isLiveServerFile f)@@ -63,10 +70,11 @@ : VirtualRoute_TaskIndex : (VirtualRoute_TagIndex <$> toList tagPaths) in htmlRoutes+ <> feedRoutes <> staticRoutes <> fmap SiteRoute_VirtualRoute virtualRoutes -emanoteRouteEncoder :: HasCallStack => ModelEma -> Prism' FilePath SiteRoute+emanoteRouteEncoder :: (HasCallStack) => ModelEma -> Prism' FilePath SiteRoute emanoteRouteEncoder model = prism' enc dec where@@ -89,18 +97,20 @@ <|> decodeGeneratedRoute model fp <|> pure (SiteRoute_MissingR fp) -encodeResourceRoute :: HasCallStack => ModelEma -> ResourceRoute -> FilePath+encodeResourceRoute :: (HasCallStack) => ModelEma -> ResourceRoute -> FilePath encodeResourceRoute model = \case- ResourceRoute_LML r ->- R.encodeRoute- $- -- HACK: This should never fail ... but *if* it does, consult- -- https://github.com/srid/emanote/issues/148- maybe- -- FIXME: See note above.- (error $ "emanote: attempt to encode missing note: " <> show r)- N.noteHtmlRoute- $ M.modelLookupNoteByRoute r model+ ResourceRoute_LML view r ->+ -- HACK: This should never fail ... but *if* it does, consult+ -- https://github.com/srid/emanote/issues/148+ fromMaybe+ -- FIXME: See note above.+ (error $ "emanote: attempt to encode missing note resource: " <> show r)+ ( do+ (_, note) <- M.modelLookupNoteByRoute (view, r) model+ case view of+ R.LMLView_Atom -> R.encodeRoute <$> N.noteXmlRoute note+ R.LMLView_Html -> pure $ R.encodeRoute $ N.noteHtmlRoute note+ ) ResourceRoute_StaticFile r _fpAbs -> R.encodeRoute r @@ -110,30 +120,42 @@ fmap staticFileSiteRoute (flip M.modelLookupStaticFileByRoute model =<< R.decodeAnyRoute fp)+ <|> mFeedRoute <|> noteHtmlSiteRoute (flip M.modelLookupNoteByHtmlRoute model $ R.decodeHtmlRoute fp) where+ mFeedRoute :: Maybe SiteRoute+ mFeedRoute = case R.decodeXmlRoute fp of+ Nothing -> Nothing+ Just r -> noteFeedSiteRoute <$> M.modelLookupFeedNoteByHtmlRoute r model noteHtmlSiteRoute :: Rel.ResolvedRelTarget N.Note -> Maybe SiteRoute noteHtmlSiteRoute = \case Rel.RRTMissing -> Nothing Rel.RRTFound note ->- Just $ noteFileSiteRoute note+ Just $ noteFileSiteRoute' note Rel.RRTAmbiguous notes -> Just $ ambiguousNoteURLsRoute notes ambiguousNoteURLsRoute :: NonEmpty N.Note -> SiteRoute ambiguousNoteURLsRoute ns = SiteRoute_AmbiguousR ("/" <> fp) (N._noteRoute <$> ns) -noteFileSiteRoute :: N.Note -> SiteRoute+noteFeedSiteRoute :: N.Note -> SiteRoute+noteFeedSiteRoute = SiteRoute_ResourceRoute . ResourceRoute_LML R.LMLView_Atom . N._noteRoute++noteFileSiteRoute :: (R.LMLView, N.Note) -> SiteRoute noteFileSiteRoute =- lmlSiteRoute . N._noteRoute+ lmlSiteRoute . fmap N._noteRoute -lmlSiteRoute :: LMLRoute -> SiteRoute+noteFileSiteRoute' :: N.Note -> SiteRoute+noteFileSiteRoute' =+ noteFileSiteRoute . (R.LMLView_Html,)++lmlSiteRoute :: (R.LMLView, LMLRoute) -> SiteRoute lmlSiteRoute =- SiteRoute_ResourceRoute . lmlResourceRoute+ SiteRoute_ResourceRoute . uncurry lmlResourceRoute -lmlResourceRoute :: LMLRoute -> ResourceRoute+lmlResourceRoute :: R.LMLView -> LMLRoute -> ResourceRoute lmlResourceRoute = ResourceRoute_LML staticFileSiteRoute :: SF.StaticFile -> SiteRoute@@ -144,13 +166,13 @@ staticResourceRoute = uncurry ResourceRoute_StaticFile -- | Like `siteRouteUrl` but avoids any dynamism in the URL-siteRouteUrlStatic :: HasCallStack => Model -> SiteRoute -> Text+siteRouteUrlStatic :: (HasCallStack) => Model -> SiteRoute -> Text siteRouteUrlStatic model = Ema.routeUrlWith (urlStrategy model) rp where (rp, _) = M.withoutRoutePrism model -siteRouteUrl :: HasCallStack => Model -> SiteRoute -> Text+siteRouteUrl :: (HasCallStack) => Model -> SiteRoute -> Text siteRouteUrl model sr = siteRouteUrlStatic model sr <> siteRouteQuery@@ -174,7 +196,7 @@ case rr of ResourceRoute_StaticFile sfR _fp -> Just sfR- ResourceRoute_LML _ ->+ ResourceRoute_LML _ _ -> Nothing SiteRoute_VirtualRoute _ -> Nothing
src/Emanote/Route/SiteRoute/Type.hs view
@@ -12,7 +12,7 @@ import Data.Aeson (ToJSON) import Emanote.Pandoc.Markdown.Syntax.HashTag qualified as HT import Emanote.Route.Ext qualified as Ext-import Emanote.Route.ModelRoute (LMLRoute, StaticFileRoute, lmlRouteCase)+import Emanote.Route.ModelRoute (LMLRoute, LMLView, StaticFileRoute, lmlRouteCase) import Emanote.Route.R qualified as R import Network.URI.Slug qualified as Slug import Relude hiding (show)@@ -35,7 +35,7 @@ -} data ResourceRoute = ResourceRoute_StaticFile StaticFileRoute FilePath- | ResourceRoute_LML LMLRoute+ | ResourceRoute_LML LMLView LMLRoute deriving stock (Eq, Show, Ord, Generic) deriving anyclass (ToJSON) @@ -56,7 +56,7 @@ case rr of ResourceRoute_StaticFile r _fp -> show r- ResourceRoute_LML r ->+ ResourceRoute_LML _view r -> show $ lmlRouteCase r SiteRoute_VirtualRoute x -> show x@@ -101,13 +101,13 @@ VirtualRoute_TagIndex tagNodes -> R.encodeRoute $ encodeTagIndexR tagNodes VirtualRoute_Index ->- R.encodeRoute $ R.R @() @('Ext.Html) $ "-" :| ["all"]+ R.encodeRoute $ R.R @() @'Ext.Html $ "-" :| ["all"] VirtualRoute_Export ->- R.encodeRoute $ R.R @Ext.SourceExt @('Ext.AnyExt) $ "-" :| ["export.json"]+ R.encodeRoute $ R.R @Ext.SourceExt @'Ext.AnyExt $ "-" :| ["export.json"] VirtualRoute_StorkIndex ->- R.encodeRoute $ R.R @Ext.SourceExt @('Ext.AnyExt) $ "-" :| ["stork.st"]+ R.encodeRoute $ R.R @Ext.SourceExt @'Ext.AnyExt $ "-" :| ["stork.st"] VirtualRoute_TaskIndex ->- R.encodeRoute $ R.R @() @('Ext.Html) $ "-" :| ["tasks"]+ R.encodeRoute $ R.R @() @'Ext.Html $ "-" :| ["tasks"] encodeTagIndexR :: [HT.TagNode] -> R.R 'Ext.Html encodeTagIndexR tagNodes =
src/Emanote/Source/Dynamic.hs view
@@ -32,6 +32,7 @@ import Paths_emanote qualified import Relude import System.UnionMount qualified as UM+import Text.Pandoc.Lua (getEngine) import UnliftIO (MonadUnliftIO) -- | Everything that's required to run an Emanote site.@@ -57,13 +58,14 @@ storkIndex <- Stork.newIndex let layers = Loc.userLayers (CLI.layers _emanoteConfigCli) <> one defaultLayer initialModel = Model.emptyModel layers cliAct _emanoteConfigPandocRenderers _emanoteCompileTailwind instanceId storkIndex+ scriptingEngine <- getEngine Dynamic <$> UM.unionMount (layers & Set.map (id &&& Loc.locPath)) Pattern.filePatterns Pattern.ignorePatterns initialModel- (mapFsChanges $ Patch.patchModel layers _emanoteConfigNoteFn storkIndex)+ (mapFsChanges $ Patch.patchModel layers _emanoteConfigNoteFn storkIndex scriptingEngine) type ChangeHandler tag model m = tag ->
src/Emanote/Source/Loc.hs view
@@ -37,7 +37,7 @@ Assumes that the user has put it always by last; i.e, `-L foo;primary/layer`. -}-primaryLayer :: HasCallStack => LocLayers -> Loc+primaryLayer :: (HasCallStack) => LocLayers -> Loc primaryLayer = Set.findMax . Set.filter isUserLayer where
src/Emanote/Source/Patch.hs view
@@ -13,6 +13,7 @@ import Emanote.Model qualified as M import Emanote.Model.Note qualified as N import Emanote.Model.SData qualified as SD+import Emanote.Model.StaticFile (readStaticFileInfo) import Emanote.Model.Stork.Index qualified as Stork import Emanote.Model.Type (ModelEma) import Emanote.Prelude (@@ -28,6 +29,7 @@ import Relude import Relude.Extra (traverseToSnd) import System.UnionMount qualified as UM+import Text.Pandoc.Scripting (ScriptingEngine) import UnliftIO.Concurrent (threadDelay) import UnliftIO.Directory (doesDirectoryExist) @@ -37,6 +39,8 @@ LocLayers -> (N.Note -> N.Note) -> Stork.IndexVar ->+ -- | Lua scripting engine+ ScriptingEngine -> -- | Type of the file being changed R.FileType R.SourceExt -> -- | Path to the file being changed@@ -44,13 +48,13 @@ -- | Specific change to the file, along with its paths from other "layers" UM.FileAction (NonEmpty (Loc, FilePath)) -> m (ModelEma -> ModelEma)-patchModel layers noteF storkIndexTVar fpType fp action = do+patchModel layers noteF storkIndexTVar scriptingEngine fpType fp action = do logger <- askLoggerIO now <- liftIO getCurrentTime -- Prefix all patch logging with timestamp. let newLogger loc src lvl s = logger loc src lvl $ fromString (formatTime defaultTimeLocale "[%H:%M:%S] " now) <> s- runLoggingT (patchModel' layers noteF storkIndexTVar fpType fp action) newLogger+ runLoggingT (patchModel' layers noteF storkIndexTVar scriptingEngine fpType fp action) newLogger -- | Map a filesystem change to the corresponding model change. patchModel' ::@@ -58,6 +62,8 @@ LocLayers -> (N.Note -> N.Note) -> Stork.IndexVar ->+ -- | Lua scripting engine+ ScriptingEngine -> -- | Type of the file being changed R.FileType R.SourceExt -> -- | Path to the file being changed@@ -65,7 +71,7 @@ -- | Specific change to the file, along with its paths from other "layers" UM.FileAction (NonEmpty (Loc, FilePath)) -> m (ModelEma -> ModelEma)-patchModel' layers noteF storkIndexTVar fpType fp action = do+patchModel' layers noteF storkIndexTVar scriptingEngine fpType fp action = do case fpType of R.LMLType lmlType -> do case R.mkLMLRouteFromKnownFilePath lmlType fp of@@ -90,7 +96,7 @@ -- Until this, `layers` is threaded through as a hack. currentLayerPath = locPath $ primaryLayer layers s <- readRefreshedFile refreshAction fpAbs- note <- N.parseNote currentLayerPath r fpAbs (decodeUtf8 s)+ note <- N.parseNote scriptingEngine currentLayerPath r fpAbs (decodeUtf8 s) pure $ M.modelInsertNote $ noteF note UM.Delete -> do log $ "Removing note: " <> toText fp@@ -145,7 +151,8 @@ _ -> log . ("Re-registering" <>) logF $ " file: " <> toText fpAbs <> " " <> show r t <- liftIO getCurrentTime- pure $ M.modelInsertStaticFile t r fpAbs+ mInfo <- readStaticFileInfo fpAbs (fmap decodeUtf8 . readRefreshedFile refreshAction)+ pure $ M.modelInsertStaticFile t r fpAbs mInfo UM.Delete -> do pure $ M.modelDeleteStaticFile r
src/Emanote/Source/Pattern.hs view
@@ -4,7 +4,7 @@ import Relude import System.FilePattern (FilePattern) -filePattern :: HasCallStack => R.FileType R.SourceExt -> FilePath+filePattern :: (HasCallStack) => R.FileType R.SourceExt -> FilePath filePattern = \case R.LMLType R.Md -> R.withExt @_ @('R.LMLType 'R.Md) $@@ -13,9 +13,9 @@ R.withExt @_ @('R.LMLType 'R.Org) $ "**/*" R.Yaml ->- R.withExt @_ @('R.Yaml) "**/*"+ R.withExt @_ @'R.Yaml "**/*" R.HeistTpl ->- R.withExt @_ @('R.HeistTpl) $+ R.withExt @_ @'R.HeistTpl $ "**/*" R.AnyExt -> "**"
src/Emanote/View/Common.hs view
@@ -22,7 +22,6 @@ import Emanote.Model.Title qualified as Tit import Emanote.Model.Type (Model) import Emanote.Model.Type qualified as M-import Emanote.Pandoc.BuiltinFilters (preparePandoc) import Emanote.Pandoc.Renderer (EmanotePandocRenderers (..), PandocRenderers (..)) import Emanote.Pandoc.Renderer qualified as Renderer import Emanote.Route (LMLRoute)@@ -75,7 +74,7 @@ -- TODO: We should be using withInlineCtx, so as to make the wikilink -- render in note title. titleSplice titleDoc = withLinkInlineCtx $ \ctx ->- Tit.titleSplice ctx preparePandoc titleDoc+ Tit.titleSplice ctx id titleDoc in TemplateRenderCtx {..} where withRenderCtx ::@@ -104,7 +103,7 @@ generatedCssFile = "tailwind.css" commonSplices ::- HasCallStack =>+ (HasCallStack) => ((RenderCtx -> HI.Splice Identity) -> HI.Splice Identity) -> Model -> Aeson.Value ->@@ -140,7 +139,7 @@ "ema:metadata" ## HJ.bindJson meta "ema:title" ## withCtx $ \ctx ->- Tit.titleSplice ctx preparePandoc routeTitle+ Tit.titleSplice ctx id routeTitle -- <head>'s <title> cannot contain HTML "ema:titleFull" ## Tit.titleSpliceNoHtml routeTitleFull@@ -150,7 +149,7 @@ -- get the full URL. The reason there is no slash in between is to account for -- the usual case of homeUrl being an empty string. "ema:homeUrl" ##- ( let homeR = SR.lmlSiteRoute (M.modelIndexRoute model)+ ( let homeR = SR.lmlSiteRoute (R.LMLView_Html, M.modelIndexRoute model) homeUrl' = SR.siteRouteUrl model homeR homeUrl = if homeUrl' /= "" then homeUrl' <> "/" else homeUrl' in HI.textSplice homeUrl@@ -222,5 +221,5 @@ & init & fmap (M.resolveLmlRoute model) Splices.listSplice breadcrumbs "each-crumb" $ \crumbR -> do- "crumb:url" ## HI.textSplice (SR.siteRouteUrl model $ SR.lmlSiteRoute crumbR)+ "crumb:url" ## HI.textSplice (SR.siteRouteUrl model $ SR.lmlSiteRoute (R.LMLView_Html, crumbR)) "crumb:title" ## titleSplice (M.modelLookupTitle crumbR model)
src/Emanote/View/Export.hs view
@@ -63,7 +63,7 @@ (Tit.toPlain tit) k (toText . lmlSourcePath <$> G.parentLmlRoute model r)- (SR.siteRouteUrl model $ lmlSiteRoute r)+ (SR.siteRouteUrl model $ lmlSiteRoute (R.LMLView_Html, r)) meta_ (fromMaybe [] $ Map.lookup k rels) )
+ src/Emanote/View/Feed.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE NamedFieldPuns #-}++module Emanote.View.Feed where++import Data.Aeson qualified as Aeson+import Data.Aeson.Optics (key, _String)+import Emanote.Model (Model)+import Emanote.Model.Meta (getEffectiveRouteMeta)+import Emanote.Model.Note (Feed (..), Note (..), lookupMeta)+import Emanote.Model.Query (Query, parseQuery, runQuery)+import Emanote.Model.SData (lookupAeson)+import Emanote.Model.Title (toPlain)+import Emanote.Route.SiteRoute+import Emanote.Route.SiteRoute.Class (noteFeedSiteRoute)+import Optics.Operators ((^?))+import Optics.Optic ((%))+import Relude+import Text.Atom.Feed qualified as Atom+import Text.Atom.Feed.Export qualified as Export (textFeed)+import Text.Pandoc.Definition hiding (lookupMeta)++import Emanote.Route.ModelRoute (LMLView (..))+import Text.Blaze.Html (Html, (!))+import Text.Blaze.Html5 qualified as H+import Text.Blaze.Html5.Attributes qualified as A++feedDiscoveryLink :: Model -> Note -> Html+feedDiscoveryLink model note =+ H.link+ ! A.href ("/" <> H.toValue feedUrl)+ ! A.rel "alternate"+ ! A.type_ "application/atom+xml"+ ! A.title "Atom Feed"+ where+ feedUrl = siteRouteUrl model (noteFeedSiteRoute note)++noteToEntry :: Atom.URI -> (Note -> Text) -> Note -> Atom.Entry+noteToEntry baseUrl noteUrl note = entry {Atom.entrySummary, Atom.entryLinks}+ where+ entry = Atom.nullEntry entryUrl noteTitle noteDate+ entryUrl = noteUrl note+ entryLinks = [(Atom.nullLink (baseUrl <> "/" <> entryUrl)) {Atom.linkRel = Just (Left "alternate")}]+ noteDate = getNoteDate note+ noteTitle = Atom.TextString $ toPlain $ _noteTitle note+ entrySummary = Atom.TextString <$> lookupMeta ("page" :| ["description"]) note++getNoteDate :: Note -> Atom.Date+getNoteDate note = fromMaybe "1970-01-01" $ _noteMeta note ^? key "date" % _String++getNoteQuery :: Note -> Either LText Query+getNoteQuery note = case _noteDoc note of+ Pandoc _meta [] -> Left "empty note"+ Pandoc _meta blocks -> go blocks+ where+ go [] = Left "can't find note query"+ go (block : rest) = case block of+ CodeBlock ("", classes, _) txt | "query" `elem` classes -> case parseQuery txt of+ Nothing -> Left ("invalid query: " <> toLazy txt)+ Just query -> case go rest of+ -- Check that only query exists+ Right _ -> Left "multiple ```query found"+ Left _ -> Right query+ _ -> go rest++renderFeed :: Model -> Note -> Either LText LByteString+renderFeed model baseNote = case eFeedText of+ Left err -> Left err+ Right feedText -> Right (encodeUtf8 feedText)+ where+ eFeedText = do+ -- get the note feed+ feed <- maybeToRight "feed attribute missing" $ _noteFeed baseNote++ -- find the query and get the feed notes+ feedQuery <- getNoteQuery baseNote+ notes <- case runQuery (_noteRoute baseNote) model feedQuery of+ [] -> Left "no notes matched the query"+ x : xs -> Right (x :| xs)++ -- lookup the feedUrl+ let feedMeta :: Aeson.Value+ feedMeta = getEffectiveRouteMeta (_noteRoute baseNote) model+ let mFeedUrl :: Maybe Text+ mFeedUrl = lookupAeson Nothing ("feed" :| ["siteUrl"]) feedMeta+ feedUrl <- maybeToRight "index.yaml or note doesn't have feed.siteUrl" mFeedUrl++ -- process the notes+ let noteUrl note =+ let sr = SiteRoute_ResourceRoute $ ResourceRoute_LML LMLView_Html $ _noteRoute note+ in siteRouteUrl model sr+ let takeNotes = case _feedLimit feed of+ Nothing -> id+ Just x -> take (fromIntegral x)+ let feedEntries = noteToEntry feedUrl noteUrl <$> takeNotes (toList notes)++ -- render the feed+ let feedTitle = fromMaybe (toPlain $ _noteTitle baseNote) (_feedTitle feed)+ let feedName = Atom.TextString feedTitle+ let feedUpdated = getNoteDate (head notes)+ let feedLinks =+ [ (Atom.nullLink (feedUrl <> "/" <> noteUrl baseNote)) {Atom.linkRel = Just (Left "alternate")}+ , (Atom.nullLink (feedUrl <> "/" <> siteRouteUrl model (noteFeedSiteRoute baseNote))) {Atom.linkRel = Just (Left "self")}+ ]+ let atomFeed = (Atom.nullFeed feedUrl feedName feedUpdated) {Atom.feedEntries, Atom.feedLinks}+ maybeToRight "invalid feed" $ Export.textFeed atomFeed
src/Emanote/View/TagIndex.hs view
@@ -67,7 +67,7 @@ lookupForestMust path = fromMaybe (error $ "Tag not found in forest: " <> show path) . lookupForest path- lookupForest :: Eq k => NonEmpty k -> Forest (k, a) -> Maybe (Tree (k, a))+ lookupForest :: (Eq k) => NonEmpty k -> Forest (k, a) -> Maybe (Tree (k, a)) lookupForest (k :| ks') trees = case nonEmpty ks' of Nothing ->
src/Emanote/View/TaskIndex.hs view
@@ -34,7 +34,7 @@ tCtx = Common.mkTemplateRenderCtx model defR meta taskIndex = mkTaskIndex model taskGroupSplice r tasks = do- "t:note:url" ## HI.textSplice (SR.siteRouteUrl model $ SR.lmlSiteRoute r)+ "t:note:url" ## HI.textSplice (SR.siteRouteUrl model $ SR.lmlSiteRoute (R.LMLView_Html, r)) "t:note:title" ## Common.titleSplice tCtx (M.modelLookupTitle r model) "t:note:breadcrumbs" ## Common.routeBreadcrumbs tCtx model r@@ -45,7 +45,7 @@ "task:description" ## Common.withInlineCtx tCtx $ \ctx -> Splices.pandocSplice ctx $ B.Pandoc mempty $ one $ B.Plain $ task ^. Task.taskDescription "note:title" ## Common.titleSplice tCtx (M.modelLookupTitle r model)- "note:url" ## HI.textSplice (SR.siteRouteUrl model $ SR.lmlSiteRoute r)+ "note:url" ## HI.textSplice (SR.siteRouteUrl model $ SR.lmlSiteRoute (R.LMLView_Html, r)) Common.renderModelTemplate model "templates/special/tasks" $ do Common.commonSplices ($ emptyRenderCtx) model meta "Task Index"
src/Emanote/View/Template.hs view
@@ -16,13 +16,13 @@ import Emanote.Model.Note qualified as MN import Emanote.Model.SData qualified as SData import Emanote.Model.Stork (renderStorkIndex)-import Emanote.Pandoc.BuiltinFilters (prepareNoteDoc, preparePandoc) import Emanote.Route qualified as R import Emanote.Route.SiteRoute (SiteRoute) import Emanote.Route.SiteRoute qualified as SR import Emanote.Route.SiteRoute.Class (indexRoute) import Emanote.View.Common qualified as C import Emanote.View.Export (renderGraphExport)+import Emanote.View.Feed (feedDiscoveryLink, renderFeed) import Emanote.View.TagIndex qualified as TagIndex import Emanote.View.TaskIndex qualified as TaskIndex import Heist qualified as H@@ -35,6 +35,7 @@ import Optics.Core (Prism', review) import Optics.Operators ((.~), (^.)) import Relude+import Text.Blaze.Renderer.XmlHtml qualified as RX import Text.Pandoc.Builder qualified as B import Text.Pandoc.Definition (Pandoc (..)) @@ -86,10 +87,14 @@ renderResourceRoute :: Model -> SR.ResourceRoute -> Ema.Asset LByteString renderResourceRoute m = \case- SR.ResourceRoute_LML r -> do- case M.modelLookupNoteByRoute r m of- Just note ->+ SR.ResourceRoute_LML view r -> do+ case M.modelLookupNoteByRoute (view, r) m of+ Just (R.LMLView_Html, note) -> Ema.AssetGenerated Ema.Html $ renderLmlHtml m note+ Just (R.LMLView_Atom, note) ->+ case renderFeed m note of+ Left err -> error $ toStrict $ "Bad feed: " <> show r <> ": " <> err+ Right feed -> Ema.AssetGenerated Ema.Other feed Nothing -> -- This should never be reached because decodeRoute looks up the model. error $ "Bad route: " <> show r@@ -139,14 +144,14 @@ let backlinksSplice (bs :: [(R.LMLRoute, NonEmpty [B.Block])]) = Splices.listSplice bs "backlink" $ \(source, contexts) -> do- let bnote = fromMaybe (error "backlink note missing - impossible") $ M.modelLookupNoteByRoute source model+ let bnote = fromMaybe (error "backlink note missing - impossible") $ M.modelLookupNoteByRoute' source model bmeta = Meta.getEffectiveRouteMetaWith (bnote ^. MN.noteMeta) source model bctx = C.mkTemplateRenderCtx model source bmeta -- TODO: reuse note splice "backlink:note:title" ## C.titleSplice bctx (M.modelLookupTitle source model)- "backlink:note:url" ## HI.textSplice (SR.siteRouteUrl model $ SR.lmlSiteRoute source)+ "backlink:note:url" ## HI.textSplice (SR.siteRouteUrl model $ SR.lmlSiteRoute (R.LMLView_Html, source)) "backlink:note:contexts" ## Splices.listSplice (toList contexts) "context" $ \backlinkCtx -> do- let ctxDoc :: Pandoc = preparePandoc $ Pandoc mempty $ one $ B.Div B.nullAttr backlinkCtx+ let ctxDoc = Pandoc mempty $ one $ B.Div B.nullAttr backlinkCtx "context:body" ## C.withInlineCtx bctx $ \ctx' -> Splices.pandocSplice ctx' ctxDoc -- Sidebar navigation@@ -156,11 +161,17 @@ -- Note stuff "ema:note:title" ## C.titleSplice ctx (note ^. MN.noteTitle)- let modelRoute = R.ModelRoute_LML r+ let modelRoute = R.ModelRoute_LML R.LMLView_Html r "ema:note:source-path" ## HI.textSplice (toText . R.withLmlRoute R.encodeRoute $ r) "ema:note:url" ##- HI.textSplice (SR.siteRouteUrl model . SR.lmlSiteRoute $ r)+ HI.textSplice (SR.siteRouteUrl model . SR.lmlSiteRoute $ (R.LMLView_Html, r))+ "emaNoteFeedUrl"+ ## pure+ . RX.renderHtmlNodes+ $ if MN.noteHasFeed note+ then feedDiscoveryLink model note+ else mempty "ema:note:backlinks" ## backlinksSplice (G.modelLookupBacklinks modelRoute model) let (backlinksDaily, backlinksNoDaily) = partition (Calendar.isDailyNote . fst) $ G.modelLookupBacklinks modelRoute model@@ -170,20 +181,20 @@ backlinksSplice backlinksNoDaily let folgeAnc = G.modelFolgezettelAncestorTree modelRoute model "ema:note:uptree" ##- Splices.treeSplice (const ()) folgeAnc $+ Splices.treeSplice (\_ _ -> ()) folgeAnc $ \(last -> nodeRoute) children -> do "node:text" ## C.titleSplice ctx $ M.modelLookupTitle nodeRoute model- "node:url" ## HI.textSplice $ SR.siteRouteUrl model $ SR.lmlSiteRoute nodeRoute+ "node:url" ## HI.textSplice $ SR.siteRouteUrl model $ SR.lmlSiteRoute (R.LMLView_Html, nodeRoute) "tree:open" ## Heist.ifElseISplice (not . null $ children) "ema:note:uptree:nonempty" ## Heist.ifElseISplice (not . null $ folgeAnc) "ema:note:pandoc" ## C.withBlockCtx ctx $ \ctx' ->- Splices.pandocSplice ctx' (prepareNoteDoc note)+ Splices.pandocSplice ctx' (note ^. MN.noteDoc) -- | If there is no 'current route', all sub-trees are marked as active/open. routeTreeSplice ::- Monad n =>+ (Monad n) => C.TemplateRenderCtx n -> Maybe R.LMLRoute -> Model ->@@ -191,18 +202,24 @@ routeTreeSplice tCtx mr model = do "ema:route-tree" ## ( let tree = PathTree.treeDeleteChild "index" $ model ^. M.modelNav- getOrder tr =- ( Meta.lookupRouteMeta @Int 0 (one "order") tr model- , tr- )+ getFoldersFirst tr =+ Meta.lookupRouteMeta @Bool False ("template" :| ["sidebar", "folders-first"]) tr model+ getOrder path children =+ let tr = mkLmlRoute path+ isLeaf = null children+ priority = if getFoldersFirst tr && isLeaf then 1 else 0 :: Int+ in ( priority+ , Meta.lookupRouteMeta @Int 0 (one "order") tr model+ , tr+ ) getCollapsed tr = Meta.lookupRouteMeta @Bool True ("template" :| ["sidebar", "collapsed"]) tr model mkLmlRoute = M.resolveLmlRoute model . R.mkRouteFromSlugs lmlRouteSlugs = R.withLmlRoute R.unRoute- in Splices.treeSplice (getOrder . mkLmlRoute) tree $ \(mkLmlRoute -> nodeRoute) children -> do+ in Splices.treeSplice getOrder tree $ \(mkLmlRoute -> nodeRoute) children -> do "node:text" ## C.titleSplice tCtx $ M.modelLookupTitle nodeRoute model- "node:url" ## HI.textSplice $ SR.siteRouteUrl model $ SR.lmlSiteRoute nodeRoute+ "node:url" ## HI.textSplice $ SR.siteRouteUrl model $ SR.lmlSiteRoute (R.LMLView_Html, nodeRoute) let isActiveNode = Just nodeRoute == mr isActiveTree = -- Active tree checking is applicable only when there is an@@ -218,7 +235,7 @@ "tree:open" ## Heist.ifElseISplice openTree ) -lookupTemplateName :: ConvertUtf8 Text b => Aeson.Value -> b+lookupTemplateName :: (ConvertUtf8 Text b) => Aeson.Value -> b lookupTemplateName meta = encodeUtf8 $ SData.lookupAeson @Text defaultTemplate ("template" :| ["name"]) meta where