git-annex in flupe@gozom:~/dev/acatalepsie

.gitignore

@@ -4,3 +4,4 @@ dist-newstyle
 _site
 *.local
 *~
+*.agdai

README.md

@@ -9,7 +9,10 @@ nix-env -if release.nix
 
 - dark theme
 - faster thumbnail generation with openCV
+- generic feed generation
+- indieweb interactions (webmentions, etc)
+- bin packing / grid system for galery
 - better gallery (albums, webzines, media types, layouts, etc)
-- tag/category/search system
+- tag/category/search engine
 - parallelization
 - draft builds + live server

acatalepsie.nix

@@ -1,19 +0,0 @@
-{ mkDerivation, achille, aeson, base, binary, bytestring
-, containers, data-default, directory, feed, filepath, lucid
-, optparse-applicative, pandoc, pandoc-types, process, sort, stdenv
-, text, time, yaml
-}:
-mkDerivation {
-  pname = "site";
-  version = "0.1.0.0";
-  src = ./.;
-  isLibrary = false;
-  isExecutable = true;
-  executableHaskellDepends = [
-    achille aeson base binary bytestring containers data-default
-    directory feed filepath lucid optparse-applicative pandoc
-    pandoc-types process sort text time yaml
-  ];
-  license = "unknown";
-  hydraPlatforms = stdenv.lib.platforms.none;
-}

content/assets/theme.css

@@ -13,7 +13,7 @@
 }
 
 body {
-  font: 15px Inter, sans-serif, "é";
+  font: 16px Inter, sans-serif, "é";
   line-height: 1.54;
   margin: 0;
   height: 100vh;
@@ -43,6 +43,10 @@ main > section {
   counter-reset: subsection;
 }
 
+main :first-child {
+  margin-top: 0;
+}
+
 main ::selection {
   background: var(--yellow);
   color: var(--black);
@@ -124,7 +128,7 @@ strong {color: var(--darker)}
 
 #hd nav a:hover {border-bottom:2px solid var(--yellow)}
 
-main, #ft {
+main, #ft, .breadcrumb {
   padding: 2em 1em;
   max-width: var(--width);
   box-sizing: border-box;
@@ -229,9 +233,11 @@ dt {text-align: right; font-weight: 500;}
 dd {margin:0}
 dd p {margin:0}
 
-code {font: .9em "Source Code Pro", monospace}
+code, pre.Agda {font: .9em "Source Code Pro", monospace}
+pre.Agda a {font-weight: inherit; text-decoration: none}
+pre.Agda a[href]:hover { background: var(--yellow) }
 
-code, pre.sourceCode {
+code, pre.sourceCode, pre.Agda {
   background: #eceff4; 
   border-radius: 3px;
 }
@@ -252,12 +258,18 @@ pre > code {display: block}
 #ft svg:hover {opacity:1}
 
 pre.sourceCode {
-  margin:1em 0;
+  margin:2em 0;
   padding: .8em 0;
   line-height: 1;
   overflow: auto;
 }
 
+pre.Agda {
+  margin: 2em 0;
+  padding: .8em 1em;
+  overflow: auto;
+}
+
 pre.sourceCode > code {
     display: inline-block;
     margin: 0 1em;
@@ -290,13 +302,24 @@ section.visual {
   grid-template-columns: repeat(auto-fill, minmax(300px, 1fr));
 }
 
+section.visual.tiny {
+  align-items: stretch;
+  grid-template-columns: repeat(auto-fill, minmax(160px, 1fr));
+}
+
 section.visual figure { margin: 0 }
+section.visual.tiny figure { margin: 0; border-radius: 5px; overflow: hidden; }
 figure img {
   max-width: 100%;
   height: auto;
   /* aspect-ratio: attr(width) / attr(height); */
   vertical-align: top;
 }
+section.visual.tiny img {object-fit: cover}
+
+p.right {text-align: right}
+
+section.visual.tiny figure img { height: 100% }
 
 .admonition {
   border-left: 3px solid var(--yellow);
@@ -319,19 +342,20 @@ figure img {
 .bn {color:#40a070}
 .cf {color:#007020; font-weight: bold; }
 .ch {color:#4070a0}
-.cn {color:#880000}
+.cn, .Agda .InductiveConstructor {color:#880000}
-.co {color:#60a0b0; font-style: italic; }
+.co, .Agda .Comment {color:#60a0b0; font-style: italic; }
 .cv {color:#60a0b0; font-weight: bold; font-style: italic; }
 .do {color:#ba2121; font-style: italic; }
-.dt {color:#902000}
+.dt, .Agda .PrimitiveType
+   , .Agda .Datatype {color:#902000}
 .dv {color:#40a070}
 .er {color:#f00; font-weight: bold; }
 .fl {color:#40a070; }
-.fu {color:#06287e; }
+.fu, .Agda .Function {color:#06287e; }
 .in {color:#60a0b0; font-weight: bold; font-style: italic; }
-.kw {color:#007020; }
+.kw, .Agda .Keyword {color:#007020; }
 .op {color:#666}
-.ot {color:#007020}
+.ot, .Agda .Symbol {color:#007020}
 .pp {color:#bc7a00}
 .sc {color:#4070a0}
 .ss {color:#bb6688}
@@ -353,5 +377,21 @@ table.books tr td:first-child {
   color: var(--blacker);
   font-weight: 500;
 }
+
+.breadcrumb {
+  padding-bottom: 0;
+  padding-top: 1em;
+}
+
+.breadcrumb .sep {
+  color: #999;
+  padding: 0 .5em;
+  cursor: default;
+}
+
+main > header h1   {line-height: 1.3}
+main > header p    {font-style: italic; padding-left: .5em; margin: .2em 0 0 }
+main > header time {font-weight: 500 }
+
 table.books tr td:nth-child(3),
 table.books tr td:last-child  {text-align: center;color: var(--yellow)}

content/index.rst

@@ -1 +0,0 @@
-  Oh god why

content/readings.yaml

@@ -1,3 +1,11 @@
+- title:  Machine Sex and Other Stories
+  author: Candas Jane Dorsey
+- title:  Art
+  author: Yasmina Reza
+- title:  Histoire de ta bêtise
+  author: François Bégaudeau
+- title:  Le Discours
+  author: Fabrice Caro
 - title:  Ayoade on Ayoade
   author: Richard Ayoade
 - title:  Antkind

release.nix

@@ -1,16 +0,0 @@
-let
-  compiler = "ghc884";
-  rev  = "b78e08e981a9ad31036fc6c6fb880c1315b4ebea";
-  overlay = _: pkgs: {
-    haskellPackages = pkgs.haskellPackages.override {
-      overrides = self: super: rec {
-        achille = self.callPackage ../achille/achille.nix {};
-      };
-    };
-  };
-  nixpkgs =
-    import (builtins.fetchTarball {
-      url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz";
-    }) { overlays = [ overlay ] ; };
-
-in nixpkgs.haskellPackages.callPackage ./acatalepsie.nix {}

site.cabal

@@ -17,6 +17,7 @@ executable site
                      , Visual
                      , Templates
                      , Readings
+                     , Route
   build-depends:       base >= 4.12 && < 5
                      , filepath
                      , achille
@@ -37,7 +38,7 @@ executable site
                      , optparse-applicative
                      , process
                      , directory
-  extensions:          BlockArguments
+  default-extensions:   BlockArguments
                       , TupleSections
                       , OverloadedStrings
                       , ScopedTypeVariables
@@ -47,5 +48,4 @@ executable site
                       , NamedFieldPuns
   ghc-options:       -threaded
                      -j8
-                     -O2
   default-language:    Haskell2010

src/Common.hs

@@ -12,11 +12,13 @@ module Common
     , module Data.Binary
     , module GHC.Generics
     , module Data.Aeson.Types
+    , toDate
     ) where
 
 import Achille
 import Achille.Task.Pandoc
 
+import Data.Time        (UTCTime, defaultTimeLocale, formatTime, rfc822DateFormat)
 import Data.Aeson.Types (FromJSON)
 import GHC.Generics     (Generic)
 import Data.Binary      (Binary)
@@ -28,3 +30,6 @@ import Data.Text        (Text)
 import Data.Maybe       (fromMaybe, mapMaybe)
 import System.FilePath
 import Lucid            (Html)
+
+toDate :: UTCTime -> String
+toDate = formatTime defaultTimeLocale rfc822DateFormat

src/Config.hs

@@ -4,14 +4,18 @@ import Data.Default
 import Data.Text (Text)
 import Text.Pandoc.Options as Pandoc
 import Achille (Config(..))
+import Route
 
 
 config :: Achille.Config
 config = def
-    { deployCmd  = Just "rsync -avzzr _site/ --chmod=755 acatalepsie:/var/www/html"
+    { deployCmd  = Just "rsync -avzzr ~/dev/acatalepsie/_site/ --chmod=755 acatalepsie:/var/www/html"
     , contentDir = root <> "content"
     , outputDir  = root <> "_site"
     , cacheFile  = root <> ".cache"
+    , ignore     = [ "**/*.agdai"
+                   , "**/*~"
+                   ]
     } where root = "/home/flupe/dev/acatalepsie/"
 
 
@@ -26,6 +30,7 @@ data SiteConfig = SiteConfig
     { title       :: Text
     , description :: Text
     , image       :: Text
+    , route       :: Route
     }
 
 instance Default SiteConfig where
@@ -33,4 +38,5 @@ instance Default SiteConfig where
         { title       = "sbbls"
         , description = "my personal web space, for your enjoyment"
         , image       = "https://acatalepsie.fr/assets/card.png"
+        , route       = IndexRoute
         }

src/Main.hs

@@ -17,6 +17,7 @@ import qualified Projects
 import qualified Visual
 import qualified Readings
 
+
 type ShowDrafts = Bool
 
 data Cmd
@@ -39,8 +40,7 @@ main = customExecParser p opts >>= \case
     Deploy -> mapM_ Process.callCommand (deployCmd config)
     Clean  -> removePathForcibly        (outputDir config)
            >> removePathForcibly        (cacheFile config)
-    Build showDrafts ->
+    Build showDrafts -> void $ runTask [] config (build showDrafts)
-        void $ runTask [] config (build showDrafts)
     where
         opts = info (cli <**> helper) $ fullDesc <> header desc
         p    = prefs showHelpOnEmpty
@@ -51,6 +51,7 @@ build :: ShowDrafts -> Task IO String
 build showDrafts = do
     -- static assets
     match_ "assets/*" copyFile
+    match_ "static/*" copyFile
 
     -- quid page
     match_ "./quid.rst" \src ->
@@ -59,7 +60,7 @@ build showDrafts = do
         <&> outerWith def {Config.title = "quid"}
         >>= write (src -<.> "html")
 
-    Visual.build
+    lastImages <- Visual.build
     Projects.build
-    Posts.build showDrafts
+    Posts.build showDrafts lastImages
     Readings.build

src/Posts.hs

@@ -1,21 +1,31 @@
-module Posts (build) where
+module Posts where
 
 import Data.Aeson.Types (FromJSON)
 import Data.Binary      (Binary, put, get)
 import Data.Time        (UTCTime, defaultTimeLocale)
 import Data.Time.Clock  (getCurrentTime)
 import Data.Time.Format (rfc822DateFormat, formatTime)
+import Data.List        (isPrefixOf)
 import GHC.Generics
 import Lucid
 
 import Text.Atom.Feed   as Atom
 import Text.Feed.Types  (Feed(..))
 import Text.Feed.Export (textFeed)
+import qualified Achille.Internal.IO as AchilleIO
 
 import Common
 import Config (ropts, wopts)
+import Visual (Image(..))
 import qualified Config
 import Templates
+import Route
+import System.FilePath
+import System.Directory ( setCurrentDirectory
+                        , getTemporaryDirectory
+                        , renameDirectory
+                        , createDirectoryIfMissing
+                        )
 
 --  metadata used for parsing YAML headers
 data PostMeta = PostMeta
@@ -39,25 +49,57 @@ instance IsTimestamped Post where timestamp = postDate
 buildPost :: FilePath -> Task IO Post
 buildPost src = do
     copyFile src
+    let ext = takeExtensions src
+    if ".lagda.md" `isPrefixOf` ext then processAgda src
+    else do
         (PostMeta title draft desc, pandoc) <- readPandocMetadataWith ropts src
         content <- renderPandocWith wopts pandoc
-
+        let date = timestamp src
-    pure (renderPost title src content)
+        pure (renderPost date title content)
             >>= write (src -<.> "html")
-        <&> Post title (timestamp src) (fromMaybe False draft) Nothing content
+            <&> Post title date (fromMaybe False draft) Nothing content
 
-toDate :: UTCTime -> String
+    where
-toDate = formatTime defaultTimeLocale rfc822DateFormat
+        processAgda :: FilePath -> Task IO Post
+        processAgda src = do
+            spath  <- toAbsolute src
+            odir   <- getOutputDir <&> (</> dropExtensions src)
+            tmpdir <- liftIO getTemporaryDirectory <&> (</> "achille")
+            liftIO $ createDirectoryIfMissing False tmpdir
+            liftIO $ createDirectoryIfMissing False odir
+            liftIO $ AchilleIO.copyFile spath (tmpdir </> "index.lagda.md")
 
-build :: Bool -> Task IO ()
+            -- agda --html needs to be invoked in the correct directory
-build showDrafts = do
+            liftIO $ setCurrentDirectory tmpdir
+
+            callCommand $
+                "agda --html "
+                <> "--html-dir=. "
+                <> "--html-highlight=auto "
+                <> "index.lagda.md"
+
+            callCommand $ "cp " <> tmpdir <> "/* " <> odir
+
+            let tpath = odir </> "index.md"
+
+            (PostMeta title draft desc, pandoc) <- readAbsPandocMetadataWith ropts tpath
+            content <- renderPandocWith wopts pandoc
+            let date = timestamp src
+            pure (renderPost date title content)
+                >>= write (dropExtensions src </> "index.html")
+                <&> takeDirectory
+                <&> Post title date (fromMaybe False draft) Nothing content
+
+
+build :: Bool -> [Image] -> Task IO ()
+build showDrafts imgs = do
     posts <- match "posts/*" buildPost
              <&> filter (\p -> not (postDraft p) || showDrafts)
              <&> recentFirst
 
-    watch posts $ match_ "index.rst" \src -> do
+    watch imgs $ watch posts $ match_ "index.rst" \src -> do
         compilePandoc src
-            <&> renderIndex posts
+            <&> renderIndex imgs posts
             >>= write (src -<.> "html")
 
         now <- liftIO getCurrentTime
@@ -84,18 +126,33 @@ build showDrafts = do
             }
 
 
-renderPost :: Text -> FilePath -> Text -> Html ()
+renderPost :: UTCTime -> Text -> Text -> Html ()
-renderPost title source content =
+renderPost date title content =
-    outerWith def { Config.title = title } do
+    outerWith def { Config.title = title, Config.route = PostRoute } do
+        header_ do
             h1_ $ toHtml title
-        toLink source "View source"
+            p_ do
+                "Posted on "
+                time_ $ toHtml (showDate date)
+                "."
         toHtmlRaw content
 
 
-renderIndex :: [Post] -> Text -> Html ()
+renderIndex :: [Image] -> [Post] -> Text -> Html ()
-renderIndex posts content = 
+renderIndex imgs posts content = 
     outer do
         toHtmlRaw content
+
+        section_ [class_ "visual tiny"] $
+            forM_ imgs \Image{..} ->
+                figure_ $ a_ [href_ $ fromString imgPath] $ img_
+                    [ src_ (fromString imgThumbPath)
+                    , width_ (fromString $ show imgThumbWidth)
+                    , height_ (fromString $ show imgThumbHeight)
+                    ]
+
+        p_ [class_ "right"] $ a_ [href_ "/visual.html"] "→ View more visual work"
+
         h2_ "Latest posts"
         ul_ [ id_ "pidx" ] $ forM_ posts \post ->
             li_ do

src/Projects.hs

@@ -5,6 +5,7 @@ import Data.Char (digitToInt)
 import qualified Data.Map.Strict as Map
 
 import Common
+import Route
 import Types
 import Config
 import Templates
@@ -48,7 +49,9 @@ buildProject src = do
             (TitledPage title _, doc) <- readPandocMetadataWith ropts filepath
             renderPandocWith wopts doc
                 <&> toHtmlRaw
-                <&> outerWith (def {Config.title = title})
+                <&> outerWith (def { Config.title = title
+                                   , Config.route = ProjectPageRoute title (ProjectRoute $ fromString name)
+                                   })
                 >>= write (filepath -<.> "html")
                 <&> (title,)
 
@@ -57,6 +60,7 @@ renderProject :: Project -> [(Text, FilePath)] -> Text -> Html ()
 renderProject Project{..} children content =
     outerWith def { Config.title       = title
                   , Config.description = subtitle
+                  , Config.route       = ProjectRoute title
                   } do
         header_ [class_ "project"] do
             div_ (img_ [src_ "logo.svg"])

src/Templates.hs

@@ -17,6 +17,7 @@ import Achille.Writable as Writable
 import Lucid
 import Lucid.Base (makeAttribute)
 
+import Route
 import Types
 import Common
 import Config
@@ -45,7 +46,7 @@ outer :: Html () -> Html ()
 outer = outerWith def
 
 outerWith :: SiteConfig -> Html () -> Html ()
-outerWith SiteConfig{title,..} content = doctypehtml_ do
+outerWith SiteConfig{title,route,..} content = doctypehtml_ do
     head_ do
         meta_ [ name_ "viewport"
               , content_ "width=device-width, initial-scale=1.0, user-scalable=yes"
@@ -77,6 +78,8 @@ outerWith SiteConfig{title,..} content = doctypehtml_ do
                 a_ [ href_ "/readings.html" ] "Readings"
                 a_ [ href_ "/quid.html"     ] "Quid"
 
+        breadcrumb route
+
         main_ content
 
         footer_ [ id_ "ft" ] do
@@ -84,6 +87,6 @@ outerWith SiteConfig{title,..} content = doctypehtml_ do
             a_ [ href_ "https://creativecommons.org/licenses/by-nc/2.0/" ]
                 "CC BY-NC 2.0"
             " · "
-            a_ [ href_ "https://instagram.com/ba.bou.m/" ] "instagram"
+            a_ [ href_ "https://instagram.com/ba.bou.m/", rel_ "me" ] "instagram"
             " · "
             a_ [ href_ "/atom.xml" ] "feed"

src/Visual.hs

@@ -1,54 +1,107 @@
-module Visual (build) where
+module Visual (build, Image(..)) where
 
-import Config
+import Data.Time (UTCTime)
+import Data.List (isSuffixOf)
+import qualified Config
 import Common
 import Templates (outerWith, loading_)
 import Lucid
+import Route
 
 
 thumbWidth :: Int
 thumbWidth = 710
 
 
-build :: Task IO ()
+data Image = Image
+    { imgPath        :: FilePath
+    , imgThumbPath   :: FilePath
+    , imgThumbWidth  :: Int
+    , imgThumbHeight :: Int
+    , imgDate        :: UTCTime
+    , imgNSFW        :: Bool     -- is the image nsfw?
+    } deriving (Generic, Eq, Binary)
+
+
+data EntryMeta = EntryMeta
+    { title     :: Text
+    , date      :: Text
+    , updated   :: Maybe Text
+    } deriving (Generic, Eq, FromJSON)
+
+
+data Entry = Entry
+    { entryTitle   :: Text
+    , entryContent :: Text
+    , entryItems   :: [Image]
+    , entryDate    :: UTCTime
+    , entryType    :: Text
+    } deriving (Generic, Eq, Binary)
+
+
+instance IsTimestamped Image where timestamp = imgDate
+instance IsTimestamped Entry where timestamp = entryDate
+
+
+build :: Task IO [Image]
 build = do
     pictures <- match "visual/*" \src -> do
-        copyFile src
+        path  <- copyFile src
-        callCommandWith
+        tpath <- callCommandWith (\a b -> "convert -resize 710x " <> a <> " " <> b)
-            (\a b -> "convert " <> a <> " " <> b)
-            (-<.> "webp")
-            src
-        src' <- toAbsolute src
-        size <- (resized . read)
-                <$> readCommand "identify" ["-ping", "-format", "(%w, %h)", src']
-        callCommandWith
-            (\a b -> "convert -resize 710x " <> a <> " " <> b)
                                  (-<.> "thumb.webp")
                                  src
-            <&> timestamped
+        apath <- toAbsolute src
-            <&> fmap (size,) 
+        size  <- read <$> readCommand "identify" ["-ping", "-format", "(%w, %h)", apath]
+        let nsfw = "nsfw" `isSuffixOf` dropExtension src
+        pure (Image path tpath thumbWidth (thumbHeight size) (timestamp src) nsfw)
 
-    watch pictures $ match_ "./visual.rst" \src -> do
+
+    -- webcomics/albums
+    entries <- matchDir "visual/*/" \src -> do
+        matchFile "index.markdown" \src -> do
+            (meta, doc) <- readPandocMetadata src
+            renderPandoc doc
+                <&> renderEntry meta
+                >>= write (src -<.> "html")
+        pure ()
+
+
+    watch pictures do
+        let sorted = filter (not . imgNSFW) $ recentFirst pictures
+
+        match_ "./visual.rst" \src -> do
             intro <- compilePandoc src
-        write "visual.html" $ renderVisual intro (recentFirst pictures)
+            write "visual.html" $ renderVisual intro sorted
-    where
+
-        resized :: (Int, Int) -> (Int, Int)
+        return (take 4 sorted)
-        resized (width, height) =
-            (thumbWidth, round $ fi height * fi thumbWidth / fi width)
     where
+        thumbHeight :: (Int, Int) -> Int
+        thumbHeight (width, height) = round (fi height * fi thumbWidth / fi width)
+
         fi :: Int -> Float
         fi = fromIntegral
 
 
-renderVisual :: Text -> [Timestamped ((Int, Int), FilePath)] -> Html ()
+renderEntry :: EntryMeta -> Text -> Html ()
+renderEntry meta content =
+    outerWith def { Config.title = title meta
+                  , Config.route = VEntryRoute
+                  } do
+        header_ do
+            h1_ $ toHtml (title meta)
+            p_ $ toHtml (date meta)
+        toHtmlRaw content
+        hr_ []
+
+renderVisual :: Text -> [Image] -> Html ()
 renderVisual txt imgs =
-    outerWith def {title = "visual"} do
+    outerWith def {Config.title = "visual"} do
         toHtmlRaw txt
         hr_ []
         section_ [class_ "visual"] $
-            forM_ imgs \ (Timestamped _ ((width, height), p)) ->
+            forM_ imgs \Image{..} ->
-                figure_ $ a_ [href_ (fromString (replaceExtensions p "webp"))] $ img_
+                figure_ $ a_ [href_ $ fromString imgPath] $ img_
-                    [ src_ (fromString p)
+                    [ src_ (fromString imgThumbPath)
-                    , width_ (fromString $ show width)
+                    , width_ (fromString $ show imgThumbWidth)
-                    , height_ (fromString $ show height)
+                    , height_ (fromString $ show imgThumbHeight)
                     , loading_ "lazy" ]