This commit is contained in:
Malte Brandy 2021-06-18 15:58:08 +02:00
parent c67ef9f469
commit cf0f719c81
No known key found for this signature in database
GPG Key ID: 226A2D41EF5378C9
4 changed files with 89 additions and 28 deletions

2
.gitignore vendored
View File

@ -1,7 +1,7 @@
*~
/output
dist-newstyle
result
result*
/.direnv
/.pre-commit-config.yaml
/content/static/font

View File

@ -38,7 +38,14 @@
{
LOCALE_ARCHIVE = "${pkgs.glibcLocales}/lib/locale/locale-archive";
LC_ALL = "en_US.UTF-8";
} "mkdir $out; ${packages.generator}/bin/run-ema -C ${./content} gen $out";
} ''
cp -r ${./content} content
chmod +w content
echo ${toString self.lastModified} > content/lastModified
ls -lha content
mkdir $out
${packages.generator}/bin/run-ema -C content gen $out
'';
css = pkgs.runCommand "windi.css" { } ''
${windicss}/bin/windicss '${packages.pageWithoutResources}/**/*.html' -mto $out
'';

View File

@ -10,6 +10,7 @@
module Main where
import Relude
import qualified Relude.Unsafe as Unsafe
import Prelude ()
import Control.Monad.Logger (logErrorNS)
@ -19,6 +20,8 @@ import Data.String.Interpolate (i)
import qualified Data.Text as Text
import Data.Time (Day, defaultTimeLocale)
import qualified Text.Atom.Feed as Atom
import qualified Text.Atom.Feed.Export as Export (textFeed)
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Text.Blaze.Html5 ((!))
import qualified Text.Blaze.Html5 as H
@ -35,7 +38,8 @@ import qualified Ema.Helper.Tailwind as Tailwind
import qualified Data.Set as Set
import qualified Data.Text.Lazy as LText
import Data.Time.Format (formatTime)
import Data.Time.Clock (UTCTime (UTCTime))
import Data.Time.Format (formatTime, parseTimeM)
import RenderPandoc (renderPandoc)
newtype Tag = Tag {unTag :: Text}
@ -115,16 +119,20 @@ data Meta = Meta
-- readingSpeed = wordcount / 130 words per minute
type Model = Map PageName PageData
type Model = (Maybe UTCTime, Map PageName PageData)
lookupPage :: PageName -> Model -> Maybe PageData
lookupPage name = Map.lookup name . snd
instance Ema Model (Either FilePath Route) where
encodeRoute _model =
encodeRoute model =
either id $
\case
Page page -> html $ pageNameToUrl page
BlogList index -> html $ Slug "list" : indexToPath index
Page page | page == Special (Slug "") || isJust (lookupPage page model) -> html $ pageNameToUrl page
BlogList index@(Index _ tag) | maybe True (`elem` allTags model) tag -> html $ Slug "list" : indexToPath index
Feeds -> html [Slug "feeds"]
Rss index -> xml $ Slug "feed" : indexToPath index
Rss index@(Index _ tag) | maybe True (`elem` allTags model) tag -> xml $ Slug "feed" : indexToPath index
notFound -> error [i|Route #{notFound} does not exist.|]
where
html = toPath "html"
xml = toPath "xml"
@ -138,24 +146,24 @@ instance Ema Model (Either FilePath Route) where
[Slug "feeds"] -> Just (Right Feeds)
Slug "feed" : (pathToIndex -> Just index) -> Just (Right (Rss index))
Slug "list" : (pathToIndex -> Just index) -> Just (Right (BlogList index))
p | Just pageName <- urlToPageName p, Just _ <- Map.lookup pageName model -> Just (Right (Page pageName))
p | Just pageName <- urlToPageName p, Just _ <- lookupPage pageName model -> Just (Right (Page pageName))
_ -> Nothing
allRoutes model = [Left "static", Right Feeds] <> pages <> feeds <> lists
where
pages = Right . Page <$> Map.keys model
pages = Right . Page <$> Map.keys (snd model)
allIndices = [Nothing, Just De, Just En] >>= \l -> Index l <$> (Nothing : (Just <$> toList (allTags model)))
feeds = Right . Rss <$> allIndices
lists = Right . BlogList <$> allIndices
allTags :: Model -> Set Tag
allTags = fold . mapMaybe (fmap (fromList . toList) . tags . fst) . Map.elems
allTags :: Model -> [Tag]
allTags = reverse . fmap Unsafe.head . sortOn length . group . sort . join . mapMaybe (fmap toList . tags . fst) . Map.elems . snd
main :: IO ()
main = do
Ema.runEma (\act m -> either Ema.AssetStatic (render act m)) $ \_ model -> do
let pats = [((), "**/*.md")]
ignorePats = [".*"]
FileSystem.mountOnLVar "." pats ignorePats model mempty $ \(concatMap snd -> fps) action -> do
let pats = [((), "**/*.md"), ((), "lastModified")]
ignorePats = [".*", "drafts/*"]
FileSystem.mountOnLVar "." pats ignorePats model (Nothing, mempty) $ \(concatMap snd -> fps) action -> do
modelUpdates <- forM fps $ \fp -> case action of
FileSystem.Update ->
case pageNameFromFilepath fp of
@ -163,8 +171,12 @@ main = do
file <- readFileText fp
Markdown.parseMarkdownWithFrontMatter Markdown.fullMarkdownSpec fp file & \case
Left err -> do logErrorNS "maralorn.de" [i|Parse error on #{fp}: #{err}|]; pure id
Right (Just meta, page) -> pure $ Map.insert pageName (meta, page)
Right (Just meta, page) -> pure $ second (Map.insert pageName (meta, page))
_ -> do logErrorNS "maralorn.de" [i|Failed to parse Meta on #{fp}|]; pure id
_ | "lastModified" == fp -> do
stamp <- readFile fp
time <- either error pure $ parseTimeM True defaultTimeLocale "%s" stamp
pure $ first (const (Just time))
_ -> pure id
FileSystem.Delete ->
pure id
@ -182,13 +194,51 @@ render emaAction model r =
Left other -> Ema.AssetGenerated Ema.Other other
where
content = case r of
Page pageName@(BlogPost _) | Just (meta, pandoc) <- Map.lookup pageName model -> Right (renderPost model meta pandoc)
Page pageName@(Special _) | Just (meta, pandoc) <- Map.lookup pageName model -> Right (renderSpecial model meta pandoc)
Page pageName@(BlogPost _) | Just (meta, pandoc) <- lookupPage pageName model -> Right (renderPost model meta pandoc)
Page pageName@(Special _) | Just (meta, pandoc) <- lookupPage pageName model -> Right (renderSpecial model meta pandoc)
Page pageName -> Right (Content (Just "Error") [i|Missing Model for #{pageName}|])
Feeds -> Right (Content (Just "Feeds") "Feeds are not yet implemented.")
Rss _ -> Left ""
Feeds -> Right (Content (Just "Feeds") (feedList model))
Rss index -> Left (maybe (error "Feed malformed?") encodeUtf8 $ Export.textFeed $ mkFeed model index)
BlogList index -> Right (renderBlogList model index)
mkFeed :: Model -> Index -> Atom.Feed
mkFeed model index =
( Atom.nullFeed
(Ema.routeUrl model (Right (Rss index) :: Either FilePath _))
(Atom.TextString "Maralorns Blog")
"never"
)
{ Atom.feedIcon = Just ""
, Atom.feedEntries = []
, Atom.feedLinks = one $ Atom.nullLink ""
}
--feedText = feed
feedList :: Model -> H.Html
feedList model = do
H.h2 ! tw ["text-xl", "text-blue-800"] $ "Feed of all posts"
H.table ! tw ["table-fixed", "w-full", "my-2"] $
H.tr $ do
icell ""
cell (mkLink Nothing Nothing)
cell (mkLink (Just En) Nothing)
cell (mkLink (Just De) Nothing)
H.h2 ! tw ["text-xl", "text-blue-800"] $ "Feeds by tag"
H.table ! tw ["table-fixed", "w-full", "my-2"] $ do
forM_ (allTags model) $ \tag -> H.tr $ do
icell (renderTag model True tag)
cell (mkLink Nothing (Just tag))
cell (mkLink (Just En) (Just tag))
cell (mkLink (Just De) (Just tag))
where
mkLink language tag = H.a ! tw ["px-1", "bg-gray-100", "text-blue-800", "hover:underline"] ! routeHref model (Rss (Index language tag)) $ case language of
Just De -> "Only German"
Just En -> "Only English"
Nothing -> "Any Language"
cell = H.td ! tw ["text-right", "w-1/4"]
icell = H.td ! tw ["text-left", "w-1/4"]
renderBlogList :: Model -> Index -> Content
renderBlogList model (Index language tag) = Content (Just title') $ do
H.div ! tw ["text-right"] $ langSwitcher De <> "" <> langSwitcher En
@ -211,10 +261,10 @@ renderBlogList model (Index language tag) = Content (Just title') $ do
maybe id (\t -> filter (\(_, (meta, _)) -> t `elem` maybe [] toList (tags meta))) tag $
maybe id (\l -> filter (\(_, (meta, _)) -> l == lang meta)) language $
mapMaybe (\(n, x) -> n & \case BlogPost name -> Just (name, x); _ -> Nothing) $
Map.toList model
Map.toList (snd model)
renderPostSummary :: Model -> (Slug, (Meta, Pandoc)) -> H.Html
renderPostSummary model (name, (meta, pandoc)) = H.div ! tw ["border-t-2"] $ do
renderPostSummary model (name, (meta, pandoc)) = H.div ! tw ["border-t-2", "mt-4"] $ do
H.h2 ! tw ["text-blue-800", "text-xl"] $ (H.a ! tw ["hover:bg-blue-50", "rounded"] ! routeHref model (Page (BlogPost name)) $ H.text $ title meta)
renderPostHeader model meta pandoc True
@ -248,7 +298,7 @@ renderContent content model r = (header, body)
, (intern $ BlogList (Index Nothing Nothing), "All Posts")
, --, (intern $ BlogList (Index Nothing (Just (Tag "project"))), "Projects")
(intern $ BlogList (Index Nothing (Just (Tag "non-tech"))), "Non-Tech")
, (intern $ BlogList (Index Nothing (Just (Tag "tech"))), "Tech")
--, (intern $ BlogList (Index Nothing (Just (Tag "tech"))), "Tech")
]
H.span ! tw ["flex-row", "flex", "justify-items-center"] $
headLinks
@ -262,8 +312,11 @@ renderContent content model r = (header, body)
H.div ! tw ["mx-auto", "max-w-prose"] $ do
whenJust (contentTitle content) $ \theTitle -> H.h1 ! tw ["text-3xl text-blue-800 pt-8 pb-4"] $ H.text theTitle
H.div ! tw ["text-justify"] $ contentHtml content
H.footer ! tw ["border-t-2", "flex", "justify-between"] $ do
H.footer ! tw ["border-t-2", "flex", "justify-between", "mt-4", "text-sm"] $ do
H.a ! tw ["text-blue-600", "hover:bg-blue-100"] ! A.href [i|#{Ema.routeUrl model (Right r :: Either FilePath Route)}\#top|] $ "Back to top"
H.span ! tw ["text-gray-600"] $ do
[i|Generated: #{maybe "dynamically" (formatTime defaultTimeLocale "%F") (fst model)}|]
" Source will soon be published under AGPL"
H.a ! tw ["text-blue-600", "hover:underline"] ! A.href "https://ema.srid.ca" $ "Created with Ema"
-- tag-cloud
icon :: Text -> H.Html
@ -289,7 +342,7 @@ wordsPerMinute = 200
renderPostHeader :: Model -> Meta -> Pandoc -> Bool -> H.Html
renderPostHeader model meta pandoc flip' = do
whenJust (summary meta) $ \x -> H.p ! tw ["italic", "text-gray-700"] $ H.text x
H.div ! tw ["my-2", "overflow-auto"] $ do
H.div ! tw ["overflow-auto"] $ do
H.span ! tw ("text-blue-600" : if flip' then ["float-left"] else ["float-right"]) $ H.text $ Text.intercalate "" $ trans $ [[i|~#{round (toRational wordCount / 200) :: Int} min|], langToText (lang meta)] <> maybeToList (toText . formatTime defaultTimeLocale "%-e %B %Y" <$> date meta)
H.span ! tw (["flex", "flex-wrap-reverse"] <> if flip' then ["float-right", "justify-end"] else ["float-left", "justify-start"]) $ forM_ (maybe [] toList $ tags meta) (renderTag model False)
where
@ -301,7 +354,7 @@ renderTag model showCount tag = H.a ! smallCaps ["px-1", "m-0.5", "text-blue-800
H.text (unTag tag)
memptyIfFalse showCount $ H.span ! tw ["ml-1", "text-sm", "text-gray-500"] $ show count
where
count = length $ filter (tag `elem`) $ maybe [] toList . tags . fst <$> Map.elems model
count = length $ filter (tag `elem`) $ maybe [] toList . tags . fst <$> Map.elems (snd model)
renderSpecial :: Model -> Meta -> Pandoc -> Content
renderSpecial model meta pandoc =
@ -343,7 +396,7 @@ similarPosts model meta = H.div $ do
sortOn (similarity meta . fst . snd) $
filter (\(_, (m, _)) -> similarity meta m > 0 && title meta /= title m) $
mapMaybe (\(n, x) -> n & \case BlogPost name -> Just (name, x); _ -> Nothing) $
Map.toList model
Map.toList (snd model)
similarity m1 m2 = length $ Set.intersection (tagSet m1) (tagSet m2)
where
tagSet = maybe mempty (fromList . toList) . tags
@ -359,7 +412,7 @@ recentPosts model = H.div do
sortOn (date . fst . snd) $
filter (\(_, (meta, _)) -> isJust (date meta)) $
mapMaybe (\(n, x) -> n & \case BlogPost name -> Just (name, x); _ -> Nothing) $
Map.toList model
Map.toList (snd model)
includeCss :: Ema.CLI.Action -> H.Html
includeCss = \case

View File

@ -15,6 +15,7 @@ executable run-ema
, containers
, data-default
, ema >=0.2
, feed
, filepath
, lvar
, monad-logger