reciproka-web/site.hs

199 lines
7.6 KiB
Haskell
Raw Normal View History

2021-10-27 06:24:02 +00:00
--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
2021-11-02 22:14:48 +00:00
import Data.Monoid (mappend)
import Data.List (sortBy)
import Data.Ord (comparing)
2021-10-27 06:24:02 +00:00
import Hakyll
2021-11-02 22:14:48 +00:00
import Control.Monad (liftM, forM_)
import System.FilePath (takeBaseName)
2021-10-27 06:24:02 +00:00
--------------------------------------------------------------------------------
main :: IO ()
main = hakyll $ do
2021-11-02 22:14:48 +00:00
match ("images/*" .||. "js/*") $ do
2021-10-27 06:24:02 +00:00
route idRoute
compile copyFileCompiler
match "css/*" $ do
route idRoute
compile compressCssCompiler
2021-11-02 22:14:48 +00:00
match "error/*" $ do
route $ (gsubRoute "error/" (const "") `composeRoutes` setExtension "html")
2021-10-27 06:24:02 +00:00
compile $ pandocCompiler
2021-11-02 22:14:48 +00:00
>>= 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
2021-10-27 06:24:02 +00:00
match "posts/*" $ do
route $ setExtension "html"
2021-11-02 22:14:48 +00:00
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
2021-10-27 06:24:02 +00:00
create ["archive.html"] $ do
route idRoute
compile $ do
2021-11-02 22:14:48 +00:00
posts <- recentFirst =<< loadAllSnapshots ("posts/*" .&&. hasNoVersion) "content"
2021-10-27 06:24:02 +00:00
let archiveCtx =
listField "posts" postCtx (return posts) `mappend`
2021-11-02 22:14:48 +00:00
constField "title" "Archive" `mappend`
constField "archive" "" `mappend`
siteCtx
2021-10-27 06:24:02 +00:00
makeItem ""
>>= loadAndApplyTemplate "templates/archive.html" archiveCtx
2021-11-02 22:14:48 +00:00
>>= loadAndApplyTemplate "templates/default.html" (baseSidebarCtx <> archiveCtx)
2021-10-27 06:24:02 +00:00
>>= relativizeUrls
2021-11-02 22:14:48 +00:00
paginate <- buildPaginateWith postsGrouper "posts/*" postsPageId
2021-10-27 06:24:02 +00:00
2021-11-02 22:14:48 +00:00
paginateRules paginate $ \page pattern -> do
route idRoute
2021-10-27 06:24:02 +00:00
compile $ do
2021-11-02 22:14:48 +00:00
posts <- recentFirst =<< loadAllSnapshots (pattern .&&. hasNoVersion) "content"
2021-10-27 06:24:02 +00:00
let indexCtx =
2021-11-02 22:14:48 +00:00
constField "title" (if page == 1 then "Home"
else "Blog posts, page " ++ show page) `mappend`
2021-10-27 06:24:02 +00:00
listField "posts" postCtx (return posts) `mappend`
2021-11-02 22:14:48 +00:00
constField "home" "" `mappend`
paginateContext paginate page `mappend`
siteCtx
2021-10-27 06:24:02 +00:00
2021-11-02 22:14:48 +00:00
makeItem ""
2021-10-27 06:24:02 +00:00
>>= applyAsTemplate indexCtx
2021-11-02 22:14:48 +00:00
>>= loadAndApplyTemplate "templates/index.html" indexCtx
>>= loadAndApplyTemplate "templates/default.html" (baseSidebarCtx <> indexCtx)
2021-10-27 06:24:02 +00:00
>>= relativizeUrls
match "templates/*" $ compile templateBodyCompiler
2021-11-02 22:14:48 +00:00
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
2021-10-27 06:24:02 +00:00
--------------------------------------------------------------------------------
2021-11-02 22:14:48 +00:00
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 = "JFDI Collective"
2021-11-04 00:49:38 +00:00
, feedDescription = "liberation, autonomy, privacy"
2021-11-02 22:14:48 +00:00
, feedAuthorName = "JFDI Collective"
, feedAuthorEmail = "collective@jfdic.org"
, feedRoot = "https://jfdic.org"
}
--------------------------------------------------------------------------------
siteCtx :: Context String
siteCtx =
baseCtx `mappend`
constField "site_description" "JFDI Collective" `mappend`
constField "site-url" "https://jfdic.org" `mappend`
2021-11-04 00:49:38 +00:00
constField "tagline" "liberation, autonomy, privacy" `mappend`
2021-11-02 22:14:48 +00:00
constField "site-title" "JFDI Collective" `mappend`
constField "copy-year" "2021" `mappend`
constField "github-repo" "https://source.jfdic.org/jfdic/jfdic-web" `mappend`
defaultContext
baseCtx =
2021-11-16 10:04:45 +00:00
constField "baseurl" "https://jfdic.org"
2021-11-02 22:14:48 +00:00
--------------------------------------------------------------------------------
2021-10-27 06:24:02 +00:00
postCtx :: Context String
postCtx =
dateField "date" "%B %e, %Y" `mappend`
defaultContext
2021-11-02 22:14:48 +00:00
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