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

4
src/Common.hs
View File

@ -5,10 +5,10 @@ module Common
, module System.FilePath
, module Achille
, module Achille.Recipe.Pandoc
, module Text.Blaze.Html
, module Data.Text
, module Control.Monad
, module Data.Maybe
, module Lucid
) where
import Achille
@ -21,4 +21,4 @@ import Data.String (fromString)
import Data.Text (Text)
import Data.Maybe (fromMaybe, mapMaybe)
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
import qualified Data.Yaml as Yaml
import Text.Blaze
import Lucid
import Common
import Templates
@ -19,7 +19,7 @@ main = achilleWith config do
-- quid page
match_ "./quid.rst" $
compilePandoc
<&> preEscapedText
<&> toHtmlRaw
<&> outerWith def {Config.title = "quid"}
>>= saveFileAs (-<.> "html")

22
src/Posts.hs
View File

@ -2,15 +2,13 @@
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.Binary (Binary, put, get)
import Data.Time (UTCTime, defaultTimeLocale)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Format (rfc822DateFormat, formatTime)
import GHC.Generics
import Lucid
import Text.Atom.Feed as Atom
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 =
outerWith def { Config.title = title } do
H.h1 $ toHtml title
h1_ $ toHtml title
toLink source "View source"
preEscapedText content
toHtmlRaw content
renderIndex :: [Post] -> Text -> Html
renderIndex :: [Post] -> Text -> Html ()
renderIndex posts content =
outer do
preEscapedText content
H.h2 "Latest posts"
H.ul ! A.id "pidx" $ forM_ posts \post ->
H.li do
H.span $ fromString $ showDate (postDate post)
toHtmlRaw content
h2_ "Latest posts"
ul_ [ id_ "pidx" ] $ forM_ posts \post ->
li_ do
span_ $ fromString $ showDate (postDate 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 Text.Blaze
import Common
import Types
import Page
import Config
import Templates
import Lucid
getKey :: String -> (Int, String)
@ -39,7 +39,7 @@ buildProject = do
let (key, file) = getKey $ takeFileName filepath
(TitledPage title _, doc) <- readPandocMetadataWith ropts
renderPandocWith wopts doc
<&> preEscapedText
<&> toHtmlRaw
<&> outerWith (def {Config.title = fromString title})
>>= saveFileAs (const $ file -<.> "html")
<&> (title,)

174
src/Templates.hs
View File

@ -1,144 +1,152 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
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.Format (formatTime, defaultTimeLocale)
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 Common
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 = formatTime defaultTimeLocale "%b %d, %_Y"
loading :: AttributeValue -> Attribute
loading = I.customAttribute "loading"
loading_ :: Text -> Attribute
loading_ = makeAttribute "loading"
property :: AttributeValue -> Attribute
property = I.customAttribute "property"
property_ :: Text -> Attribute
property_ = makeAttribute "property"
toLink :: FilePath -> Html -> Html
toLink url = H.a ! A.href (fromString $ "/" <> url)
toLink :: FilePath -> Html () -> Html ()
toLink url = a_ [ href_ (fromString $ "/" <> url) ]
renderVisual :: Text -> [Timestamped FilePath] -> Html
renderVisual :: Text -> [Timestamped FilePath] -> Html ()
renderVisual txt imgs =
outer do
preEscapedText txt
H.hr
H.section $ forM_ imgs \ (Timestamped _ p) ->
H.figure $ H.img ! A.src (fromString p)
! loading "lazy"
toHtmlRaw txt
hr_ []
section_ $ forM_ imgs \ (Timestamped _ p) ->
figure_ $ img_ [ src_ (fromString p), loading_ "lazy" ]
renderProject :: Project -> [(String, FilePath)] -> Text -> Html
renderProject :: Project -> [(String, FilePath)] -> Text -> Html ()
renderProject (project@Project{title,..}) children content =
outerWith def { Config.title = fromString title
, Config.description = fromString subtitle
} do
H.header ! A.class_ "project" $ do
H.div $ H.img ! A.src "logo.svg"
H.div do
H.h1 $ fromString $ title
H.p $ fromString $ subtitle
H.ul $ forM_ (Map.toList labels) \(k, v) -> H.li do
header_ [ class_ "project" ] do
div_ (img_ [ src_ "logo.svg" ])
div_ do
h1_ (fromString title)
p_ (fromString subtitle)
ul_ $ forM_ (Map.toList labels) \(k, v) -> li_ do
fromString k <> ": "
if k == "repo" then
H.a ! A.href (fromString $ "https://github.com/" <> v)
a_ [ href_ (fromString $ "https://github.com/" <> v) ]
$ fromString v
else fromString v
when (length children > 0) $
H.ol ! A.class_ "pages" $ forM_ children \(t,l) ->
H.li $ H.a ! A.href (fromString l) $ (fromString t)
preEscapedText content
ol_ [ class_ "pages" ] $ forM_ children \(t,l) ->
li_ $ a_ [ href_ (fromString l) ] (fromString t)
toHtmlRaw content
renderReadings :: [Book] -> Html
renderReadings :: [Book] -> Html ()
renderReadings books =
outerWith def { Config.title = "readings"
, Config.description = "books I've read"
} do
H.table ! A.class_ "books" $
table_ [ class_ "books" ] $
forM_ books \ Book {title,author,rating,completed} ->
H.tr do
H.td $ toHtml title
H.td $ toHtml author
H.td $ fromString $ case rating of
tr_ do
td_ (toHtml title)
td_ (toHtml author)
td_ $ fromString $ case rating of
Just r -> replicate r '★'
Nothing -> "·"
H.td $ fromString $ case completed of
td_ $ fromString $ case completed of
Just d -> formatTime defaultTimeLocale "%m/%0Y"
$ zonedTimeToUTC d
Nothing -> "·"
renderProjects :: Text -> [(Project, FilePath)] -> Html
renderProjects :: Text -> [(Project, FilePath)] -> Html ()
renderProjects txt paths =
outer do
preEscapedText txt
H.ul ! A.class_ "projects" $ do
forM_ paths \(Project {title,..}, link) -> H.li $ H.a ! A.href (fromString link) $ do
H.div $ H.img ! A.src (fromString $ link </> "logo.svg")
H.div do
H.h2 $ fromString title
H.p $ fromString subtitle
toHtmlRaw txt
ul_ [ class_ "projects" ] do
forM_ paths \(Project {title,..}, link) -> li_ $ a_ [ href_ (fromString link) ] $ do
div_ $ img_ [ src_ (fromString $ link </> "logo.svg") ]
div_ do
h2_ (fromString title)
p_ (fromString subtitle)
-- H.ul $ forM_ (Map.toList $ Types.labels project) \(k, v) ->
-- H.li $ (fromString k <> ": " <> fromString v)
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 :: Html ()
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
outerWith :: SiteConfig -> Html -> Html
outerWith SiteConfig{title,..} content = H.docTypeHtml do
H.head do
H.meta ! A.name "viewport"
! A.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"
H.meta ! charset "utf-8"
H.link ! A.rel "stylesheet" ! A.href "/assets/theme.css"
H.link ! A.rel "shortcut icon"
! A.type_ "image/svg"
! A.href "/assets/favicon.svg"
H.link ! A.rel "alternate"
! A.type_ "application/atom+xml"
! A.href "/atom.xml"
H.meta ! property "og:title"
! A.content (textValue title)
H.meta ! property "og:type"
! A.content "website"
H.meta ! property "og:image"
! A.content (textValue image)
H.meta ! property "og:description"
! A.content (textValue description)
H.title $ toHtml title
outerWith :: SiteConfig -> Html () -> Html ()
outerWith SiteConfig{title,..} content = doctypehtml_ do
head_ do
meta_ [ name_ "viewport"
, content_ "width=device-width, initial-scale=1.0, user-scalable=yes"
]
meta_ [ name_ "theme-color", content_ "#000000" ]
meta_ [ name_ "robots", content_ "index, follow" ]
meta_ [ charset_ "utf-8" ]
link_ [ rel_ "stylesheet", href_ "/assets/theme.css" ]
link_ [ rel_ "shortcut icon"
, type_ "image/svg"
, href_ "/assets/favicon.svg"
]
link_ [ rel_ "alternate"
, type_ "application/atom+xml"
, href_ "/atom.xml"
]
meta_ [ property_ "og:title", content_ title ]
meta_ [ property_ "og:type", content_ "website" ]
meta_ [ property_ "og:image", content_ image ]
meta_ [ property_ "og:description", content_ description ]
title_ $ toHtml title
H.body do
H.header ! A.id "hd" $ H.section do
H.a ! A.href "/" $ logo
H.section $ H.nav do
H.a ! A.href "/projects.html" $ "Projects"
H.a ! A.href "/visual.html" $ "Visual"
H.a ! A.href "/readings.html" $ "Readings"
H.a ! A.href "/quid.html" $ "Quid"
H.a ! A.href "/atom.xml" $ "Feed"
body_ do
header_ [ id_ "hd" ] $ section_ do
a_ [ href_ "/" ] $ logo
section_ $ nav_ do
a_ [ href_ "/projects.html" ] "Projects"
a_ [ href_ "/visual.html" ] "Visual"
a_ [ href_ "/readings.html" ] "Readings"
a_ [ href_ "/quid.html" ] "Quid"
a_ [ href_ "/atom.xml" ] "Feed"
H.main content
main_ content
H.footer ! A.id "ft" $ do
footer_ [ id_ "ft" ] do
"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"