re-working
This commit is contained in:
parent
150d79f96b
commit
00d04794d3
|
@ -4,4 +4,5 @@ _optim/
|
||||||
src/archive.org
|
src/archive.org
|
||||||
.direnv/
|
.direnv/
|
||||||
_shake/
|
_shake/
|
||||||
.shake/
|
.shake/
|
||||||
|
dist-newstyle/
|
||||||
|
|
|
@ -0,0 +1,5 @@
|
||||||
|
# Revision history for her-esy-fun
|
||||||
|
|
||||||
|
## 0.1.0.0 -- YYYY-mm-dd
|
||||||
|
|
||||||
|
* First version. Released on an unsuspecting world.
|
497
Shakefile.hs
497
Shakefile.hs
|
@ -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:<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"]
|
|
|
@ -0,0 +1 @@
|
||||||
|
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:<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"]
|
7
build.sh
7
build.sh
|
@ -1,3 +1,6 @@
|
||||||
#!/bin/sh
|
#!/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 "$@"
|
||||||
|
|
|
@ -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
|
|
@ -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/<owner>/<repo>/archive/<rev>.tar.gz"
|
||||||
|
},
|
||||||
"niv": {
|
"niv": {
|
||||||
"branch": "master",
|
"branch": "master",
|
||||||
"description": "Easy dependency management for Nix projects",
|
"description": "Easy dependency management for Nix projects",
|
||||||
|
@ -12,15 +24,15 @@
|
||||||
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
|
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
|
||||||
},
|
},
|
||||||
"nixpkgs": {
|
"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",
|
"description": "A read-only mirror of NixOS/nixpkgs tracking the released channels. Send issues and PRs to",
|
||||||
"homepage": "https://github.com/NixOS/nixpkgs",
|
"homepage": "https://github.com/NixOS/nixpkgs",
|
||||||
"owner": "NixOS",
|
"owner": "NixOS",
|
||||||
"repo": "nixpkgs-channels",
|
"repo": "nixpkgs",
|
||||||
"rev": "a84cbb60f0296210be03c08d243670dd18a3f6eb",
|
"rev": "e716ddfac4be879ffbae75c3914a538dd5d4d12e",
|
||||||
"sha256": "04j07c98iy66hpzha7brz867dcl9lkflck43xvz09dfmlvqyzmiz",
|
"sha256": "0c2090sz4nvd1bqa9bfz3b6mj0q8b7v4jzgsykn2hf291l3h94d6",
|
||||||
"type": "tarball",
|
"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/<owner>/<repo>/archive/<rev>.tar.gz"
|
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
|
||||||
},
|
},
|
||||||
"shake": {
|
"shake": {
|
||||||
|
|
|
@ -12,36 +12,29 @@ let
|
||||||
else
|
else
|
||||||
pkgs.fetchurl { inherit (spec) url sha256; };
|
pkgs.fetchurl { inherit (spec) url sha256; };
|
||||||
|
|
||||||
fetch_tarball = pkgs: spec:
|
fetch_tarball = pkgs: name: spec:
|
||||||
if spec.builtin or true then
|
let
|
||||||
builtins_fetchTarball { inherit (spec) url sha256; }
|
ok = str: ! builtins.isNull (builtins.match "[a-zA-Z0-9+-._?=]" str);
|
||||||
else
|
# sanitize the name, though nix will still fail if name starts with period
|
||||||
pkgs.fetchzip { inherit (spec) url sha256; };
|
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:
|
fetch_git = spec:
|
||||||
builtins.fetchGit { url = spec.repo; inherit (spec) rev ref; };
|
builtins.fetchGit { url = spec.repo; inherit (spec) rev ref; };
|
||||||
|
|
||||||
fetch_builtin-tarball = spec:
|
fetch_local = spec: spec.path;
|
||||||
builtins.trace
|
|
||||||
''
|
|
||||||
WARNING:
|
|
||||||
The niv type "builtin-tarball" will soon be deprecated. You should
|
|
||||||
instead use `builtin = true`.
|
|
||||||
|
|
||||||
$ niv modify <package> -a type=tarball -a builtin=true
|
fetch_builtin-tarball = name: throw
|
||||||
''
|
''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`.
|
||||||
builtins_fetchTarball { inherit (spec) url sha256; };
|
$ niv modify ${name} -a type=tarball -a builtin=true'';
|
||||||
|
|
||||||
fetch_builtin-url = spec:
|
fetch_builtin-url = name: throw
|
||||||
builtins.trace
|
''[${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'';
|
||||||
WARNING:
|
|
||||||
The niv type "builtin-url" will soon be deprecated. You should
|
|
||||||
instead use `builtin = true`.
|
|
||||||
|
|
||||||
$ niv modify <package> -a type=file -a builtin=true
|
|
||||||
''
|
|
||||||
(builtins_fetchurl { inherit (spec) url sha256; });
|
|
||||||
|
|
||||||
#
|
#
|
||||||
# Various helpers
|
# Various helpers
|
||||||
|
@ -72,13 +65,23 @@ let
|
||||||
if ! builtins.hasAttr "type" spec then
|
if ! builtins.hasAttr "type" spec then
|
||||||
abort "ERROR: niv spec ${name} does not have a 'type' attribute"
|
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 == "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 == "git" then fetch_git spec
|
||||||
else if spec.type == "builtin-tarball" then fetch_builtin-tarball spec
|
else if spec.type == "local" then fetch_local spec
|
||||||
else if spec.type == "builtin-url" then fetch_builtin-url spec
|
else if spec.type == "builtin-tarball" then fetch_builtin-tarball name
|
||||||
|
else if spec.type == "builtin-url" then fetch_builtin-url name
|
||||||
else
|
else
|
||||||
abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}";
|
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
|
# Ports of functions for older nix versions
|
||||||
|
|
||||||
# a Nix version of mapAttrs if the built-in doesn't exist
|
# 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))
|
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
|
# fetchTarball version that is compatible between all the versions of Nix
|
||||||
builtins_fetchTarball = { url, sha256 }@attrs:
|
builtins_fetchTarball = { url, name, sha256 }@attrs:
|
||||||
let
|
let
|
||||||
inherit (builtins) lessThan nixVersion fetchTarball;
|
inherit (builtins) lessThan nixVersion fetchTarball;
|
||||||
in
|
in
|
||||||
if lessThan nixVersion "1.12" then
|
if lessThan nixVersion "1.12" then
|
||||||
fetchTarball { inherit url; }
|
fetchTarball { inherit name url; }
|
||||||
else
|
else
|
||||||
fetchTarball attrs;
|
fetchTarball attrs;
|
||||||
|
|
||||||
|
@ -115,13 +128,13 @@ let
|
||||||
then abort
|
then abort
|
||||||
"The values in sources.json should not have an 'outPath' attribute"
|
"The values in sources.json should not have an 'outPath' attribute"
|
||||||
else
|
else
|
||||||
spec // { outPath = fetch config.pkgs name spec; }
|
spec // { outPath = replace name (fetch config.pkgs name spec); }
|
||||||
) config.sources;
|
) config.sources;
|
||||||
|
|
||||||
# The "config" used by the fetchers
|
# The "config" used by the fetchers
|
||||||
mkConfig =
|
mkConfig =
|
||||||
{ sourcesFile ? ./sources.json
|
{ sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null
|
||||||
, sources ? builtins.fromJSON (builtins.readFile sourcesFile)
|
, sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile)
|
||||||
, pkgs ? mkPkgs sources
|
, pkgs ? mkPkgs sources
|
||||||
}: rec {
|
}: rec {
|
||||||
# The sources, i.e. the attribute set of spec name to spec
|
# 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
|
# The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers
|
||||||
inherit pkgs;
|
inherit pkgs;
|
||||||
};
|
};
|
||||||
|
|
||||||
in
|
in
|
||||||
mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); }
|
mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); }
|
||||||
|
|
|
@ -23,10 +23,10 @@ pkgs.mkShell {
|
||||||
perlPackages.URI
|
perlPackages.URI
|
||||||
minify
|
minify
|
||||||
niv
|
niv
|
||||||
ghc
|
|
||||||
git
|
git
|
||||||
direnv
|
direnv
|
||||||
haskellPackages.shake
|
# ghc
|
||||||
|
# haskellPackages.shake
|
||||||
tmux
|
tmux
|
||||||
# for emacs dev
|
# for emacs dev
|
||||||
ripgrep
|
ripgrep
|
||||||
|
|
|
@ -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.
|
|
@ -1,6 +1,5 @@
|
||||||
#+Title: Programming experiences and choices
|
#+Title: Programming experiences and choices
|
||||||
#+Author: Yann Esposito
|
#+Author: Yann Esposito
|
||||||
#+Language: English
|
|
||||||
#+Select_tags: Programming, culture
|
#+Select_tags: Programming, culture
|
||||||
|
|
||||||
* TODO Introduction
|
* TODO Introduction
|
||||||
|
|
Loading…
Reference in New Issue