Save status-quo

This commit is contained in:
Malte Brandy 2021-06-14 03:21:31 +02:00
parent 1c0bcc380a
commit c5b78d1ed6
No known key found for this signature in database
GPG Key ID: 226A2D41EF5378C9
5 changed files with 113 additions and 89 deletions

View File

@ -1,5 +1,7 @@
Title: Studien
Date: 2017-06-13
---
title: Studien
date: 2017-06-13
---
Vor ein paar Tagen stellte man mir in einem Gespräch eine spannende Frage, die ungefähr so lautete:
„Lässt Du Dein Weltbild durch Studien beeinflussen?“

View File

@ -1,3 +1,7 @@
---
title: Approximations of Truth
---
# Ema Template
Hi, welcome to the **Ema Template** website. This is site generated from [ema-template repo](http://github.com/srid/ema-template) which uses the [Ema](https://ema.srid.ca/) Haskell static site generator.

1
fourmolu.yaml Normal file
View File

@ -0,0 +1 @@
indentation: 2

View File

@ -1,107 +1,128 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE QuasiQuotes #-}
module Main where
import Control.Concurrent (threadDelay)
import Control.Monad.Logger
import Data.Aeson (FromJSON)
import Data.Default (Default (..))
import qualified Data.LVar as LVar
import Data.Time.LocalTime (ZonedTime (ZonedTime))
import Ema (Ema (..), Slug (..))
import qualified Ema
import qualified Ema.CLI
import qualified Ema.CLI as CLI
import qualified Ema.Helper.FileSystem as FileSystem
import qualified Ema.Helper.Markdown as Markdown
import qualified Ema.Helper.PathTree as PathTree
import qualified Ema.Helper.Tailwind as Tailwind
import Relude
import Prelude ()
import Control.Monad.Logger (logErrorNS)
import Data.Aeson (FromJSON)
import Data.Default (Default (def))
import qualified Data.Map.Strict as Map
import Data.String.Interpolate (i)
import qualified Data.Text as Text
import Data.Time (Day)
import Text.Blaze.Html5 ((!))
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import Text.Pandoc (runPure)
import Text.Pandoc.Definition (Pandoc (..))
import Prelude ()
import Text.Pandoc.Writers (writeHtml5)
newtype Tag = Tag Text deriving (Show)
data Index = Index (Maybe Lang) (Maybe Tag) deriving (Show)
data Lang = De | En deriving (Show)
import Ema (Ema (..), Slug (..), decodeSlug, encodeSlug)
import qualified Ema
import qualified Ema.CLI
import qualified Ema.Helper.FileSystem as FileSystem
import qualified Ema.Helper.Markdown as Markdown
import qualified Ema.Helper.Tailwind as Tailwind
newtype Tag = Tag Text deriving (Show, Eq, Generic, FromJSON)
data Index = Index (Maybe Lang) (Maybe Tag) deriving (Show, Eq)
data Lang = De | En deriving (Show, Eq, Generic, FromJSON)
data Route
= Special Slug
| BlogPost Slug
| BlogList Index
| Rss Index
deriving (Show)
= Page PageName
| BlogList Index
| Rss Index
deriving (Show, Eq)
type Post = (Meta, Pandoc)
type Special = (Meta, Pandoc)
data PageName = BlogPost Slug | Special Slug deriving (Show, Eq, Ord)
pageNameFromFilepath :: FilePath -> Maybe PageName
pageNameFromFilepath fp =
Text.stripSuffix ".md" (toText fp) <&> Text.splitOn "/" >>= \case
["special", name] -> Just (Special (Slug name))
["posts", name] -> Just (BlogPost (Slug name))
_ -> Nothing
pageNameToUrl :: PageName -> [Slug]
pageNameToUrl = \case
Special name -> [name]
BlogPost name -> [Slug "post", name]
urlToPageName :: [Slug] -> Maybe PageName
urlToPageName = \case
[Slug "post", name] -> Just (BlogPost name)
[name] -> Just (Special name)
_ -> Nothing
type PageData = (Meta, Pandoc)
data Meta = Meta
{ title :: Text
, summary :: Maybe Text
, date :: Maybe ZonedTime
, tags :: Seq Tag
, lang :: Maybe Lang
}
deriving (Show)
{ title :: Text
, summary :: Maybe Text
, date :: Maybe Day
, tags :: Maybe (NonEmpty Tag)
, lang :: Maybe Lang
}
deriving (Show, Generic, FromJSON)
data Model = Model
{ posts :: Map Slug Post
, specials :: Map Slug Pandoc
}
deriving (Show)
type Model = Map PageName PageData
instance Ema Model Route where
encodeRoute model =
\case
Index -> "index.html"
About -> "about.html"
NotFound -> "not-found.html"
decodeRoute _model = \case
"index.html" -> Just Index
"about.html" -> Just About
"not-found.html" -> Just About
_ -> Nothing
encodeRoute _model = \case
Page page -> toString $ (<> ".html") $ Text.intercalate "/" $ encodeSlug <$> pageNameToUrl page
_ -> error "encodeRoute not completely implemented"
decodeRoute model route =
Text.stripSuffix ".html" (Text.pack route) <&> (fmap decodeSlug . Text.splitOn "/") >>= \case
p | Just pageName <- urlToPageName p, Just _ <- Map.lookup pageName model -> Just (Page pageName)
_ -> Nothing
allRoutes = fmap Page . Map.keys
main :: IO ()
main = do
Ema.runEma (\act m -> Ema.AssetGenerated Ema.Html . render act m) $ \act model -> do
let pats = [((), "**/*.md")]
ignorePats = [".*"]
FileSystem.mountOnLVar "." pats ignorePats model (Model "Hello World.") $ \(concatMap snd -> fps) action -> do
modelUpdates <- forM fps $ \fp -> case action of
FileSystem.Update -> do
file <- readFile fp
pure id
FileSystem.Delete ->
pure id
pure $ flip (foldl' $ flip ($)) modelUpdates
Ema.runEma (\act m -> Ema.AssetGenerated Ema.Html . render act m) $ \_ model -> do
let pats = [((), "**/*.md")]
ignorePats = [".*"]
FileSystem.mountOnLVar "." pats ignorePats model mempty $ \(concatMap snd -> fps) action -> do
modelUpdates <- forM fps $ \fp -> case action of
FileSystem.Update ->
case pageNameFromFilepath fp of
Just pageName -> 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)
_ -> do logErrorNS "maralorn.de" [i|Failed to parse Meta on #{fp}|]; pure id
_ -> pure id
FileSystem.Delete ->
pure id
pure $ flip (foldl' $ flip ($)) modelUpdates
render :: Ema.CLI.Action -> Model -> Route -> LByteString
render emaAction model r =
Tailwind.layoutWith "en" "UTF-8" (myTailwind emaAction) (H.title "Approximations of Truth" >> H.base ! A.href "/") $
H.div ! A.class_ "container mx-auto" $ do
H.div ! A.class_ "mt-8 p-2 text-center" $ do
case r of
Index -> do
H.toHtml (unModel model)
"You are on the index page. "
routeElem About "Go to about"
About -> do
"You are on the about page. "
routeElem Index "Go to Index"
NotFound -> "Page missing"
where
routeElem r' w =
H.a ! A.class_ "text-blue-500 hover:underline" ! routeHref r' $ w
routeHref r' =
A.href (fromString . toString $ Ema.routeUrl model r')
Tailwind.layoutWith "en" "UTF-8" (myTailwind emaAction) (H.title "Approximations of Truth" >> H.base ! A.href "/") $
H.div ! A.class_ "container mx-auto" $ do
H.div ! A.class_ "mt-8 p-2 text-center" $ do
case r of
Page pageName
| Just (_, pandoc) <- Map.lookup pageName model ->
fromRight (error [i|Pandoc error for #{pageName}|]) (runPure (writeHtml5 def pandoc))
err -> error [i|Cant render route #{err}|]
where
routeElem r' w =
H.a ! A.class_ "text-blue-500 hover:underline" ! routeHref r' $ w
routeHref r' =
A.href (fromString . toString $ Ema.routeUrl model r')
myTailwind = \case
Ema.CLI.Generate _ ->
H.link
! A.href "/tailwind.css"
! A.rel "stylesheet"
! A.type_ "text/css"
_ -> Tailwind.twindShimCdn
Ema.CLI.Generate _ ->
H.link
! A.href "/tailwind.css"
! A.rel "stylesheet"
! A.type_ "text/css"
_ -> Tailwind.twindShimCdn

View File

@ -9,25 +9,21 @@ author: Malte Brandy
executable run-ema
build-depends:
, aeson
, async
, base
, blaze-html
, blaze-markup
, containers
, data-default
, directory
, ema >=0.2
, filepath
, lvar
, monad-logger
, neat-interpolation
, string-interpolate
, pandoc-types
, pandoc
, relude
, shower
, tagged
, text
, time
, unliftio
ghc-options:
-Wall -Wincomplete-record-updates -Wincomplete-uni-patterns