Save status-quo

content/posts/studien.md

@@ -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?“

content/special/index.md

@@ -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.

fourmolu.yaml

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

generator/Main.hs

@@ -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|Can‘t 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

generator/maralorn-de.cabal

@@ -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