diff --git a/src/posts/2020-09-21-hello-world.md b/src/posts/2020-09-21-hello-world.md index 6fb6b67..c494c48 100644 --- a/src/posts/2020-09-21-hello-world.md +++ b/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" --- diff --git a/ssg/src/Formats/Gogen.hs b/ssg/src/Formats/Gogen.hs index 2f158eb..3442d6b 100644 --- a/ssg/src/Formats/Gogen.hs +++ b/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) - -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 +import Util.Hakyll.Context -------------------------------------------------------------------------------- -- FURIGANA CONVERSION diff --git a/ssg/src/Formats/Posts.hs b/ssg/src/Formats/Posts.hs index e5dd913..334d98a 100644 --- a/ssg/src/Formats/Posts.hs +++ b/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 diff --git a/ssg/src/Main.hs b/ssg/src/Main.hs index 3164d29..d6e08f1 100644 --- a/ssg/src/Main.hs +++ b/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 diff --git a/ssg/src/Util/Hakyll/Context.hs b/ssg/src/Util/Hakyll/Context.hs new file mode 100644 index 0000000..b5db58b --- /dev/null +++ b/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 diff --git a/ssg/src/Util/Hakyll/Routes.hs b/ssg/src/Util/Hakyll/Routes.hs new file mode 100644 index 0000000..111974f --- /dev/null +++ b/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 diff --git a/ssg/src/Util/Hash.hs b/ssg/src/Util/Hash.hs new file mode 100644 index 0000000..fdc252f --- /dev/null +++ b/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 diff --git a/ssg/src/Util/Routes.hs b/ssg/src/Util/Routes.hs deleted file mode 100644 index e6ddd07..0000000 --- a/ssg/src/Util/Routes.hs +++ /dev/null @@ -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 diff --git a/ssg/ssg.cabal b/ssg/ssg.cabal index d526f57..0898dd2 100644 --- a/ssg/ssg.cabal +++ b/ssg/ssg.cabal @@ -7,13 +7,18 @@ license: BSD-3-Clause license-file: LICENSE executable hakyll-site - main-is: Main.hs - hs-source-dirs: src - build-depends: base >= 4.8 - , hakyll >= 4.15 - , pandoc == 2.14.* - , slugger >= 0.1.0.1 - , text >= 1.2 - , pcre-heavy >= 1.0.0.2 - ghc-options: -Wall -threaded - default-language: Haskell2010 + main-is: Main.hs + hs-source-dirs: src + build-depends: base >= 4.8 + , hakyll >= 4.15 + , pandoc == 2.14.* + , slugger >= 0.1.0.1 + , text >= 1.2 + , pcre-heavy >= 1.0.0.2 + , filepath >= 1.4.2.1 + , 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