Automate languages and routes without titles

- Language now defaults to english for posts
- Posts without a title gets a hash as its title

src/posts/2020-09-21-hello-world.md

@@ -4,7 +4,6 @@ authorTwitter: "@MyName"
 desc: "I announce myself to the world"
 image: "./images/waiheke-stony-batter.jpg"
 keywords: "hello, announcement"
-lang: "en"
 title: "Hello, world!"
 updated: "2020-09-22T12:00:00Z"
 ---

ssg/src/Formats/Gogen.hs

@@ -8,16 +8,7 @@ import Data.Maybe (fromMaybe)
 import Control.Applicative (empty)
 import Text.Regex.PCRE.Heavy (Regex, gsub, re)
 
-
+import Util.Hakyll.Context
-updateFieldWith :: String -> String -> (String -> String) -> Item a -> Compiler String
-updateFieldWith field defaultPreviousValue f = 
-  fmap updateField . getMetadata . itemIdentifier
-    where
-      updateField :: Metadata -> String
-      updateField = f . fromMaybe defaultPreviousValue . lookupString field
-
-ifField :: String -> (Item a -> Compiler ContextField) -> Context a
-ifField key value = Context $ \k _ i -> if k == key then value i else empty
 
 --------------------------------------------------------------------------------
 -- FURIGANA CONVERSION

ssg/src/Formats/Posts.hs

@@ -1 +1,13 @@
 module Formats.Posts where
+
+import Hakyll
+import Util.Hakyll.Routes
+import Data.Maybe (fromMaybe)
+import Util.Hash (FileHashes)
+import Debug.Trace
+
+postRoute :: FileHashes -> Routes
+postRoute hashes = titleRouteElseHash `composeRoutes` prefixRoute "posts/"
+  where
+    titleRouteElseHash :: Routes
+    titleRouteElseHash = metadataRoute $ \metadata -> fromMaybe (hashRoute hashes) $ titleRoute metadata

ssg/src/Main.hs

@@ -14,11 +14,16 @@ import Text.Pandoc
     writerExtensions,
   )
 import Text.Pandoc.Highlighting (Style, breezeDark, styleToCss)
+import Debug.Trace
+import Data.Map (mapKeys)
 
 -- ---------
 
 import Formats.Gogen
-import Util.Routes
+import Formats.Posts
+import Util.Hakyll.Routes
+import Util.Hakyll.Context
+import Util.Hash
 
 --------------------------------------------------------------------------------
 -- CONFIG
@@ -48,6 +53,8 @@ config =
 
 main :: IO ()
 main = hakyllWith config $ do
+  fileHashes <- preprocess (mapKeys (fromFilePath . drop 4 . toFilePath) <$> mkFileHashes "src/posts")
+
   forM_
     [ "CNAME"
     , "favicon.ico"
@@ -71,7 +78,8 @@ main = hakyllWith config $ do
   match "posts/*" $ do
     let ctx = constField "type" "article" <> postCtx
 
-    route $ metadataRoute titleRoute `composeRoutes` prefixRoute "posts/"
+    route $ postRoute fileHashes
+
     compile $
       pandocCompilerCustom
         >>= loadAndApplyTemplate "templates/post.html" ctx
@@ -160,6 +168,8 @@ feedCtx =
 postCtx :: Context String
 postCtx =
   constField "root" root
+    <> defaultConstField "lang" "en"
+    <> constField "author" "h7x4"
     <> constField "siteName" siteName
     <> dateField "date" "%Y-%m-%d"
     <> defaultContext

ssg/src/Util/Hakyll/Context.hs

@@ -0,0 +1,43 @@
+module Util.Hakyll.Context (
+  updateFieldWith,
+  defaultConstField,
+  ifField,
+) where
+
+import Hakyll
+import Data.Maybe (fromMaybe)
+import Control.Applicative (empty)
+
+
+{- |
+  Shortcut function for getting an Items Metadata
+  This is used as a helper function in a lot of places.
+-}
+getItemMetadata :: Item a -> Compiler Metadata
+getItemMetadata = getMetadata . itemIdentifier
+
+{- |
+-}
+updateFieldWith :: String -> String -> (String -> String) -> Item a -> Compiler String
+updateFieldWith field defaultPreviousValue f = 
+  fmap updateField . getMetadata . itemIdentifier
+    where
+      updateField :: Metadata -> String
+      updateField = f . fromMaybe defaultPreviousValue . lookupString field
+
+{- |
+  This function takes a field name, and a default String value.
+  If the field is found, it will leave it be, else inject the default value.
+  Similar to the behaviour of (fromMaybe)
+-}
+defaultConstField :: String -> String -> Context String
+defaultConstField fieldString defaultValue =
+  field fieldString (fmap f . getItemMetadata)
+    where
+      f :: Metadata -> String
+      f = fromMaybe defaultValue . lookupString fieldString
+
+{-
+-}
+ifField :: String -> (Item a -> Compiler ContextField) -> Context a
+ifField key value = Context $ \k _ i -> if k == key then value i else empty

ssg/src/Util/Hakyll/Routes.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Util.Hakyll.Routes where
+
+import Hakyll
+import Data.Maybe (fromMaybe)
+import Data.Map as Map
+import qualified Data.Text as T
+import qualified Data.Text.Slugger as Slugger
+import Debug.Trace
+
+import Util.Hash (FileHashes)
+
+prefixRoute :: FilePath -> Routes
+prefixRoute p = customRoute $ \id' -> p ++ toFilePath id'
+
+titleRouteWithDefault :: String -> Metadata -> Routes
+titleRouteWithDefault defaultValue = constRoute . fileNameFromTitle
+    where
+      getTitleFromMeta :: Metadata -> String
+      getTitleFromMeta =
+        fromMaybe defaultValue . lookupString "title"
+      
+      fileNameFromTitle :: Metadata -> FilePath
+      fileNameFromTitle =
+        T.unpack . (`T.append` ".html") . Slugger.toSlug . T.pack . getTitleFromMeta
+
+titleRoute :: Metadata -> Maybe Routes
+titleRoute metadata = constRoute <$> fileNameFromTitle metadata
+    where
+      slug :: String -> String
+      slug = T.unpack . (`T.append` ".html") . Slugger.toSlug . T.pack
+
+      ignore :: Eq a => a -> a -> Maybe a
+      ignore shouldBeIgnored value
+        | shouldBeIgnored == value = Nothing
+        | otherwise = Just value
+
+      fileNameFromTitle :: Metadata -> Maybe FilePath
+      fileNameFromTitle metadata = slug <$> (ignore "" =<< lookupString "title" metadata)
+
+
+hashRoute :: FileHashes -> Routes
+hashRoute hashes = customRoute hash 
+  where
+    hash :: Identifier -> String
+    hash = flip (++) ".html" . fromMaybe "error" . flip Map.lookup hashes 

ssg/src/Util/Hash.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE BangPatterns #-}
+
+module Util.Hash(
+  FileHashes,
+  mkFileHashes
+) where
+
+-- https://groups.google.com/g/hakyll/c/zdkQlDsj9lQ
+
+import Control.Monad (forM)
+import qualified Crypto.Hash.SHA256 as SHA256
+import qualified Data.ByteString.Base16 as Base16
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.ByteString.Lazy as BSL
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Hakyll
+import System.FilePath ((</>))
+import Debug.Trace
+
+type FileHashes = Map Identifier String
+
+mkFileHashes :: FilePath -> IO FileHashes
+mkFileHashes dir = do
+  allFiles <- getRecursiveContents (\_ -> return False) dir
+  fmap (Map.fromList . trace "MAPLISTS: " . traceShowId) $ forM allFiles $ \path0 -> do
+    let path1 = dir </> path0
+    !h <- hash $ trace ("HASHING: " ++ show path1) path1
+    return (fromFilePath path1, h)
+      where
+        hash :: FilePath -> IO String
+        hash fp = do
+          !h <- SHA256.hashlazy <$> BSL.readFile fp
+          return $! BS8.unpack $! Base16.encode h

ssg/src/Util/Routes.hs

@@ -1,23 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Util.Routes where
-
-import Hakyll
-import Data.Maybe (fromMaybe)
-import qualified Data.Text as T
-import qualified Data.Text.Slugger as Slugger
-
-prefixRoute :: FilePath -> Routes
-prefixRoute p = customRoute $ \id' -> p ++ (toFilePath id')
-
-
-titleRoute :: Metadata -> Routes
-titleRoute = constRoute . fileNameFromTitle
-    where
-      getTitleFromMeta :: Metadata -> String
-      getTitleFromMeta =
-        fromMaybe "no title" . lookupString "title"
-      
-      fileNameFromTitle :: Metadata -> FilePath
-      fileNameFromTitle =
-        T.unpack . (`T.append` ".html") . Slugger.toSlug . T.pack . getTitleFromMeta

ssg/ssg.cabal

@@ -7,13 +7,18 @@ license:             BSD-3-Clause
 license-file:        LICENSE
 
 executable hakyll-site
-  main-is:           Main.hs
+  main-is:          Main.hs
-  hs-source-dirs:    src
+  hs-source-dirs:   src
-  build-depends:     base >= 4.8
+  build-depends:    base >= 4.8
-                   , hakyll >= 4.15
+                  , hakyll >= 4.15
-                   , pandoc == 2.14.*
+                  , pandoc == 2.14.*
-                   , slugger >= 0.1.0.1
+                  , slugger >= 0.1.0.1
-                   , text >= 1.2
+                  , text >= 1.2
-                   , pcre-heavy >= 1.0.0.2
+                  , pcre-heavy >= 1.0.0.2
-  ghc-options:       -Wall -threaded
+                  , filepath >= 1.4.2.1
-  default-language:  Haskell2010
+                  , bytestring >= 0.10.10.1
+                  , base16-bytestring >= 1.0.2.0
+                  , containers >= 0.6.2.1
+                  , cryptohash-sha256 >= 0.11.102.1
+  ghc-options:      -Wall -threaded -dynamic
+  default-language: Haskell2010