You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

497 lines
17 KiB

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
import Protolude
import Development.Shake
import Development.Shake.FilePath
import Data.Time.Format.ISO8601 (iso8601Show)
import qualified Data.Time.Clock as Clock
import Control.Monad.Fail
import Data.Aeson
import Data.Default ( Default(def) )
import qualified Data.Text as T
import Text.Mustache
import Text.Pandoc.Class (PandocMonad)
import qualified Text.Pandoc.Class as Pandoc
import Text.Pandoc.Definition ( Pandoc(..)
, Block(..)
, Inline(..)
, MetaValue(..)
, nullMeta
, docTitle
, docDate
, docAuthors
, lookupMeta
)
import Text.Pandoc.Options ( ReaderOptions(..)
, WriterOptions(..)
, ObfuscationMethod(..)
, HTMLMathMethod(..)
)
import qualified Text.Pandoc.Readers as Readers
import Text.Pandoc.Walk (Walkable(..))
import qualified Text.Pandoc.Writers as Writers
import qualified Text.Pandoc.Templates as Templates
main :: IO ()
main = shakeArgs shOpts buildRules
where
shOpts =
shakeOptions
{ shakeVerbosity = Chatty
, shakeLintInside = ["\\"]
}
-- Configuration
-- Should probably go in a Reader Monad
srcDir :: FilePath
srcDir = "src"
siteDir :: FilePath
siteDir = "_site"
optimDir :: FilePath
optimDir = "_optim"
-- BlogPost data structure (a bit of duplication because the metas are in Pandoc)
data BlogPost =
BlogPost { postTitle :: T.Text
, postDate :: T.Text
, postAuthor :: T.Text
, postUrl :: FilePath
, postSrc :: FilePath
, postTags :: [T.Text]
, postDescr :: T.Text
, postToc :: Bool
, postBody :: Pandoc
}
inlineToText :: PandocMonad m => [Inline] -> m T.Text
inlineToText inline =
Writers.writeAsciiDoc def (Pandoc nullMeta [Plain inline])
reformatDate :: Text -> Text
reformatDate = T.takeWhile (/= ' ') . (T.dropAround dateEnvelope)
where
dateEnvelope ' ' = True
dateEnvelope '\n' = True
dateEnvelope '\t' = True
dateEnvelope '[' = True
dateEnvelope ']' = True
dateEnvelope _ = False
getBlogpostFromMetas
:: (MonadIO m, MonadFail m) => [Char] -> Bool -> Pandoc -> m BlogPost
getBlogpostFromMetas path toc pandoc@(Pandoc meta _) = do
eitherBlogpost <- liftIO $ Pandoc.runIO $ do
title <- fmap (T.dropEnd 1) $ inlineToText $ docTitle meta
date <- fmap reformatDate $ inlineToText $ docDate meta
author <- case head $ docAuthors meta of
Just m -> fmap T.strip $ inlineToText m
Nothing -> return ""
let tags = tagsToList $ lookupMeta "keywords" meta
description = descr $ lookupMeta "description" meta
url = "/" </> dropDirectory1 path -<.> "org"
return $ BlogPost title date author url path tags description toc pandoc
case eitherBlogpost of
Left _ -> fail "BAD"
Right bp -> return bp
where
tagsToList (Just (MetaList ms)) = map toStr ms
tagsToList _ = []
descr (Just (MetaString t)) = t
descr _ = ""
toStr (MetaString t) = t
toStr (MetaInlines inlines) = T.intercalate " " $ map inlineToTxt inlines
toStr _ = ""
inlineToTxt (Str t) = t
inlineToTxt _ = ""
sortByPostDate :: [BlogPost] -> [BlogPost]
sortByPostDate =
sortBy (\a b-> compare (postDate b) (postDate a))
build :: FilePath -> FilePath
build = (</>) siteDir
genAllDeps :: [FilePattern] -> Action [FilePath]
genAllDeps patterns = do
allMatchedFiles <- getDirectoryFiles srcDir patterns
allMatchedFiles &
filter ((/= "html") . takeExtension) &
filter (null . takeExtension) &
map (siteDir </>) &
return
buildRules :: Rules ()
buildRules = do
cleanRule
fastRule
allRule
fullRule
getPost <- mkGetPost
getPosts <- mkGetPosts getPost
getTemplate <- mkGetTemplate
build "**" %> \out -> do
let asset = dropDirectory1 out
case (takeExtension asset) of
".html" -> do
if out == siteDir </> "index.html"
then buildArchive getPosts getTemplate out
else genHtmlAction getPost getTemplate out
".pdf" -> do
txtExists <- doesFileExist (srcDir </> asset)
if txtExists
then copyFileChanged (srcDir </> asset) out
else genPdfAction getPost out
".gmi" -> do
fileExists <- doesFileExist (srcDir </> asset)
if fileExists
then copyFileChanged (srcDir </> asset) out
else if out == siteDir </> "index.gmi"
then buildGeminiArchive getPosts out
else genGeminiAction out
".jpg" -> compressImage asset
".jpeg" -> compressImage asset
".gif" -> compressImage asset
".png" -> compressImage asset
_ -> copyFileChanged (srcDir </> asset) out
optimDir </> "rss.xml" %> \_ -> do
needAll
command_[] "engine/pre-deploy.sh" []
welcomeTxt :: Text
welcomeTxt = toS $ T.intercalate "\n" $
[ "Welcome to my small place on the Internet."
]
buildArchive
:: (() -> Action [BlogPost])
-> (FilePath -> Action Template) -> [Char] -> Action ()
buildArchive getPosts getTemplate out = do
css <- genAllDeps ["//*.css"]
posts <- fmap sortByPostDate $ getPosts ()
need $ css <> map postSrc posts
let
title :: Text
title = "#+title: Yann Esposito's blog"
menu = "@@html:<a href=\"/index.html\">Home</a> | <a href=\"/slides.html\">Slides</a> | <a href=\"/about-me.html\">About</a>@@"
articleList = toS $ T.intercalate "\n" $ map postInfo posts
fileContent = title <> "\n\n" <> menu <> "\n\n" <> welcomeTxt <> "\n\n" <> articleList
eitherResult <- liftIO $ Pandoc.runIO $ Readers.readOrg (def { readerStandalone = True }) (toS fileContent)
bp <- case eitherResult of
Left _ -> fail "BAD"
Right pandoc -> getBlogpostFromMetas out False pandoc
innerHtml <- genHtml bp
template <- getTemplate ("templates" </> "main.mustache")
let htmlContent =
renderMustache template
$ object [ "title" .= postTitle bp
, "author" .= postAuthor bp
, "date" .= postDate bp
, "tags" .= postTags bp
, "description" .= postDescr bp
, "body" .= innerHtml
]
writeFile' out (toS htmlContent)
geminiMenu :: Text
geminiMenu = T.intercalate "\n"
[ "=> /index.gmi Home"
, "=> /gem-atom.xml Feed"
, "=> /slides.gmi Slides"
, "=> /about-me.gmi About me"
]
buildGeminiArchive
:: (() -> Action [BlogPost])
-> [Char] -> Action ()
buildGeminiArchive getPosts out = do
posts <- fmap sortByPostDate $ getPosts ()
need $ map postSrc posts
let
title :: Text
title = "# Yann Esposito's posts"
articleList = toS $ T.intercalate "\n" $ map postGeminiInfo posts
fileContent = title
<> "\n\n" <> welcomeTxt
<> "\n\n" <> geminiMenu
<> "\n\n" <> "## Articles"
<> "\n\n" <> articleList
writeFile' out (toS fileContent)
postGeminiInfo :: BlogPost -> Text
postGeminiInfo bp =
"=> " <> (toS (postUrl bp -<.> ".gmi")) <> " " <> date <> ": " <> (postTitle bp)
where
date = T.takeWhile (/= ' ') (postDate bp)
postInfo :: BlogPost -> Text
postInfo bp =
"| " <> date <> " | " <> orglink <> " |"
where
date = T.takeWhile (/= ' ') (postDate bp)
orglink = "[[file:" <> (toS (postUrl bp)) <> "][" <> (postTitle bp) <> "]]"
replaceLinks :: Pandoc -> Pandoc
replaceLinks = walk replaceOrgLink
where
replaceOrgLink :: Inline -> Inline
replaceOrgLink lnk@(Link attr inl (url,txt)) =
if takeExtension (toS url) == ".org"
then Link attr inl ((toS (toS url -<.> ".html")),txt)
else lnk
replaceOrgLink x = x
orgContentToText :: (MonadIO m, MonadFail m) => Text -> m Text
orgContentToText org = do
eitherResult <- liftIO $ Pandoc.runIO $ Readers.readOrg (def { readerStandalone = True }) org
pandoc <- case eitherResult of
Left _ -> fail "BAD"
Right p -> return p
eitherHtml <- liftIO $ Pandoc.runIO $
Writers.writeHtml5String (def {writerEmailObfuscation = ReferenceObfuscation}) pandoc
case eitherHtml of
Left _ -> fail "BAD"
Right innerHtml -> return innerHtml
postamble :: (MonadIO m, MonadFail m) => Text -> BlogPost -> m Text
postamble now bp =
orgContentToText $ unlines $
[ "@@html:<footer>@@"
, "@@html:<i>Any comment? Click on my email below and I'll add it.</i>@@"
, ""
, "| author | @@html:<span class=\"author\">@@ [[mailto:Yann Esposito <yann@esposito.host>?subject=yblog: " <> (postTitle bp) <> "][Yann Esposito <yann@esposito.host>]] @@html:</span>@@ |"
, "| gpg | [[file:files/publickey.txt][CB420F8005F1A662]] |"
, "| tags | " <> T.intercalate " " (map ("#"<>) (postTags bp)) <> " |"
, "| date | " <> postDate bp <> " |"
, "| rss | [[file:/rss.xml][RSS]] ([[https://validator.w3.org/feed/check.cgi?url=https%3A%2F%2Fher.esy.fun%2Frss.xml][validate]]) |"
, "| size | @@html:<span class=\"web-file-size\">XXK (html XXK, css XXK, img XXK)</span>@@ |"
, "| gz | @@html:<span class=\"gzweb-file-size\">XXK (html XXK, css XXK, img XXK)</span>@@ |"
, "| generated | " <> now <> " |"
, ""
, "@@html:</footer>@@"
]
tpltxt :: Text
tpltxt = T.unlines [
"$if(toc)$"
, "<nav id=\"$idprefix$TOC\" role=\"doc-toc\">"
, "$if(toc-title)$"
, "<h2 id=\"$idprefix$toc-title\">$toc-title$</h2>"
, "$endif$"
, "$table-of-contents$"
, "</nav>"
, "$endif$"
, "$body$"
]
getPostTpl :: IO (Templates.Template Text)
getPostTpl = do
etpl <- Templates.compileTemplate "blog.template" tpltxt
case etpl of
Left e -> fail e
Right tpl -> return tpl
genHtml :: (MonadIO m, MonadFail m) => BlogPost -> m Text
genHtml bp = do
let htmlBody = replaceLinks (postBody bp)
eitherHtml <- liftIO $ do
tpl <- getPostTpl
Pandoc.runIO $ do
Writers.writeHtml5String
(def { writerTableOfContents = postToc bp
, writerTemplate = Just tpl
, writerTOCDepth = 3
, writerEmailObfuscation = ReferenceObfuscation
, writerHTMLMathMethod = MathML
})
htmlBody
body <- case eitherHtml of
Left _ -> fail "BAD"
Right innerHtml -> return innerHtml
now <- liftIO Clock.getCurrentTime
footer <- postamble (toS (iso8601Show now)) bp
return (body <> footer)
origin :: Text
origin = "https://her.esy.fun"
geminiOrigin :: Text
geminiOrigin = "gemini://her.esy.fun"
genHtmlAction
:: (FilePath -> Action BlogPost)
-> (FilePath -> Action Template) -> [Char] -> Action ()
genHtmlAction getPost getTemplate out = do
let tplname = case takeDirectory1 (dropDirectory1 out) of
"posts" -> "post.mustache"
"slides" -> "slide.mustache"
"drafts" -> "post.mustache"
_ -> "main.mustache"
let templateFile = "templates" </> tplname
template <- getTemplate templateFile
let srcFile = srcDir </> (dropDirectory1 (out -<.> "org"))
liftIO $ putText $ "need: " <> (toS srcFile) <> " -> " <> (toS out)
need [srcFile,templateFile,"templates" </> "menu.mustache","Shakefile.hs"]
bp <- getPost srcFile
innerHtml <- genHtml bp
let htmlContent =
renderMustache template
$ object [ "title" .= postTitle bp
, "author" .= postAuthor bp
, "date" .= postDate bp
, "tags" .= postTags bp
, "description" .= postDescr bp
, "body" .= innerHtml
, "orgsource" .= T.pack (postUrl bp -<.> "org")
, "txtsource" .= T.pack (postUrl bp -<.> "gmi")
, "geminiurl" .= T.pack (toS geminiOrigin <> postUrl bp -<.> "gmi")
, "pdf" .= T.pack (postUrl bp -<.> "pdf")
, "permalink" .= T.pack (toS origin <> postUrl bp -<.> "html")
]
writeFile' out (toS htmlContent)
genPdfAction :: p -> [Char] -> Action ()
genPdfAction _getPost out = do
let srcFile = srcDir </> (dropDirectory1 (out -<.> "org"))
need [srcFile,"Shakefile.hs"]
command_ [] "pandoc"
["--pdf-engine=xelatex"
, "--resource-path=" <> takeDirectory srcFile
, srcFile
, "-H", "engine" </> "deeplist.tex"
, "-V", "mainfont:CMU Serif"
, "-V", "mainfontoptions:Renderer=OpenType, Mapping=tex-text, ItalicFeatures={Alternate = 0}, Ligatures={Common,Rare,Historic,Contextual},Contextuals=Inner,Alternate=1"
, "-V", "monofont:Menlo"
, "-V", "monofontoptions:Scale=0.7"
, "-o", out ]
-- genGemini :: (MonadIO m, MonadFail m) => BlogPost -> m Text
-- genGemini bp = do
-- eitherMd <- liftIO $ Pandoc.runIO $ Writers.writeMarkdown def (postBody bp)
-- case eitherMd of
-- Left _ -> fail "BAD"
-- Right innerMd -> return innerMd
genGeminiAction :: [Char] -> Action ()
genGeminiAction out = do
let srcFile = srcDir </> (dropDirectory1 (out -<.> "org"))
need [srcFile]
command_ [] "./engine/org2gemini.sh" [ srcFile, out ]
allHtmlAction :: Action ()
allHtmlAction = do
allOrgFiles <- getDirectoryFiles srcDir ["//*.org"]
let allHtmlFiles = map (-<.> "html") allOrgFiles
need (map build allHtmlFiles)
allPdfAction :: Action ()
allPdfAction = do
allOrgFiles <- getDirectoryFiles srcDir ["//*.org"]
let allHtmlFiles = map (-<.> "pdf") allOrgFiles
need (map build allHtmlFiles)
allGeminiAction :: Action ()
allGeminiAction = do
allOrgFiles <- getDirectoryFiles srcDir ["//*.org"]
let allGeminiFiles = map (-<.> "gmi") allOrgFiles
need (map build $ allGeminiFiles <> ["index.gmi"])
compressImage :: FilePath -> Action ()
compressImage img = do
let src = srcDir </> img
dst = siteDir </> img
need [src]
let dir = takeDirectory dst
dirExists <- doesDirectoryExist dir
when (not dirExists) $
command [] "mkdir" ["-p", dir]
command_ [] "convert" [ src
, "-strip"
, "-resize","960x960>"
, "-interlace","Plane"
, "-quality","85"
, "-define","filter:blur=0.75"
, "-filter","Gaussian"
-- , "-ordered-dither","o4x4,4"
, dst ]
needFast :: Action ()
needFast = do
allAssets <- filter (/= ".DS_Store") <$> getDirectoryFiles srcDir ["**"]
need (map build $ allAssets <> ["index.html"])
allHtmlAction
allGeminiAction
fastRule :: Rules ()
fastRule =
withTargetDocs "generate html" $
phony "fast" $
needFast
needAll :: Action ()
needAll = do
needFast
allPdfAction
allGeminiAction
allRule :: Rules ()
allRule =
withTargetDocs "generate all, no optim" $
phony "all" $
needAll
fullRule :: Rules ()
fullRule =
withTargetDocs "generate all and optim" $
phony "full" $
need [optimDir </> "rss.xml"]
cleanRule :: Rules ()
cleanRule =
phony "clean" $ do
putInfo "Cleaning files in _site and _optim"
forM_ [siteDir,optimDir] $ flip removeFilesAfter ["**"]
mkGetTemplate :: Rules (FilePath -> Action Template)
mkGetTemplate = newCache $ \path -> do
fileContent <- readFile' path
header <- readFile' ("templates" </> "header.mustache")
menu <- readFile' ("templates" </> "menu.mustache")
let withIncludes = fileContent & toS & T.replace "{{>header}}" (toS header) & T.replace "{{>menu}}" (toS menu)
res = compileMustacheText "page" (toS withIncludes)
case res of
Left _ -> fail "BAD"
Right template -> return template
tocRequested :: Text -> Bool
tocRequested fc =
let toc = fc & T.lines
& map T.toLower
& filter (T.isPrefixOf (T.pack "#+options: "))
& head
& fmap (filter (T.isPrefixOf (T.pack "toc:")) . T.words)
in toc == Just ["toc:t"]
mkGetPost :: Rules (FilePath -> Action BlogPost)
mkGetPost = newCache $ \path -> do
fileContent <- readFile' path
let toc = tocRequested (toS fileContent)
eitherResult <- liftIO $ Pandoc.runIO $ Readers.readOrg (def { readerStandalone = True }) (toS fileContent)
case eitherResult of
Left _ -> fail "BAD"
Right pandoc -> getBlogpostFromMetas path toc pandoc
mkGetPosts :: (FilePath -> Action b) -> Rules (() -> Action [b])
mkGetPosts getPost =
newCache $ \() -> mapM getPost =<< getDirectoryFiles "" ["src/posts//*.org"]