generator/Site/Page.hs

   1 module Site.Page where
   2
   3 import Data.Default (def)
   4 import Data.List qualified as List
   5 import Data.Map.Strict qualified as Map
   6 import Data.Set qualified as Set
   7 import Data.Time qualified as Time
   8 import Ema qualified
   9 import Graphics.ThumbnailPlus qualified as Thumb
  10 import Network.URI.Slug (Slug)
  11 import PyF
  12 import Relude
  13 import Text.Blaze.Html5 ((!))
  14 import Text.Blaze.Html5 qualified as H
  15 import Text.Blaze.Html5.Attributes qualified as A
  16 import Text.Blaze.Internal qualified as Blaze
  17 import Text.Pandoc.Options qualified as Pandoc
  18 import Text.Pandoc.Writers.Shared qualified as Pandoc
  19 import Prelude ()
  20
  21 import Data.Text qualified as Text
  22 import Site.Lang
  23 import Site.Model
  24 import Site.Tag
  25 import Text.Pandoc.Builder qualified as Pandoc
  26 import Text.Pandoc.Shared qualified as Pandoc
  27 import Text.Pandoc.Walk qualified as Pandoc
  28 import Utils.Html
  29 import Utils.Pandoc as Pandoc
  30 import Utils.Pandoc.Html (htmlOfPandoc)
  31
  32 renderPage :: Model -> ([Slug], Page) -> Content
  33 renderPage
  34   model@Model{..}
  35   ( pagePath
  36     , page@Page
  37         { pageMeta = meta@Meta{metaLang}
  38         , pageDoc = Pandoc.Pandoc pandocMeta pandocBlocks
  39         }
  40     ) =
  41     Content
  42       { contentTitle = Nothing -- Just metaTitle
  43       , contentHtml = do
  44           H.div ! classes ["flex", "flex-row", "flex-wrap"] $ do
  45             H.div
  46               ! A.style "flex-grow: 2;"
  47               ! classes
  48                 [ "page"
  49                 , --, "flex-grow"
  50                   "w-96"
  51                 , "max-w-xl"
  52                 , "mx-auto"
  53                 , "fg-black"
  54                 , "bg-white"
  55                 , "px-4"
  56                 , "text-justify"
  57                 --, "float-left"
  58                 --, "flow-root"
  59                 --, "w-full"
  60                 --, "lg:w-3/4"
  61                 ]
  62               $ do
  63                 renderPageTitle
  64                 renderPageTags
  65                 renderPageSummary
  66                 -- H.hr ! classes ["min-w-full"]
  67                 H.article
  68                   ! classes
  69                     [ "article"
  70                     --, "clear-left"
  71                     ]
  72                   $ pageHtml
  73             H.div
  74               -- ! A.style "width: 20em"
  75               -- TODO: use column-gap: https://www.w3.org/TR/css-align-3/
  76               -- once implemented in Web engines.
  77               ! A.style "min-width:20rem; flex-grow: 1;"
  78               ! classes
  79                 [ "w-80"
  80                 , "max-w-xl"
  81                 , "mx-auto"
  82                 , "flex"
  83                 , "flex-col"
  84                 -- , "flex-grow"
  85                 --, "w-full"
  86                 --, "lg:w-80"
  87                 ]
  88               $ do
  89                 forM_
  90                   ( catMaybes
  91                       [ renderPageHeaders
  92                       , renderPageToC
  93                       , renderPageBackLinks
  94                       , renderTags model
  95                       , similarPages model (pagePath, pageMeta page)
  96                       ]
  97                   )
  98                   $ \aside ->
  99                     H.aside ! classes ["mb-3"] $ aside
 100                 H.aside $ recentPages metaLang model (Just (metaTitle meta))
 101                 {-
 102                 H.aside
 103                   ! classes [
 104                             --"float-left"
 105                             --, "w-full"
 106                             --, "lg:pr-0"
 107                             --, "lg:w-1/4"
 108                             ]
 109                   $ do
 110                 renderPageDiscussion
 111                 -}
 112       }
 113     where
 114       doc = Pandoc.makeSections True Nothing pandocBlocks
 115       tocHtmlMaybe =
 116         case Pandoc.toTableOfContents writerOpts $
 117           Pandoc.walk walkToC doc of
 118           Pandoc.BulletList [] -> Nothing
 119           ul -> Just $ htmlOfPandoc writerOpts $ Pandoc.Pandoc pandocMeta [ul]
 120       walkToC = \case
 121         -- Hyper-link section numbers.
 122         Pandoc.Div
 123           (divId, "section" : divCls, divDict)
 124           (Pandoc.Header level ("", headerCls, headerDict) headerInlines : divBlocks) ->
 125             Pandoc.Div
 126               (divId, "section" : divCls, divDict)
 127               $
 128               -- level + 1 to only have the title in a <h1>
 129               Pandoc.Header
 130                 (level + 1)
 131                 (divId, headerCls, ("number", number) : headerDict)
 132                 (Pandoc.Space : Pandoc.Span ("", ["font-bold" | level == 1], []) headerInlines : []) :
 133               divBlocks
 134             where
 135               sectionNum = fromMaybe mempty $ List.lookup "number" headerDict
 136               sectionNums = Text.split ('.' ==) sectionNum
 137               number
 138                 | List.length sectionNums == 1 = sectionNum <> "."
 139                 | otherwise = sectionNum
 140         x -> x
 141
 142       writerOpts =
 143         def
 144           { Pandoc.writerExtensions = Pandoc.enableExtension Pandoc.Ext_smart Pandoc.pandocExtensions
 145           , -- makeSections is called here and customized
 146             Pandoc.writerNumberSections = False
 147           , -- toTableOfContents is called here and customized
 148             Pandoc.writerTableOfContents = False
 149           , Pandoc.writerSectionDivs = True
 150           , Pandoc.writerTOCDepth = maxBound
 151           }
 152       pageHtml = htmlOfPandoc writerOpts $
 153         Pandoc.walk
 154           ( \case
 155               Pandoc.Link (linkId, linkCls, linkKVs) label (uri, title)
 156                 | not (Text.isInfixOf ":" uri) -> do
 157                   -- keep only local URIs
 158                   Pandoc.Link
 159                     (linkId, ["text-red-800"] <> linkCls, linkKVs)
 160                     label
 161                     (uri <> ".html", title)
 162               inl -> inl
 163           )
 164           $ (`Pandoc.walk` Pandoc.Pandoc pandocMeta doc) $ \case
 165             Pandoc.BulletList items
 166               | all
 167                   ( \case
 168                       Pandoc.Plain (Pandoc.Str "pictures:" : Pandoc.Space : Pandoc.Str _ : _) : [] -> True
 169                       _ -> False
 170                   )
 171                   items ->
 172                 walkPictures items
 173             blk -> blk
 174       renderPageTitle =
 175         H.header $
 176           H.h1
 177             ! classes
 178               [ "bg-black"
 179               , "font-bold"
 180               , "leading-relaxed"
 181               , "mb-1"
 182               , "mt-4"
 183               , "text-center"
 184               , "text-lg"
 185               , "text-white"
 186               ]
 187             $ H.text (metaTitle meta)
 188       renderPageTags =
 189         unless (null (metaTags meta)) do
 190           H.aside
 191             ! classes
 192               [ "flex"
 193               , "flex-row"
 194               , "flex-wrap"
 195               , "mb-2"
 196               --, "max-w-screen-md"
 197               ]
 198             $ forM_ (metaTags meta) $
 199               renderTag model False
 200       renderPageSummary =
 201         whenJust (metaSummary meta) $ \Markdown{..} -> do
 202           H.div
 203             ! classes
 204               [ "summary"
 205               , --, "border-1"
 206                 --, "border-black"
 207                 "bg-gray-100"
 208               , "mb-2"
 209               ]
 210             $ do
 211               H.span
 212                 ! classes
 213                   [ "bg-black"
 214                   , "font-bold"
 215                   , "px-4"
 216                   , --, "mb-1"
 217                     --, "text-left"
 218                     "text-xs"
 219                   , "text-white"
 220                   , "display-inline"
 221                   , "float-left"
 222                   ]
 223                 $ H.text "Résumé"
 224               H.div ! classes ["px-2"] $
 225                 H.span
 226                   ! classes
 227                     [ "inline"
 228                     , "italic"
 229                     , "ml-2"
 230                     ]
 231                   $ htmlOfPandoc def markdownPandoc
 232       -- H.span
 233       --   ! classes [ "bg-gray-500"
 234       --             , "float-right"
 235       --             , "px-4"
 236       --             , "mt-1"
 237       --             , "text-white"
 238       --             , "font-bold"
 239       --             ]
 240       --   ! A.style "font-size: 0.55rem"
 241       --   $ [fmt|{signsCount pageDoc} signes|]
 242       renderPageHeaders = Just $
 243         H.table
 244           ! classes
 245             [ "document-headers"
 246             , "border-collapse"
 247             , "border-white"
 248             ]
 249           $ forM_ (zip [0 :: Int ..] headers) $ \(headerRank, (headerName, headerValue)) -> do
 250             H.tr
 251               ! classes
 252                 [ if headerRank `mod` 2 == 0
 253                     then "bg-gray-300"
 254                     else "bg-gray-200"
 255                 ]
 256               $ do
 257                 H.th
 258                   ! classes
 259                     [ "font-bold"
 260                     , "bg-black"
 261                     , "text-white"
 262                     , "px-3"
 263                     , "whitespace-nowrap"
 264                     , if headerRank /= 0 then "border-t" else ""
 265                     ]
 266                   $ do
 267                     H.text (headerName metaLang)
 268                 H.td
 269                   ! classes
 270                     [ "px-3"
 271                     , "w-full"
 272                     , if headerRank /= 0 then "border-t" else ""
 273                     ]
 274                   $ do
 275                     headerValue
 276         where
 277           dateHtml = Time.formatTime (timeLocale metaLang) "%-e %B %Y"
 278           headers :: [(Lang -> Text, H.Html)]
 279           headers =
 280             catMaybes
 281               [ metaAuthors meta >>= \authors ->
 282                   Just
 283                     ( i18nAuthors
 284                     , H.ul $
 285                         forM_ authors $ \Entity{..} ->
 286                           H.li $
 287                             case entityMail of
 288                               Nothing -> H.text entityName
 289                               Just mail ->
 290                                 H.a
 291                                   ! A.href ("mailto:" <> H.textValue mail)
 292                                   $ H.text entityName
 293                     )
 294               , metaUpdated meta >>= \date ->
 295                   Just (i18nUpdated, H.string $ dateHtml date)
 296               , metaPublished meta >>= \date ->
 297                   Just (i18nPublished, H.string $ dateHtml date)
 298               , let lisense = fromMaybe "CC-BY-SA-4.0" (metaLisense meta)
 299                  in Just (i18nLisense, H.a ! A.href [fmt|https://spdx.org/licenses/{lisense}.html|] $ H.text lisense)
 300               , metaDiscussion meta >>= \Discussion{..} ->
 301                   Just
 302                     ( i18nDiscussion
 303                     , H.a ! A.href (H.textValue [fmt|mailto:{discussionMail}|]) $
 304                         H.text discussionMail
 305                     )
 306               , Just (i18nLanguage, H.text $ langText metaLang)
 307               ]
 308       renderPageToC =
 309         tocHtmlMaybe <&> \tocHtml ->
 310           H.nav
 311             ! classes
 312               [ "toc"
 313               ]
 314             $ do
 315               H.details ! A.open "" $ do
 316                 H.summary
 317                   ! classes
 318                     [ "bg-black"
 319                     , "border-l-8"
 320                     , "border-black"
 321                     , "text-white"
 322                     ]
 323                   $ H.h2
 324                     ! classes
 325                       [ "font-bold"
 326                       , "pl-1"
 327                       , "text-left"
 328                       , "text-xs"
 329                       , "inline-block"
 330                       ]
 331                     $ i18nTableOfContent metaLang
 332                 H.div
 333                   ! classes
 334                     [ "p-2"
 335                     , "bg-yellow-50"
 336                     , "border-1"
 337                     , "border-black"
 338                     ]
 339                   $ tocHtml
 340       renderPageBackLinks =
 341         let bls = backLinks (LocalLink pagePath) modelLocalLinks
 342          in if null bls
 343               then Nothing
 344               else Just do
 345                 H.nav
 346                   ! classes
 347                     [ "backlinks"
 348                     ]
 349                   $ do
 350                     H.details ! A.open "" $ do
 351                       H.summary
 352                         ! classes
 353                           [ "bg-black"
 354                           , "border-l-8"
 355                           , "border-black"
 356                           , "text-white"
 357                           ]
 358                         $ H.h2
 359                           ! classes
 360                             [ "font-bold"
 361                             , "pl-1"
 362                             , "text-left"
 363                             , "text-xs"
 364                             , "inline-block"
 365                             ]
 366                           $ i18nBacklinks metaLang
 367                       H.ul $
 368                         forM_ (modelLocalLinks Map.! pagePath) $ \(LocalLink lnk) ->
 369                           H.li $ H.string $ show lnk
 370                       H.ul
 371                         ! classes
 372                           [ "p-2"
 373                           , "bg-yellow-50"
 374                           , "border-1"
 375                           , "border-black"
 376                           ]
 377                         $ do
 378                           forM_ bls $ \bl ->
 379                             H.li do
 380                               "— "
 381                               H.a
 382                                 ! A.href (H.stringValue (Ema.encodeRoute model (Right @FilePath (RoutePage bl))))
 383                                 $ H.text (metaTitle (pageMeta (modelPosts Map.! bl)))
 384       renderPageDiscussion =
 385         whenJust (metaDiscussion meta) $ \Discussion{..} -> do
 386           H.aside
 387             ! A.id "discussion"
 388             ! classes
 389               [ "discussion"
 390               , "bg-gray-100"
 391               , --, "float-left"
 392                 --, "clear-both"
 393                 "w-full"
 394               , --, "h-screen"
 395                 "p-0"
 396               , "mt-4"
 397               ]
 398             $ do
 399               H.h2
 400                 ! classes
 401                   [ "bg-gray-500"
 402                   , "font-bold"
 403                   , "px-4"
 404                   , "text-left"
 405                   , "text-sm"
 406                   , "text-white"
 407                   ]
 408                 $ do
 409                   H.a
 410                     ! A.href "#discussion"
 411                     ! classes ["text-white"]
 412                     $ H.text (i18nDiscussion metaLang)
 413                   H.span
 414                     ! classes ["font-normal", "text-sm"]
 415                     $ do
 416                       " ("
 417                       H.a ! A.href ("mailto:" <> H.textValue discussionMail) $
 418                         H.text discussionMail
 419                       ")"
 420               H.iframe
 421                 ! classes
 422                   [ "block"
 423                   , "border-1"
 424                   , --, "float-left", "clear-left"
 425                     "w-full"
 426                   ]
 427                 ! A.style "height:100vh"
 428                 ! A.src (H.textValue discussionUrl)
 429                 ! A.src "http://oignon.wg:8000"
 430                 ! Blaze.attribute "loading" " loading=\"" "lazy"
 431                 $ ""
 432       walkPictures items =
 433         Pandoc.Div
 434           ("", ["pictures", "mb-2"], [])
 435           [ Pandoc.BulletList $
 436               mconcat $
 437                 items <&> \case
 438                   Pandoc.Plain (Pandoc.Str "pictures:" : Pandoc.Space : Pandoc.Str (decodeSlugs -> prefix) : plainInlines) : [] ->
 439                     [ let alt = Pandoc.trimWhiteInlines plainInlines
 440                        in let (maxThumbSize, maxThumbPath) = List.last thumbs
 441                            in let (minThumbSize, _minThumbPath) = List.head $ traceShowId thumbs
 442                                in pure $
 443                                     Pandoc.Plain
 444                                       [ Pandoc.Link
 445                                           ("", [], [])
 446                                           [ {-
 447                                             Pandoc.RawInline "html5" [fmt|
 448                                               <picture><source srcset="/{}" media="(min-width: {}px)"></picture>
 449                                             -}
 450                                             Pandoc.Image
 451                                               ( ""
 452                                               , []
 453                                               ,
 454                                                 [
 455                                                   ( "srcset"
 456                                                   , Text.intercalate ", " $
 457                                                       thumbs <&> \(size, name) ->
 458                                                         [fmt|/{name} {Thumb.width size}w|]
 459                                                   )
 460                                                 ,
 461                                                   ( "sizes"
 462                                                   , Text.intercalate
 463                                                       ", "
 464                                                       [ [fmt|(min-width: 640px) {Thumb.width maxThumbSize}px|]
 465                                                       , [fmt|{Thumb.width minThumbSize}px|]
 466                                                       ]
 467                                                   )
 468                                                 ]
 469                                               )
 470                                               alt
 471                                               ( toText $ '/' : maxThumbPath
 472                                               , Pandoc.stringify alt -- title
 473                                               )
 474                                           ]
 475                                           (encodeSlugs slugs, "")
 476                                       , Pandoc.Span
 477                                           ("", [], [])
 478                                           [ Pandoc.Str [fmt|{Thumb.width maxThumbSize}x{Thumb.height maxThumbSize}|]
 479                                           ]
 480                                       ]
 481                     | (slugs, thumbs) <- Map.toList modelPictures
 482                     , prefix `List.isPrefixOf` slugs
 483                     ]
 484                   _ -> []
 485           ]
 486
 487 i18nAuthors = \case
 488   LangEn -> "Author(s)"
 489   LangFr -> "Auteur.rice(s)"
 490   _ -> i18nUpdated LangEn
 491 i18nBacklinks = \case
 492   LangEn -> "Backlinks"
 493   LangFr -> "Rétroliens"
 494   _ -> i18nBacklinks LangEn
 495 i18nLanguage = \case
 496   LangEn -> "Language"
 497   LangFr -> "Langage"
 498   _ -> i18nLanguage LangEn
 499 i18nLisense = \case
 500   LangEn -> "Lisense"
 501   LangFr -> "License"
 502   _ -> i18nLisense LangEn
 503 i18nDiscussion = \case
 504   LangEn -> "Discussion"
 505   LangFr -> "Discussion"
 506   _ -> i18nDiscussion LangEn
 507 i18nUpdated = \case
 508   LangEn -> "Updated"
 509   LangFr -> "Mise-à-jour"
 510   _ -> i18nUpdated LangEn
 511 i18nPublished = \case
 512   LangEn -> "Published"
 513   LangFr -> "Publication"
 514   _ -> i18nPublished LangEn
 515 i18nLatestPosts = \case
 516   LangEn -> "Latest Posts"
 517   LangFr -> "Derniers Billets"
 518   _ -> i18nLatestPosts LangEn
 519 i18nTableOfContent = \case
 520   LangEn -> "Table of Content"
 521   LangFr -> "Sommaire"
 522   _ -> i18nTableOfContent LangEn
 523
 524 similarPages :: Model -> ([Slug], Meta) -> Maybe H.Html
 525 similarPages model (pagePath, meta) =
 526   if null posts
 527     then Nothing
 528     else Just do
 529       H.nav
 530         ! classes
 531           [ "similars"
 532           , "bg-gray-100"
 533           , "border-1"
 534           , "border-black"
 535           , "p-0"
 536           ]
 537         $ do
 538           H.h2
 539             ! classes
 540               [ "bg-black"
 541               , "font-bold"
 542               , "px-4"
 543               , "text-left"
 544               , "text-xs"
 545               , "text-white"
 546               ]
 547             $ do
 548               H.text "Similar Posts"
 549               H.span ! classes ["font-normal"] $
 550                 H.text [fmt| ({List.length simPosts})|]
 551           renderPagesListing model posts
 552   where
 553     simPosts =
 554       List.filter (\(path, Page{..}) -> not (null (commonTags meta pageMeta)) && path /= pagePath) $
 555         filterPosts model noFilter
 556     posts = take 5 $ List.sortOn (negate . List.length . commonTags meta . pageMeta . snd) simPosts
 557     commonTags x y = tagSet x `Set.intersection` tagSet y
 558       where
 559         tagSet = fromList . metaTags
 560
 561 renderPagesListing :: Model -> [([Slug], Page)] -> H.Html
 562 renderPagesListing model pages =
 563   H.ul do
 564     forM_ pages $ \(pagePath, Page{..}) ->
 565       H.li
 566         ! classes
 567           [ "border-t-2"
 568           , "flex"
 569           , "flex-col"
 570           , "p-2"
 571           ]
 572         $ do
 573           H.h6 ! classes ["text-sm"] $ do
 574             H.a ! classes ["hover:bg-blue-50", "rounded"]
 575               ! hrefRoute model (RoutePage pagePath)
 576               $ H.text $ metaTitle pageMeta
 577           unless (null (metaTags pageMeta)) do
 578             H.div
 579               ! classes ["flex", "flex-row", "flex-wrap"]
 580               $ forM_ (metaTags pageMeta) $
 581                 renderTag model False
 582           whenJust (metaSummary pageMeta) $ \Markdown{..} -> do
 583             H.span
 584               ! classes ["italic", "text-gray-700"]
 585               $ htmlOfPandoc def markdownPandoc
 586
 587 timeLocale :: Lang -> Time.TimeLocale
 588 timeLocale = \case
 589   LangFr ->
 590     Time.defaultTimeLocale
 591       { Time.months =
 592           [ ("janvier", "Jan")
 593           , ("février", "Févr")
 594           , ("mars", "Mar")
 595           , ("avril", "Apr")
 596           , ("mai", "May")
 597           , ("juin", "Juin")
 598           , ("juillet", "Juil")
 599           , ("août", "Aoû")
 600           , ("septembre", "Sep")
 601           , ("octobre", "Oct")
 602           , ("novembre", "Nov")
 603           , ("décembre", "Déc")
 604           ]
 605       }
 606   _ -> Time.defaultTimeLocale
 607
 608 renderSpecial :: Model -> Page -> Content
 609 renderSpecial model Page{..} =
 610   Content
 611     { contentTitle = Just $ metaTitle pageMeta
 612     , contentHtml = do
 613         H.header $
 614           H.h1
 615             ! classes
 616               [ "bg-black"
 617               , "font-bold"
 618               , "leading-relaxed"
 619               , "mb-1"
 620               , "mt-4"
 621               , "text-center"
 622               , "text-lg"
 623               , "text-white"
 624               ]
 625             $ H.text $ metaTitle pageMeta
 626         htmlOfPandoc def pageDoc
 627         recentPages (metaLang pageMeta) model Nothing
 628     }
 629
 630 recentPages :: Lang -> Model -> Maybe Text -> H.Html
 631 recentPages lang model here =
 632   H.nav
 633     ! classes
 634       [ "recents"
 635       , "bg-gray-100"
 636       , "border-1"
 637       , "border-black"
 638       , "p-0"
 639       ]
 640     $ do
 641       H.h2
 642         ! classes
 643           [ "bg-black"
 644           , "font-bold"
 645           , "px-4"
 646           , "text-left"
 647           , "text-xs"
 648           , "text-white"
 649           ]
 650         $ i18nLatestPosts lang
 651       renderPagesListing model posts
 652   where
 653     posts =
 654       List.take 5 $
 655         List.filter (\(_, Page{..}) -> isJust (metaUpdated pageMeta) && maybe True (/= metaTitle pageMeta) here) $
 656           filterPosts model noFilter
 657
 658 filterPosts :: Model -> Filter -> [([Slug], Page)]
 659 filterPosts Model{..} (Filter lang tag) =
 660   reverse $
 661     List.sortOn (metaUpdated . pageMeta . snd) $
 662       maybe id (\t -> List.filter (\(_, Page{..}) -> t `elem` metaTags pageMeta)) tag $
 663         maybe id (\l -> List.filter (\(_, Page{..}) -> l == metaLang pageMeta)) lang $
 664           Map.toList modelPosts