From 639f8749fdb6a4a39b66ad0bb18e8c87757abae1 Mon Sep 17 00:00:00 2001 From: Vibrant C3PO Date: Thu, 25 Nov 2021 16:37:11 +1000 Subject: [PATCH] site: initial commit --- site.hs | 198 ++++++++++++++++++++++++++++++++++++++++++++++++++ voc-web.cabal | 14 ++++ 2 files changed, 212 insertions(+) create mode 100644 site.hs create mode 100644 voc-web.cabal diff --git a/site.hs b/site.hs new file mode 100644 index 0000000..f414376 --- /dev/null +++ b/site.hs @@ -0,0 +1,198 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +import Data.Monoid (mappend) +import Data.List (sortBy) +import Data.Ord (comparing) +import Hakyll +import Control.Monad (liftM, forM_) +import System.FilePath (takeBaseName) + +-------------------------------------------------------------------------------- +main :: IO () +main = hakyll $ do + match ("images/*" .||. "js/*") $ do + route idRoute + compile copyFileCompiler + + match "css/*" $ do + route idRoute + compile compressCssCompiler + + match "error/*" $ do + route $ (gsubRoute "error/" (const "") `composeRoutes` setExtension "html") + compile $ pandocCompiler + >>= applyAsTemplate siteCtx + >>= loadAndApplyTemplate "templates/default.html" (baseSidebarCtx <> siteCtx) + + match "pages/*" $ do + route $ setExtension "html" + compile $ do + pageName <- takeBaseName . toFilePath <$> getUnderlying + let pageCtx = constField pageName "" `mappend` + baseNodeCtx + let evalCtx = functionField "get-meta" getMetadataKey `mappend` + functionField "eval" (evalCtxKey pageCtx) + let activeSidebarCtx = sidebarCtx (evalCtx <> pageCtx) + + pandocCompiler + >>= saveSnapshot "page-content" + >>= loadAndApplyTemplate "templates/page.html" siteCtx + >>= loadAndApplyTemplate "templates/default.html" (activeSidebarCtx <> siteCtx) + >>= relativizeUrls + + tags <- buildTags "posts/*" (fromCapture "tags/*.html") + + match "posts/*" $ version "meta" $ do + route $ setExtension "html" + compile getResourceBody + + match "posts/*" $ do + route $ setExtension "html" + compile $ do + posts <- loadAll ("posts/*" .&&. hasVersion "meta") + let taggedPostCtx = (tagsField "tags" tags) `mappend` + postCtx `mappend` + (relatedPostsCtx posts 3) + + pandocCompiler + >>= saveSnapshot "content" + >>= loadAndApplyTemplate "templates/post.html" taggedPostCtx + >>= loadAndApplyTemplate "templates/default.html" (baseSidebarCtx <> siteCtx) + >>= relativizeUrls + + create ["archive.html"] $ do + route idRoute + compile $ do + posts <- recentFirst =<< loadAllSnapshots ("posts/*" .&&. hasNoVersion) "content" + let archiveCtx = + listField "posts" postCtx (return posts) `mappend` + constField "title" "Archive" `mappend` + constField "archive" "" `mappend` + siteCtx + + makeItem "" + >>= loadAndApplyTemplate "templates/archive.html" archiveCtx + >>= loadAndApplyTemplate "templates/default.html" (baseSidebarCtx <> archiveCtx) + >>= relativizeUrls + + paginate <- buildPaginateWith postsGrouper "posts/*" postsPageId + + paginateRules paginate $ \page pattern -> do + route idRoute + compile $ do + posts <- recentFirst =<< loadAllSnapshots (pattern .&&. hasNoVersion) "content" + let indexCtx = + constField "title" (if page == 1 then "Home" + else "Blog posts, page " ++ show page) `mappend` + listField "posts" postCtx (return posts) `mappend` + constField "home" "" `mappend` + paginateContext paginate page `mappend` + siteCtx + + makeItem "" + >>= applyAsTemplate indexCtx + >>= loadAndApplyTemplate "templates/index.html" indexCtx + >>= loadAndApplyTemplate "templates/default.html" (baseSidebarCtx <> indexCtx) + >>= relativizeUrls + + match "templates/*" $ compile templateBodyCompiler + + create ["atom.xml"] $ do + route idRoute + compile $ do + let feedCtx = postCtx `mappend` + bodyField "description" + posts <- fmap (take 10) . recentFirst =<< loadAllSnapshots ("posts/*" .&&. hasNoVersion) "content" + renderAtom feedConfig feedCtx posts + +-------------------------------------------------------------------------------- + +postsGrouper :: MonadFail m => MonadMetadata m => [Identifier] -> m [[Identifier]] +postsGrouper = liftM (paginateEvery 3) . sortRecentFirst + + +postsPageId :: PageNumber -> Identifier +postsPageId n = fromFilePath $ if (n == 1) then "index.html" else show n ++ "/index.html" + +-------------------------------------------------------------------------------- + +feedConfig :: FeedConfiguration +feedConfig = FeedConfiguration + { feedTitle = "Voices of Capricornia" + , feedDescription = "Be Heard" + , feedAuthorName = "Voices of Capricornia" + , feedAuthorEmail = "collective@voicesofcapricornia.org" + , feedRoot = "https://voicesofcapricornia.org" + } + +-------------------------------------------------------------------------------- + +siteCtx :: Context String +siteCtx = + baseCtx `mappend` + constField "site_description" "Voices of Capricornia" `mappend` + constField "site-url" "https://voicesofcapricornia.org" `mappend` + constField "tagline" "Be Heard" `mappend` + constField "site-title" "Voices of Capricornia" `mappend` + constField "copy-year" "2021" `mappend` + constField "github-repo" "https://source.jfdic.org/voc/voc-web" `mappend` + defaultContext + +baseCtx = + constField "baseurl" "https://voicesofcapricornia.org" + +-------------------------------------------------------------------------------- + +postCtx :: Context String +postCtx = + dateField "date" "%B %e, %Y" `mappend` + defaultContext + +tagsRulesVersioned tags rules = + forM_ (tagsMap tags) $ \(tag, identifiers) -> + rulesExtraDependencies [tagsDependency tags] $ + create [tagsMakeId tags tag] $ + rules tag identifiers + +relatedPostsCtx + :: [Item String] -> Int -> Context String +relatedPostsCtx posts n = listFieldWith "related_posts" postCtx selectPosts + where + rateItem ts i = length . filter (`elem` ts) <$> (getTags $ itemIdentifier i) + selectPosts s = do + postTags <- getTags $ itemIdentifier s + let trimmedItems = filter (not . matchPath s) posts + take n . reverse <$> sortOnM (rateItem postTags) trimmedItems + +matchPath :: Item String -> Item String -> Bool +matchPath x y = eqOn (toFilePath . itemIdentifier) x y + +eqOn :: Eq b => (a -> b) -> a -> a -> Bool +eqOn f x y = f x == f y + +sortOnM :: (Monad m, Ord b) => (a -> m b) -> [a] -> m [a] +sortOnM f xs = map fst . sortBy (comparing snd) . zip xs <$> mapM f xs + +-------------------------------------------------------------------------------- + +sidebarCtx :: Context String -> Context String +sidebarCtx nodeCtx = + listField "list_pages" nodeCtx (loadAllSnapshots ("pages/*" .&&. hasNoVersion) "page-content") `mappend` + defaultContext + +baseNodeCtx :: Context String +baseNodeCtx = + urlField "node-url" `mappend` + titleField "title" `mappend` + baseCtx + +baseSidebarCtx = sidebarCtx baseNodeCtx + +evalCtxKey :: Context String -> [String] -> Item String -> Compiler String +evalCtxKey context [key] item = (unContext context key [] item) >>= \cf -> + case cf of + StringField s -> return s + _ -> error $ "Internal error: StringField expected" + +getMetadataKey :: [String] -> Item String -> Compiler String +getMetadataKey [key] item = getMetadataField' (itemIdentifier item) key diff --git a/voc-web.cabal b/voc-web.cabal new file mode 100644 index 0000000..4d0ef79 --- /dev/null +++ b/voc-web.cabal @@ -0,0 +1,14 @@ +name: voc-web +version: 0.1.0.0 +build-type: Simple +cabal-version: >= 1.10 + +executable site + main-is: site.hs + build-depends: base == 4.* + , hakyll == 4.14.* + , containers == 0.6.* + , filepath == 1.4.* + , pandoc + ghc-options: -threaded + default-language: Haskell2010