Format og:description without tags if teaser is given

1 files changed, 46 insertions, 22 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 7dff99a..c5c9f09 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -4,7 +4,7 @@
 module Main where
 
 import Control.Monad (forM)
-import Data.List (isPrefixOf, isSuffixOf, isInfixOf)
+import Data.List (isPrefixOf, isSuffixOf)
 import Data.Time.Format (TimeLocale(..))
 import Hakyll.Core.Compiler
     ( Compiler
@@ -132,7 +132,7 @@ createIndex tags = createPaginatedPage indexRules "posts/**" ""
         compile $ do
             posts <- recentFirst =<< loadAllSnapshots pagePattern "content"
             let context
-                    = listField "posts" (postCtx tags) (pure posts)
+                    = listField "posts" previewContext (pure posts)
                     <> constField "title" "Startseite"
                     <> boolField "active-blog" (const True)
                     <> paginateContext paginate pageNumber
@@ -184,28 +184,49 @@ teaserDescriptionField = field "teaser" withItem
             >>= withMetadataField itemIdentifier'
     paragraphMap "" = "</p><p>"
     paragraphMap paragraph = paragraph
-    withMetadataField _ (Just teaser)
-        | "<p>" `isInfixOf` teaser = pure teaser
-        | otherwise = pure $ "<p>"
-            <> unlines (paragraphMap <$> lines teaser)
-            <> "</p>"
+    withMetadataField _ (Just teaser) = pure $ "<p>"
+        <> unlines (paragraphMap <$> lines teaser)
+        <> "</p>"
     withMetadataField itemIdentifier' Nothing = fail
         $ "No teaser defined for " <> show itemIdentifier'
 
-postCtx :: Tags -> Context String
-postCtx tags
-    = dateFieldWith localizedTimeLocale "published" "%e. %B %Y"
+-- og:description meta tag content.
+teaserMetaField :: Context String
+teaserMetaField = field "teaser" withItem
+  where
+    withItem item =
+        let itemIdentifier' = itemIdentifier item
+         in getMetadataField itemIdentifier' "teaser"
+            >>= withMetadataField itemIdentifier'
+    paragraphFolder ("", True) paragraph = (paragraph, True)
+    paragraphFolder (accumulator, True) "" = (accumulator, False)
+    paragraphFolder (accumulator, True) paragraph =
+        (accumulator <> " " <> paragraph, True)
+    paragraphFolder (accumulator, False) _ = (accumulator, False)
+    withMetadataField _ (Just teaser) = pure
+        $ fst
+        $ foldl' paragraphFolder ("", True)
+        $ lines teaser
+    withMetadataField itemIdentifier' Nothing = fail
+        $ "No teaser defined for " <> show itemIdentifier'
+
+publishedOnField :: forall a. Context a
+publishedOnField =
+    dateFieldWith localizedTimeLocale "published" "%e. %B %Y"
+
+previewContext :: Context String
+previewContext
+    = publishedOnField
     <> teaserDescriptionField
-    <> flevumContext tags
+    <> defaultContext
 
 flevumContext :: Tags -> Context String
 flevumContext = (<> defaultContext) . tagsCloud
-
-tagsCloud :: Tags -> Context String
-tagsCloud tags
-    = listFieldWith "categories" (Context categoryContextF)
-    $ forM (tagsMap tags) . go
   where
+    tagsCloud :: Tags -> Context String
+    tagsCloud tags
+        = listFieldWith "categories" (Context categoryContextF)
+        $ forM (tagsMap tags) . go tags
     categoryContextF "title" _ = pure . StringField . categoryTitle
     categoryContextF "url" _ = pure . StringField
         . ('/' :) . (++ "/") . categoryTitle
@@ -213,8 +234,8 @@ tagsCloud tags
     categoryContextF key _ = const $ noResult $ "Tried field " ++ key
     categoryTitle = last . directoryNames . itemIdentifier
     directoryNames = init . splitDirectories . toFilePath
-    go :: Item String -> (String, [Identifier]) -> Compiler (Item FilePath)
-    go Item{ itemIdentifier = currentPage } (tag, _) = do
+    go :: Tags -> Item String -> (String, [Identifier]) -> Compiler (Item FilePath)
+    go tags Item{ itemIdentifier = currentPage } (tag, _) = do
         let tagId = tagsMakeId tags tag
         tagsMetadata <- getMetadataField currentPage "tags"
         let isActiveClass = directoryNames currentPage == directoryNames tagId
@@ -269,7 +290,7 @@ createTagPage tags tagName tagPattern
         route withoutRootRoute
         compile $ do
             posts <- recentFirst =<< loadAllSnapshots pagePattern "content"
-            let context = listField "posts" (postCtx tags) (pure posts)
+            let context = listField "posts" previewContext (pure posts)
                     <> constField "title" tagName
                     <> paginateContext paginate pageNumber
                     <> flevumContext tags
@@ -317,7 +338,6 @@ styles = traverse load
 rules :: Rules ()
 rules = do
     tags <- buildTags "posts/**" (fromCapture "tags/*/index.html")
-    let contextWithTags = flevumContext tags
 
     -- Home page.
     createIndex tags
@@ -326,17 +346,21 @@ rules = do
     match "pages/*.tex" $ do
         route withoutRootRoute
         compile $ bibtexCompiler
-            >>= loadAndApplyLayout "page.html" contextWithTags
+            >>= loadAndApplyLayout "page.html" (flevumContext tags)
 
     -- Categories.
     tagsRules tags $ createTagPage tags
 
     -- Blog posts.
+    let postContext = publishedOnField
+            <> teaserMetaField
+            <> flevumContext tags
+
     match "posts/**.tex" $ do
         route withoutRootRoute
         compile $ bibtexCompiler
             >>= saveSnapshot "content"
-            >>= loadAndApplyLayout "post.html" (postCtx tags)
+            >>= loadAndApplyLayout "post.html" postContext
 
     match "assets/bibliography/*.bib" $ compile biblioCompiler
     match "assets/bibliography/*.csl" $ compile cslCompiler