{-# 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:Home | Slides | About@@" 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:@@" ] tpltxt :: Text tpltxt = T.unlines [ "$if(toc)$" , "" , "$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"]