diff --git a/.gitignore b/.gitignore index bb5e6a8..70863a7 100644 --- a/.gitignore +++ b/.gitignore @@ -4,4 +4,5 @@ _optim/ src/archive.org .direnv/ _shake/ -.shake/ \ No newline at end of file +.shake/ +dist-newstyle/ diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..6f65a3a --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for her-esy-fun + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/Shakefile.hs b/Shakefile.hs deleted file mode 100644 index 6b38e66..0000000 --- a/Shakefile.hs +++ /dev/null @@ -1,497 +0,0 @@ -{-# 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"] diff --git a/Shakefile.hs b/Shakefile.hs new file mode 120000 index 0000000..920a28d --- /dev/null +++ b/Shakefile.hs @@ -0,0 +1 @@ +app/Shakefile.hs \ No newline at end of file diff --git a/app/Shakefile.hs b/app/Shakefile.hs new file mode 100644 index 0000000..6b38e66 --- /dev/null +++ b/app/Shakefile.hs @@ -0,0 +1,497 @@ +{-# 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"] diff --git a/build.sh b/build.sh index 71b68d1..0bc2c8f 100755 --- a/build.sh +++ b/build.sh @@ -1,3 +1,6 @@ #!/bin/sh -mkdir -p _shake -ghc --make Shakefile.hs -rtsopts -threaded -with-rtsopts=-I0 -outputdir=_shake -o _shake/build && _shake/build "$@" + +# mkdir -p _shake +# ghc --make app/Shakefile.hs -rtsopts -threaded -with-rtsopts=-I0 -outputdir=_shake -o _shake/build && _shake/build "$@" + +cabal v2-run -- her-esy-fun "$@" diff --git a/her-esy-fun.cabal b/her-esy-fun.cabal new file mode 100644 index 0000000..3542435 --- /dev/null +++ b/her-esy-fun.cabal @@ -0,0 +1,43 @@ +cabal-version: 2.4 +name: her-esy-fun +version: 0.1.0.0 + +-- A short (one-line) description of the package. +-- synopsis: + +-- A longer description of the package. +-- description: + +-- A URL where users can report bugs. +-- bug-reports: + +-- The license under which the package is released. +-- license: +author: Yann Esposito (Yogsototh) +maintainer: yann.esposito@gmail.com + +-- A copyright notice. +-- copyright: +-- category: +extra-source-files: CHANGELOG.md + +executable her-esy-fun + main-is: Shakefile.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: base ^>=4.14.1.0 + , aeson + , pandoc + , pandoc-types + , shake + , data-default + , protolude + , stache + , text + , time + hs-source-dirs: app + default-language: Haskell2010 diff --git a/nix/sources.json b/nix/sources.json index 58f2808..3d1f87d 100644 --- a/nix/sources.json +++ b/nix/sources.json @@ -1,4 +1,16 @@ { + "ghc.nix": { + "branch": "master", + "description": "Nix (shell) expression for working on GHC", + "homepage": "https://haskell.org/ghc/", + "owner": "alpmestan", + "repo": "ghc.nix", + "rev": "9adaf8abe53fa0618c1561919ddfbc4342fe144b", + "sha256": "0qmkkildzl21y88czgnschvi8mdkqrj9hgvpban58zzjnxw5s4nd", + "type": "tarball", + "url": "https://github.com/alpmestan/ghc.nix/archive/9adaf8abe53fa0618c1561919ddfbc4342fe144b.tar.gz", + "url_template": "https://github.com///archive/.tar.gz" + }, "niv": { "branch": "master", "description": "Easy dependency management for Nix projects", @@ -12,15 +24,15 @@ "url_template": "https://github.com///archive/.tar.gz" }, "nixpkgs": { - "branch": "nixpkgs-unstable", + "branch": "nixpkgs-20.09-darwin", "description": "A read-only mirror of NixOS/nixpkgs tracking the released channels. Send issues and PRs to", "homepage": "https://github.com/NixOS/nixpkgs", "owner": "NixOS", - "repo": "nixpkgs-channels", - "rev": "a84cbb60f0296210be03c08d243670dd18a3f6eb", - "sha256": "04j07c98iy66hpzha7brz867dcl9lkflck43xvz09dfmlvqyzmiz", + "repo": "nixpkgs", + "rev": "e716ddfac4be879ffbae75c3914a538dd5d4d12e", + "sha256": "0c2090sz4nvd1bqa9bfz3b6mj0q8b7v4jzgsykn2hf291l3h94d6", "type": "tarball", - "url": "https://github.com/NixOS/nixpkgs-channels/archive/a84cbb60f0296210be03c08d243670dd18a3f6eb.tar.gz", + "url": "https://github.com/NixOS/nixpkgs/archive/e716ddfac4be879ffbae75c3914a538dd5d4d12e.tar.gz", "url_template": "https://github.com///archive/.tar.gz" }, "shake": { diff --git a/nix/sources.nix b/nix/sources.nix index 8a725cb..b64b8f8 100644 --- a/nix/sources.nix +++ b/nix/sources.nix @@ -12,36 +12,29 @@ let else pkgs.fetchurl { inherit (spec) url sha256; }; - fetch_tarball = pkgs: spec: - if spec.builtin or true then - builtins_fetchTarball { inherit (spec) url sha256; } - else - pkgs.fetchzip { inherit (spec) url sha256; }; + fetch_tarball = pkgs: name: spec: + let + ok = str: ! builtins.isNull (builtins.match "[a-zA-Z0-9+-._?=]" str); + # sanitize the name, though nix will still fail if name starts with period + name' = stringAsChars (x: if ! ok x then "-" else x) "${name}-src"; + in + if spec.builtin or true then + builtins_fetchTarball { name = name'; inherit (spec) url sha256; } + else + pkgs.fetchzip { name = name'; inherit (spec) url sha256; }; fetch_git = spec: builtins.fetchGit { url = spec.repo; inherit (spec) rev ref; }; - fetch_builtin-tarball = spec: - builtins.trace - '' - WARNING: - The niv type "builtin-tarball" will soon be deprecated. You should - instead use `builtin = true`. + fetch_local = spec: spec.path; - $ niv modify -a type=tarball -a builtin=true - '' - builtins_fetchTarball { inherit (spec) url sha256; }; + fetch_builtin-tarball = name: throw + ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`. + $ niv modify ${name} -a type=tarball -a builtin=true''; - fetch_builtin-url = spec: - builtins.trace - '' - WARNING: - The niv type "builtin-url" will soon be deprecated. You should - instead use `builtin = true`. - - $ niv modify -a type=file -a builtin=true - '' - (builtins_fetchurl { inherit (spec) url sha256; }); + fetch_builtin-url = name: throw + ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`. + $ niv modify ${name} -a type=file -a builtin=true''; # # Various helpers @@ -72,13 +65,23 @@ let if ! builtins.hasAttr "type" spec then abort "ERROR: niv spec ${name} does not have a 'type' attribute" else if spec.type == "file" then fetch_file pkgs spec - else if spec.type == "tarball" then fetch_tarball pkgs spec + else if spec.type == "tarball" then fetch_tarball pkgs name spec else if spec.type == "git" then fetch_git spec - else if spec.type == "builtin-tarball" then fetch_builtin-tarball spec - else if spec.type == "builtin-url" then fetch_builtin-url spec + else if spec.type == "local" then fetch_local spec + else if spec.type == "builtin-tarball" then fetch_builtin-tarball name + else if spec.type == "builtin-url" then fetch_builtin-url name else abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}"; + # If the environment variable NIV_OVERRIDE_${name} is set, then use + # the path directly as opposed to the fetched source. + replace = name: drv: + let + saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name; + ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}"; + in + if ersatz == "" then drv else ersatz; + # Ports of functions for older nix versions # a Nix version of mapAttrs if the built-in doesn't exist @@ -87,13 +90,23 @@ let listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set)) ); + # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295 + range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1); + + # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257 + stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1)); + + # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269 + stringAsChars = f: s: concatStrings (map f (stringToCharacters s)); + concatStrings = builtins.concatStringsSep ""; + # fetchTarball version that is compatible between all the versions of Nix - builtins_fetchTarball = { url, sha256 }@attrs: + builtins_fetchTarball = { url, name, sha256 }@attrs: let inherit (builtins) lessThan nixVersion fetchTarball; in if lessThan nixVersion "1.12" then - fetchTarball { inherit url; } + fetchTarball { inherit name url; } else fetchTarball attrs; @@ -115,13 +128,13 @@ let then abort "The values in sources.json should not have an 'outPath' attribute" else - spec // { outPath = fetch config.pkgs name spec; } + spec // { outPath = replace name (fetch config.pkgs name spec); } ) config.sources; # The "config" used by the fetchers mkConfig = - { sourcesFile ? ./sources.json - , sources ? builtins.fromJSON (builtins.readFile sourcesFile) + { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null + , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile) , pkgs ? mkPkgs sources }: rec { # The sources, i.e. the attribute set of spec name to spec @@ -130,5 +143,6 @@ let # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers inherit pkgs; }; + in mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); } diff --git a/shell.nix b/shell.nix index 45bcfbe..5f6a20a 100644 --- a/shell.nix +++ b/shell.nix @@ -23,10 +23,10 @@ pkgs.mkShell { perlPackages.URI minify niv - ghc git direnv - haskellPackages.shake +# ghc +# haskellPackages.shake tmux # for emacs dev ripgrep diff --git a/src/drafts/XXX-code-architecture/index.org b/src/drafts/XXX-code-architecture/index.org new file mode 100644 index 0000000..ba234c2 --- /dev/null +++ b/src/drafts/XXX-code-architecture/index.org @@ -0,0 +1,109 @@ +#+TITLE: Are Services superior to Free Monads? +#+AUTHOR: Yann Esposito +#+EMAIL: yann@esposito.host +#+DATE: [2021-01-10 Sun] +#+KEYWORDS: haskell, clojure, architecture, programming +#+DESCRIPTION: Here is a simple description on how to architect a big functional programming application. +#+OPTIONS: auto-id:t toc:nil + +#+begin_abstract +TODO +#+end_abstract + +A recurring hot topic in the functional programming world is how to make +your code scale while keeping professionnal level of code quality. + +Quite often in the functional programming we communities and talk people +are focusing on enhancing specifics... + +To organise your code in a functional paradigm there are many concurrent proposals. +And structuring a code application is challenging. +The way you need to structure the code generally need to reach a few +properties. + +1. You should make it easy to test your code +2. You need to support modern features any modern application is expected + to provide. Typically ability to write logs, if possible send structured + logs events. +3. The code should try to help people focalise on the business logic and + put aside irrelevant technical details. +4. Split your applications into smaller (ideal composable) components +5. Control accesses between different components of your applications + +The design space is quite open. +In Haskell for example, there are different proposed solutions. + +One of my preferred one to start with is the Handler +Pattern[fn:handler_pattern]. +Because it doesn't need any advanced Haskell knowledge to understand. +And also it prevents a classical overabstraction haskell curse I often see +within Haskellers. +No premature abstraction here. +No typeclass. + +The main principle behing it is that you create /handlers/. +Handlers are /component/ focused that each provide a set of methods and +functions already initialized. + +[fn:handler_pattern]: https://jaspervdj.be/posts/2018-03-08-handle-pattern.html + +* Monads, MTL, RIO, Handler Pattern, Free Monad +:PROPERTIES: +:CUSTOM_ID: monads--mtl--rio--handler-pattern--free-monad +:END: + +There are a lot of solutions to architecture a program while keeping all +the best properties of functional programming as well as best professional +practices. + +Here too, there are different level of looking at the problem of code +organisation. +On the very high level, an application is often understood as a set of +features. +But for all of thoses features to work together it is generally a lot of +work to organise them. + +So we can descend the level to look at code organisation. +Files organisation, how to group them. +Structure of the code organisation. +How to put test, etc... + +If you strive for composability you generally try to understand how to +group "components" and ask yourselve what a componentn should contain. +Here is a solution. +* Free Monads/Effect System +:PROPERTIES: +:CUSTOM_ID: free-monads-effect-system +:END: + +Foreword, semantic vs syntax. + +The kind of best way to talk about semantic and forget about the syntax is +to deal directly with a simplified representation of the AST. + + +Overall API: + +#+begin_src clojure +(interpret-with + [effect-1 effect-2 ... effect-n] + (let [admin-user (get-in-config [:user :admin :user-id]) + admin (get-user admin-user-id) + admin-email (get admin :email)] + (log "Admin email" admin-email) + admin-email)) +#+end_src + +It will be up to the actual instanciation of all =effect-*= to change the +interpretation of the body. +So some effect could have different interpreation of specific symbols. +So here we can imagine that =get-in-config=, =get-user= and =log= are +handlers specified in the effects. + +One advantage is that to test your code you can simply use stubbed effects. +One can use a list users + +Real effects and free monads are in fact more powerful than this example +is showing. +For example, within a free monad, even =let= semantic would be changed. +But let's not take this rabbit hole in this article right now. diff --git a/src/drafts/XXXX-programming-choices/index.org b/src/drafts/XXXX-programming-choices/index.org index 47a738e..a0e9968 100644 --- a/src/drafts/XXXX-programming-choices/index.org +++ b/src/drafts/XXXX-programming-choices/index.org @@ -1,6 +1,5 @@ #+Title: Programming experiences and choices #+Author: Yann Esposito -#+Language: English #+Select_tags: Programming, culture * TODO Introduction