flupe
/
acatalepsie
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

moved from blaze-html to lucid

This commit is contained in:
flupe 2020-09-27 01:33:50 +02:00
parent a38f10a854
commit dbae6b3623
7 changed files with 112 additions and 140 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
site.cabal
View File

@ -16,12 +16,11 @@ executable site
, Common , Common
, Config , Config
, Visual , Visual
, Templates
build-depends: base >=4.12 && <4.13 build-depends: base >=4.12 && <4.13
, filepath , filepath
, achille , achille
, data-default , data-default
, blaze-html
, blaze-markup
, pandoc , pandoc
, pandoc-types , pandoc-types
, text , text
@ -32,17 +31,18 @@ executable site
, yaml , yaml
, binary , binary
, containers , containers
, dates
, sort , sort
, feed , feed
, time , time
, xml-types , lucid
, binary-instances , binary-instances
extensions: BlockArguments extensions: BlockArguments
, TupleSections , TupleSections
, OverloadedStrings , OverloadedStrings
, ScopedTypeVariables , ScopedTypeVariables
other-modules: Templates , DeriveGeneric
, DeriveAnyClass
ghc-options: -threaded ghc-options: -threaded
-j8 -j8
-O2
default-language: Haskell2010 default-language: Haskell2010

4
src/Common.hs
View File

@ -5,10 +5,10 @@ module Common
, module System.FilePath , module System.FilePath
, module Achille , module Achille
, module Achille.Recipe.Pandoc , module Achille.Recipe.Pandoc
, module Text.Blaze.Html
, module Data.Text , module Data.Text
, module Control.Monad , module Control.Monad
, module Data.Maybe , module Data.Maybe
, module Lucid
) where ) where
import Achille import Achille
@ -21,4 +21,4 @@ import Data.String (fromString)
import Data.Text (Text) import Data.Text (Text)
import Data.Maybe (fromMaybe, mapMaybe) import Data.Maybe (fromMaybe, mapMaybe)
import System.FilePath import System.FilePath
import Text.Blaze.Html (Html) import Lucid (Html)

34
src/Feed.hs
View File

@ -1,34 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE NamedFieldPuns #-}
module Feed where
import Data.Text hiding (map)
import Data.XML.Types as XML
import qualified Data.Text.Lazy as Lazy
import Text.Atom.Feed as Atom
import qualified Text.Atom.Feed.Export as Export (textFeed)
import Common
import Types
class Reifiable a where
toEntry :: a -> Atom.Entry
instance Reifiable Project where
toEntry :: Project -> Atom.Entry
toEntry (Project {title, subtitle}) =
toFeed :: Reifiable a => [a] -> Atom.Feed
toFeed items =
( Atom.nullFeed
"https://acatalepsie.fr/atom.xml"
(Atom.TextString "acatalepsie")
"2017-08-01"
)
{ Atom.feedEntries = map toEntry items
}

4
src/Main.hs
View File

@ -1,7 +1,7 @@
module Main where module Main where
import qualified Data.Yaml as Yaml import qualified Data.Yaml as Yaml
import Text.Blaze import Lucid
import Common import Common
import Templates import Templates
@ -19,7 +19,7 @@ main = achilleWith config do
-- quid page -- quid page
match_ "./quid.rst" $ match_ "./quid.rst" $
compilePandoc compilePandoc
<&> preEscapedText <&> toHtmlRaw
<&> outerWith def {Config.title = "quid"} <&> outerWith def {Config.title = "quid"}
>>= saveFileAs (-<.> "html") >>= saveFileAs (-<.> "html")

22
src/Posts.hs
View File

@ -2,15 +2,13 @@
module Posts (build) where module Posts (build) where
import Text.Blaze.Internal as I
import Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes as A
import Data.Aeson.Types (FromJSON) import Data.Aeson.Types (FromJSON)
import Data.Binary (Binary, put, get) import Data.Binary (Binary, put, get)
import Data.Time (UTCTime, defaultTimeLocale) import Data.Time (UTCTime, defaultTimeLocale)
import Data.Time.Clock (getCurrentTime) import Data.Time.Clock (getCurrentTime)
import Data.Time.Format (rfc822DateFormat, formatTime) import Data.Time.Format (rfc822DateFormat, formatTime)
import GHC.Generics import GHC.Generics
import Lucid
import Text.Atom.Feed as Atom import Text.Atom.Feed as Atom
import Text.Feed.Types (Feed(..)) import Text.Feed.Types (Feed(..))
@ -93,20 +91,20 @@ build = do
} }
renderPost :: Text -> FilePath -> Text -> Html renderPost :: Text -> FilePath -> Text -> Html ()
renderPost title source content = renderPost title source content =
outerWith def { Config.title = title } do outerWith def { Config.title = title } do
H.h1 $ toHtml title h1_ $ toHtml title
toLink source "View source" toLink source "View source"
preEscapedText content toHtmlRaw content
renderIndex :: [Post] -> Text -> Html renderIndex :: [Post] -> Text -> Html ()
renderIndex posts content = renderIndex posts content =
outer do outer do
preEscapedText content toHtmlRaw content
H.h2 "Latest posts" h2_ "Latest posts"
H.ul ! A.id "pidx" $ forM_ posts \post -> ul_ [ id_ "pidx" ] $ forM_ posts \post ->
H.li do li_ do
H.span $ fromString $ showDate (postDate post) span_ $ fromString $ showDate (postDate post)
toLink (postPath post) (toHtml $ postTitle post) toLink (postPath post) (toHtml $ postTitle post)

4
src/Projects.hs
View File

@ -2,12 +2,12 @@ module Projects (build) where
import Data.Char (digitToInt) import Data.Char (digitToInt)
import Text.Blaze
import Common import Common
import Types import Types
import Page import Page
import Config import Config
import Templates import Templates
import Lucid
getKey :: String -> (Int, String) getKey :: String -> (Int, String)
@ -39,7 +39,7 @@ buildProject = do
let (key, file) = getKey $ takeFileName filepath let (key, file) = getKey $ takeFileName filepath
(TitledPage title _, doc) <- readPandocMetadataWith ropts (TitledPage title _, doc) <- readPandocMetadataWith ropts
renderPandocWith wopts doc renderPandocWith wopts doc
<&> preEscapedText <&> toHtmlRaw
<&> outerWith (def {Config.title = fromString title}) <&> outerWith (def {Config.title = fromString title})
>>= saveFileAs (const $ file -<.> "html") >>= saveFileAs (const $ file -<.> "html")
<&> (title,) <&> (title,)

174
src/Templates.hs
View File

@ -1,144 +1,152 @@
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
module Templates where module Templates where
import Text.Blaze.Internal as I
import Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes as A
import Data.Time (UTCTime) import Data.Time (UTCTime)
import Data.Time.Format (formatTime, defaultTimeLocale) import Data.Time.Format (formatTime, defaultTimeLocale)
import Data.Time.LocalTime (zonedTimeToUTC) import Data.Time.LocalTime (zonedTimeToUTC)
import qualified Data.Map.Strict as Map
import Achille.Internal.IO (AchilleIO)
import Achille.Writable as Writable
import Lucid
import Lucid.Base (makeAttribute)
import Types import Types
import Common import Common
import Config import Config
import qualified Data.Map.Strict as Map
instance AchilleIO m => Writable m (Html a) where
write to = Writable.write to . renderBS
showDate :: UTCTime -> String showDate :: UTCTime -> String
showDate = formatTime defaultTimeLocale "%b %d, %_Y" showDate = formatTime defaultTimeLocale "%b %d, %_Y"
loading :: AttributeValue -> Attribute loading_ :: Text -> Attribute
loading = I.customAttribute "loading" loading_ = makeAttribute "loading"
property :: AttributeValue -> Attribute property_ :: Text -> Attribute
property = I.customAttribute "property" property_ = makeAttribute "property"
toLink :: FilePath -> Html -> Html toLink :: FilePath -> Html () -> Html ()
toLink url = H.a ! A.href (fromString $ "/" <> url) toLink url = a_ [ href_ (fromString $ "/" <> url) ]
renderVisual :: Text -> [Timestamped FilePath] -> Html renderVisual :: Text -> [Timestamped FilePath] -> Html ()
renderVisual txt imgs = renderVisual txt imgs =
outer do outer do
preEscapedText txt toHtmlRaw txt
H.hr hr_ []
H.section $ forM_ imgs \ (Timestamped _ p) -> section_ $ forM_ imgs \ (Timestamped _ p) ->
H.figure $ H.img ! A.src (fromString p) figure_ $ img_ [ src_ (fromString p), loading_ "lazy" ]
! loading "lazy"
renderProject :: Project -> [(String, FilePath)] -> Text -> Html renderProject :: Project -> [(String, FilePath)] -> Text -> Html ()
renderProject (project@Project{title,..}) children content = renderProject (project@Project{title,..}) children content =
outerWith def { Config.title = fromString title outerWith def { Config.title = fromString title
, Config.description = fromString subtitle , Config.description = fromString subtitle
} do } do
H.header ! A.class_ "project" $ do header_ [ class_ "project" ] do
H.div $ H.img ! A.src "logo.svg" div_ (img_ [ src_ "logo.svg" ])
H.div do div_ do
H.h1 $ fromString $ title h1_ (fromString title)
H.p $ fromString $ subtitle p_ (fromString subtitle)
H.ul $ forM_ (Map.toList labels) \(k, v) -> H.li do ul_ $ forM_ (Map.toList labels) \(k, v) -> li_ do
fromString k <> ": " fromString k <> ": "
if k == "repo" then if k == "repo" then
H.a ! A.href (fromString $ "https://github.com/" <> v) a_ [ href_ (fromString $ "https://github.com/" <> v) ]
$ fromString v $ fromString v
else fromString v else fromString v
when (length children > 0) $ when (length children > 0) $
H.ol ! A.class_ "pages" $ forM_ children \(t,l) -> ol_ [ class_ "pages" ] $ forM_ children \(t,l) ->
H.li $ H.a ! A.href (fromString l) $ (fromString t) li_ $ a_ [ href_ (fromString l) ] (fromString t)
preEscapedText content toHtmlRaw content
renderReadings :: [Book] -> Html renderReadings :: [Book] -> Html ()
renderReadings books = renderReadings books =
outerWith def { Config.title = "readings" outerWith def { Config.title = "readings"
, Config.description = "books I've read" , Config.description = "books I've read"
} do } do
H.table ! A.class_ "books" $ table_ [ class_ "books" ] $
forM_ books \ Book {title,author,rating,completed} -> forM_ books \ Book {title,author,rating,completed} ->
H.tr do tr_ do
H.td $ toHtml title td_ (toHtml title)
H.td $ toHtml author td_ (toHtml author)
H.td $ fromString $ case rating of td_ $ fromString $ case rating of
Just r -> replicate r '★' Just r -> replicate r '★'
Nothing -> "·" Nothing -> "·"
H.td $ fromString $ case completed of td_ $ fromString $ case completed of
Just d -> formatTime defaultTimeLocale "%m/%0Y" Just d -> formatTime defaultTimeLocale "%m/%0Y"
$ zonedTimeToUTC d $ zonedTimeToUTC d
Nothing -> "·" Nothing -> "·"
renderProjects :: Text -> [(Project, FilePath)] -> Html renderProjects :: Text -> [(Project, FilePath)] -> Html ()
renderProjects txt paths = renderProjects txt paths =
outer do outer do
preEscapedText txt toHtmlRaw txt
H.ul ! A.class_ "projects" $ do ul_ [ class_ "projects" ] do
forM_ paths \(Project {title,..}, link) -> H.li $ H.a ! A.href (fromString link) $ do forM_ paths \(Project {title,..}, link) -> li_ $ a_ [ href_ (fromString link) ] $ do
H.div $ H.img ! A.src (fromString $ link </> "logo.svg") div_ $ img_ [ src_ (fromString $ link </> "logo.svg") ]
H.div do div_ do
H.h2 $ fromString title h2_ (fromString title)
H.p $ fromString subtitle p_ (fromString subtitle)
-- H.ul $ forM_ (Map.toList $ Types.labels project) \(k, v) -> -- H.ul $ forM_ (Map.toList $ Types.labels project) \(k, v) ->
-- H.li $ (fromString k <> ": " <> fromString v) -- H.li $ (fromString k <> ": " <> fromString v)
logo :: Html logo :: Html ()
logo = preEscapedString "<svg xmlns=\"http://www.w3.org/2000/svg\" version=\"1.1\" height=\"19px\" width=\"29px\"><path d=\"M 2,2 A 5,5 0 0 1 7,7 L 7, 12 A 5, 5 0 0 1 2,17 M 7,7 A 5,5 0 0 1 12,2 L 22,2 A 5,5 0 0 1 27,7 L 27,12 A 5, 5 0 0 1 22,17 L 12,17\" style=\"stroke-width: 2; stroke-linecap: butt; stroke-linejoin: bevel; stroke: #fff\" fill=\"none\"/></svg>" logo = toHtmlRaw ("<svg xmlns=\"http://www.w3.org/2000/svg\" version=\"1.1\" height=\"19px\" width=\"29px\"><path d=\"M 2,2 A 5,5 0 0 1 7,7 L 7, 12 A 5, 5 0 0 1 2,17 M 7,7 A 5,5 0 0 1 12,2 L 22,2 A 5,5 0 0 1 27,7 L 27,12 A 5, 5 0 0 1 22,17 L 12,17\" style=\"stroke-width: 2; stroke-linecap: butt; stroke-linejoin: bevel; stroke: #fff\" fill=\"none\"/></svg>" :: Text)
outer :: Html -> Html outer :: Html () -> Html ()
outer = outerWith def outer = outerWith def
outerWith :: SiteConfig -> Html -> Html outerWith :: SiteConfig -> Html () -> Html ()
outerWith SiteConfig{title,..} content = H.docTypeHtml do outerWith SiteConfig{title,..} content = doctypehtml_ do
H.head do head_ do
H.meta ! A.name "viewport" meta_ [ name_ "viewport"
! A.content "width=device-width, initial-scale=1.0, user-scalable=yes" , content_ "width=device-width, initial-scale=1.0, user-scalable=yes"
H.meta ! A.name "theme-color" ! A.content "#000000" ]
H.meta ! A.name "robots" ! A.content "index, follow" meta_ [ name_ "theme-color", content_ "#000000" ]
H.meta ! charset "utf-8" meta_ [ name_ "robots", content_ "index, follow" ]
H.link ! A.rel "stylesheet" ! A.href "/assets/theme.css" meta_ [ charset_ "utf-8" ]
H.link ! A.rel "shortcut icon" link_ [ rel_ "stylesheet", href_ "/assets/theme.css" ]
! A.type_ "image/svg" link_ [ rel_ "shortcut icon"
! A.href "/assets/favicon.svg" , type_ "image/svg"
H.link ! A.rel "alternate" , href_ "/assets/favicon.svg"
! A.type_ "application/atom+xml" ]
! A.href "/atom.xml" link_ [ rel_ "alternate"
H.meta ! property "og:title" , type_ "application/atom+xml"
! A.content (textValue title) , href_ "/atom.xml"
H.meta ! property "og:type" ]
! A.content "website" meta_ [ property_ "og:title", content_ title ]
H.meta ! property "og:image" meta_ [ property_ "og:type", content_ "website" ]
! A.content (textValue image) meta_ [ property_ "og:image", content_ image ]
H.meta ! property "og:description" meta_ [ property_ "og:description", content_ description ]
! A.content (textValue description) title_ $ toHtml title
H.title $ toHtml title
H.body do body_ do
H.header ! A.id "hd" $ H.section do header_ [ id_ "hd" ] $ section_ do
H.a ! A.href "/" $ logo a_ [ href_ "/" ] $ logo
H.section $ H.nav do section_ $ nav_ do
H.a ! A.href "/projects.html" $ "Projects" a_ [ href_ "/projects.html" ] "Projects"
H.a ! A.href "/visual.html" $ "Visual" a_ [ href_ "/visual.html" ] "Visual"
H.a ! A.href "/readings.html" $ "Readings" a_ [ href_ "/readings.html" ] "Readings"
H.a ! A.href "/quid.html" $ "Quid" a_ [ href_ "/quid.html" ] "Quid"
H.a ! A.href "/atom.xml" $ "Feed" a_ [ href_ "/atom.xml" ] "Feed"
H.main content main_ content
H.footer ! A.id "ft" $ do footer_ [ id_ "ft" ] do
"flupe 2020 · " "flupe 2020 · "
H.a ! A.href "https://creativecommons.org/licenses/by-nc/2.0/" $ "CC BY-NC 2.0" a_ [ href_ "https://creativecommons.org/licenses/by-nc/2.0/" ]
"CC BY-NC 2.0"
" · " " · "
H.a ! A.href "https://instagram.com/ba.bou.m/" $ "instagram" a_ [ href_ "https://instagram.com/ba.bou.m/" ] "instagram"
" · " " · "
H.a ! A.href "/atom.xml" $ "feed" a_ [ href_ "/atom.xml" ] "feed"