natto1784/nattopages
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

src: format

Browse Source 
Signed-off-by: Amneesh Singh <natto@weirdnatto.in>
This commit is contained in:
Amneesh Singh
2023-08-26 20:45:10 +05:30
parent 7cb266782d
commit ba247f88d4
1 changed files with 164 additions and 164 deletions
Download Patch File Download Diff File Expand all files Collapse all files

328
src/Main.hs
View File

@@ -6,240 +6,240 @@ import Data.Maybe (isJust)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Hakyll import Hakyll
import System.Environment (getEnv)
import System.FilePath (replaceDirectory, replaceExtension, takeDirectory) import System.FilePath (replaceDirectory, replaceExtension, takeDirectory)
import System.IO.Unsafe (unsafePerformIO)
import qualified System.Process as Process import qualified System.Process as Process
import Text.Pandoc import Text.Pandoc (
( WriterOptions WriterOptions (
( writerHighlightStyle, writerHighlightStyle,
writerNumberSections, writerNumberSections,
writerTOCDepth, writerTOCDepth,
writerTableOfContents, writerTableOfContents,
writerTemplate writerTemplate
), ),
) )
import qualified Text.Pandoc as Pandoc import qualified Text.Pandoc as Pandoc
import Text.Pandoc.Templates (Template, compileTemplate) import Text.Pandoc.Templates (Template, compileTemplate)
import System.Environment (getEnv)
import System.IO.Unsafe (unsafePerformIO)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
main :: IO () main :: IO ()
main = hakyllWith config $ do main = hakyllWith config $ do
let individualPatterns = fromList ["about.org", "contact.org", "links.org", "documents/cv.org"] let individualPatterns = fromList ["about.org", "contact.org", "links.org", "documents/cv.org"]
let copyPatterns = fromList ["images/**", "fonts/*", "documents/*"] let copyPatterns = fromList ["images/**", "fonts/*", "documents/*"]
match "images/**" $ do match "images/**" $ do
route idRoute route idRoute
compile copyFileCompiler compile copyFileCompiler
match "fonts/*" $ do match "fonts/*" $ do
route idRoute route idRoute
compile copyFileCompiler compile copyFileCompiler
match "css/*" $ do match "css/*" $ do
route idRoute route idRoute
compile compressCssCompiler compile compressCssCompiler
match "*pdf" $ do match "*pdf" $ do
route idRoute route idRoute
match individualPatterns $ do match individualPatterns $ do
route $ setExtension "html" route $ setExtension "html"
compile $ compile $
pandocCompiler pandocCompiler
>>= loadAndApplyTemplate "templates/default.html" defaultCtx >>= loadAndApplyTemplate "templates/default.html" defaultCtx
>>= relativizeUrls >>= relativizeUrls
-- kindly stolen from https://github.com/jaspervdj/jaspervdj/blob/b2a9a34cd2195c6e216b922e152c42266dded99d/src/Main.hs#L163-L169 -- kindly stolen from https://github.com/jaspervdj/jaspervdj/blob/b2a9a34cd2195c6e216b922e152c42266dded99d/src/Main.hs#L163-L169
-- also see helper functions writeXetex and xelatex -- also see helper functions writeXetex and xelatex
match "documents/cv.org" $ match "documents/cv.org" $
version "pdf" $ do version "pdf" $ do
route $ setExtension "pdf" route $ setExtension "pdf"
compile $ compile $
getResourceBody getResourceBody
>>= readPandoc >>= readPandoc
>>= writeXeTex >>= writeXeTex
>>= loadAndApplyTemplate "templates/cv.tex" defaultCtx >>= loadAndApplyTemplate "templates/cv.tex" defaultCtx
>>= xelatex >>= xelatex
tags <- buildTags "posts/*" (fromCapture "archive/tags/*.html") tags <- buildTags "posts/*" (fromCapture "archive/tags/*.html")
tagsRules tags $ \tag pattern -> do tagsRules tags $ \tag pattern -> do
let title = "Posts tagged \"" ++ tag ++ "\"" let title = "Posts tagged \"" ++ tag ++ "\""
route idRoute route idRoute
compile $ do compile $ do
posts <- recentFirst =<< loadAll pattern posts <- recentFirst =<< loadAll pattern
let tagCtx = let tagCtx =
constField "title" title constField "title" title
<> constField "tag" tag <> constField "tag" tag
<> listField "posts" (postCtx tags) (return posts) <> listField "posts" (postCtx tags) (return posts)
<> defaultCtx <> defaultCtx
makeItem "" makeItem ""
>>= loadAndApplyTemplate "templates/tag.html" tagCtx >>= loadAndApplyTemplate "templates/tag.html" tagCtx
>>= loadAndApplyTemplate "templates/default.html" tagCtx >>= loadAndApplyTemplate "templates/default.html" tagCtx
>>= relativizeUrls >>= relativizeUrls
match "posts/*org" $ do match "posts/*org" $ do
route $ setExtension "html" route $ setExtension "html"
compile $ do compile $ do
identifier <- getUnderlying identifier <- getUnderlying
toc <- getMetadataField identifier "enabletoc" toc <- getMetadataField identifier "enabletoc"
numbering <- getMetadataField identifier "enablenumbering" numbering <- getMetadataField identifier "enablenumbering"
let writerOptions' = maybe defaultHakyllWriterOptions (const $ writerOptions $ isJust numbering) toc let writerOptions' = maybe defaultHakyllWriterOptions (const $ writerOptions $ isJust numbering) toc
pandocCompilerWith defaultHakyllReaderOptions writerOptions' pandocCompilerWith defaultHakyllReaderOptions writerOptions'
>>= saveSnapshot "content" >>= saveSnapshot "content"
>>= loadAndApplyTemplate "templates/post.html" (postCtx tags) >>= loadAndApplyTemplate "templates/post.html" (postCtx tags)
>>= loadAndApplyTemplate "templates/default.html" (postCtx tags) >>= loadAndApplyTemplate "templates/default.html" (postCtx tags)
>>= relativizeUrls >>= relativizeUrls
create ["archive.html"] $ do create ["archive.html"] $ do
route idRoute route idRoute
compile $ do compile $ do
posts <- recentFirst =<< loadAll "posts/*" posts <- recentFirst =<< loadAll "posts/*"
let archiveCtx = let archiveCtx =
listField "posts" (postCtx tags) (return posts) listField "posts" (postCtx tags) (return posts)
<> constField "title" "Archives" <> constField "title" "Archives"
<> field "tags" (\_ -> renderTagList tags) <> field "tags" (\_ -> renderTagList tags)
<> defaultCtx <> defaultCtx
makeItem "" makeItem ""
>>= loadAndApplyTemplate "templates/archive.html" archiveCtx >>= loadAndApplyTemplate "templates/archive.html" archiveCtx
>>= loadAndApplyTemplate "templates/default.html" archiveCtx >>= loadAndApplyTemplate "templates/default.html" archiveCtx
>>= relativizeUrls >>= relativizeUrls
match "index.html" $ do match "index.html" $ do
route idRoute route idRoute
compile $ do compile $ do
let indexCtx = defaultCtx let indexCtx = defaultCtx
getResourceBody getResourceBody
>>= applyAsTemplate indexCtx >>= applyAsTemplate indexCtx
>>= loadAndApplyTemplate "templates/default.html" indexCtx >>= loadAndApplyTemplate "templates/default.html" indexCtx
>>= relativizeUrls >>= relativizeUrls
create ["rss.xml"] $ do create ["rss.xml"] $ do
route idRoute route idRoute
compile $ do compile $ do
let feedCtx = postCtx tags <> bodyField "description" let feedCtx = postCtx tags <> bodyField "description"
posts <- fmap (take 10) . recentFirst =<< loadAllSnapshots "posts/*" "content" posts <- fmap (take 10) . recentFirst =<< loadAllSnapshots "posts/*" "content"
renderRss rssFeedConfiguration feedCtx posts renderRss rssFeedConfiguration feedCtx posts
-- https://robertwpearce.com/hakyll-pt-2-generating-a-sitemap-xml-file.html -- https://robertwpearce.com/hakyll-pt-2-generating-a-sitemap-xml-file.html
create ["sitemap.xml"] $ do create ["sitemap.xml"] $ do
route idRoute route idRoute
compile $ do compile $ do
posts <- recentFirst =<< loadAll "posts/*" posts <- recentFirst =<< loadAll "posts/*"
individualPages <- loadAll individualPatterns individualPages <- loadAll individualPatterns
let pages = posts <> individualPages let pages = posts <> individualPages
sitemapCtx = sitemapCtx =
listField "pages" (postCtx tags) (return pages) listField "pages" (postCtx tags) (return pages)
<> defaultCtx <> defaultCtx
makeItem "" makeItem ""
>>= loadAndApplyTemplate "templates/sitemap.xml" sitemapCtx >>= loadAndApplyTemplate "templates/sitemap.xml" sitemapCtx
match "templates/*" $ compile templateBodyCompiler match "templates/*" $ compile templateBodyCompiler
where where
-- https://github.com/jaspervdj/jaspervdj/blob/b2a9a34cd2195c6e216b922e152c42266dded99d/src/Main.hs#L214-L218 -- https://github.com/jaspervdj/jaspervdj/blob/b2a9a34cd2195c6e216b922e152c42266dded99d/src/Main.hs#L214-L218
writeXeTex :: Item Pandoc.Pandoc -> Compiler (Item String) writeXeTex :: Item Pandoc.Pandoc -> Compiler (Item String)
writeXeTex = traverse $ \pandoc -> writeXeTex = traverse $ \pandoc ->
case Pandoc.runPure (Pandoc.writeLaTeX Pandoc.def pandoc) of case Pandoc.runPure (Pandoc.writeLaTeX Pandoc.def pandoc) of
Left err -> fail $ show err Left err -> fail $ show err
Right x -> return (T.unpack x) Right x -> return (T.unpack x)
-- https://github.com/jaspervdj/jaspervdj/blob/b2a9a34cd2195c6e216b922e152c42266dded99d/src/Main.hs#L280-L292 -- https://github.com/jaspervdj/jaspervdj/blob/b2a9a34cd2195c6e216b922e152c42266dded99d/src/Main.hs#L280-L292
-- but even more hacky -- but even more hacky
xelatex :: Item String -> Compiler (Item TmpFile) xelatex :: Item String -> Compiler (Item TmpFile)
xelatex item = do xelatex item = do
TmpFile texPath <- newTmpFile "xelatex.tex" TmpFile texPath <- newTmpFile "xelatex.tex"
let tmpDir = takeDirectory texPath let tmpDir = takeDirectory texPath
pdfPath = replaceExtension texPath "pdf" pdfPath = replaceExtension texPath "pdf"
unsafeCompiler $ do unsafeCompiler $ do
writeFile texPath $ itemBody item writeFile texPath $ itemBody item
let x = itemBody item let x = itemBody item
_ <- _ <-
Process.system $ Process.system $
unwords unwords
[ "xelatex", [ "xelatex"
"-halt-on-error", , "-halt-on-error"
"-output-directory", , "-output-directory"
tmpDir, , tmpDir
texPath, , texPath
">/dev/null", , ">/dev/null"
"2>&1" , "2>&1"
] ]
return () return ()
makeItem $ TmpFile pdfPath makeItem $ TmpFile pdfPath
rssFeedConfiguration :: FeedConfiguration rssFeedConfiguration :: FeedConfiguration
rssFeedConfiguration = rssFeedConfiguration =
FeedConfiguration FeedConfiguration
{ feedTitle = "nattopages", { feedTitle = "nattopages"
feedDescription = "Pages by natto", , feedDescription = "Pages by natto"
feedAuthorName = "Amneesh Singh", , feedAuthorName = "Amneesh Singh"
feedAuthorEmail = "natto@weirdnatto.in", , feedAuthorEmail = "natto@weirdnatto.in"
feedRoot = "https://weirdnatto.in" , feedRoot = "https://weirdnatto.in"
} }
config :: Configuration config :: Configuration
config = config =
defaultConfiguration defaultConfiguration
{ deployCommand = "rsync --checksum -ave 'ssh -p" ++ sshTargetPort ++"' _site/* " ++ sshTarget, { deployCommand = "rsync --checksum -ave 'ssh -p" ++ sshTargetPort ++ "' _site/* " ++ sshTarget
previewPort = 3333 , previewPort = 3333
} }
where where
{-# NOINLINE sshTarget#-} {-# NOINLINE sshTarget #-}
sshTarget = unsafePerformIO $ getEnv "SSHTARGET" sshTarget = unsafePerformIO $ getEnv "SSHTARGET"
{-# NOINLINE sshTargetPort#-} {-# NOINLINE sshTargetPort #-}
sshTargetPort = unsafePerformIO $ getEnv "SSHTARGETPORT" sshTargetPort = unsafePerformIO $ getEnv "SSHTARGETPORT"
postCtx :: Tags -> Context String postCtx :: Tags -> Context String
postCtx tags = postCtx tags =
tagsField "tags" tags tagsField "tags" tags
-- <> teaserFieldWithSeparator "((.tease.))" "teaser" "content" -- <> teaserFieldWithSeparator "((.tease.))" "teaser" "content"
<> dateField "date" "%B %e, %Y" <> dateField "date" "%B %e, %Y"
<> dateField "altdate" "%Y-%m-%d" <> dateField "altdate" "%Y-%m-%d"
<> teaserField "teaser" "content" <> teaserField "teaser" "content"
<> defaultCtx <> defaultCtx
defaultCtx :: Context String defaultCtx :: Context String
defaultCtx = defaultCtx =
listField "subdomains" subCtx (return subdomains) listField "subdomains" subCtx (return subdomains)
<> domainCtx <> domainCtx
<> defaultContext <> defaultContext
where where
domain :: String domain :: String
domain = "weirdnatto.in" domain = "weirdnatto.in"
subCtx :: Context String subCtx :: Context String
subCtx = subCtx =
field "name" (return . itemBody) field "name" (return . itemBody)
<> domainCtx <> domainCtx
domainCtx :: Context String domainCtx :: Context String
domainCtx = constField "domain" domain domainCtx = constField "domain" domain
subdomains :: [Item String] subdomains :: [Item String]
subdomains = map mkItem ["git", "radio", "f"] subdomains = map mkItem ["git", "radio", "f"]
where where
mkItem :: a -> Item a mkItem :: a -> Item a
mkItem a = Item {itemIdentifier = "subdomain", itemBody = a} mkItem a = Item{itemIdentifier = "subdomain", itemBody = a}
writerOptions :: Bool -> WriterOptions writerOptions :: Bool -> WriterOptions
writerOptions withNumbering = writerOptions withNumbering =
defaultHakyllWriterOptions defaultHakyllWriterOptions
{ writerNumberSections = withNumbering, { writerNumberSections = withNumbering
writerTableOfContents = True, , writerTableOfContents = True
writerTOCDepth = 2, , writerTOCDepth = 2
writerTemplate = Just tocTemplate , writerTemplate = Just tocTemplate
} }
tocTemplate :: Text.Pandoc.Templates.Template Text tocTemplate :: Text.Pandoc.Templates.Template Text
tocTemplate = tocTemplate =
either error id . runIdentity . compileTemplate "" $ either error id . runIdentity . compileTemplate "" $
T.unlines T.unlines
[ "<div class=\"toc\"><div class=\"toc-header\">Table of Contents</div>", [ "<div class=\"toc\"><div class=\"toc-header\">Table of Contents</div>"
"$toc$", , "$toc$"
"</div>", , "</div>"
"$body$" , "$body$"
] ]