chipburners_web/src/Render.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Render (renderFrontpage, renderMonthview) where

import Control.Monad (forM_)
import Data.Maybe (fromMaybe)
import Data.Text qualified as T
import Data.Time (Day, MonthOfYear, Year, addDays, addGregorianMonthsClip, dayOfWeek, defaultTimeLocale, formatTime, fromGregorian, toGregorian)
import Ical
import Lucid
import Text.Printf (printf)

renderHead :: Html ()
renderHead = do
  doctype_
  head_ $ do
    meta_ [charset_ "UTF-8"]
    meta_
      [ name_ "viewport",
        content_ "width=device-width, initial-scale=1.0"
      ]
    meta_
      [ name_ "description",
        content_ "Chipburners home page"
      ]
    title_ "Chipburners"
    link_ [rel_ "stylesheet", href_ "/style.css"]

renderHeader :: Int -> Html ()
renderHeader active =
  header_ [class_ "site-header"] $ do
    nav_ [] $ do
      ul_ [class_ "nav-list"] $ do
        li_ $ a_ [href_ "/", getActive 0] "Chip"
        li_ $ a_ [href_ "/monthView", getActive 1] "Eventos"
        li_ $ a_ [href_ "/wiki", getActive 2] "Wiki"
        li_ $ a_ [href_ "/contact", getActive 3] "Contacto"
  where
    getActive cur = if cur == active then class_ "active" else class_ "inactive"

renderImage :: T.Text -> T.Text -> T.Text -> Html ()
renderImage url caption alt =
  figure_ $ do
    img_
      [ src_ url,
        alt_ alt,
        loading_ "lazy"
      ]
    figcaption_ $ toHtml caption

renderSideEvent :: Event -> Html ()
renderSideEvent e =
  li_ $ do
    span_ [class_ "event-time"] $
      toHtml (formatTime defaultTimeLocale "%H:%M" (dtStart e))
    span_ [class_ "event-title"] $ do
      let uid = euid e
      a_ [href_ ("/monthView#" <> uid), class_ "event-link"] $ toHtml (summary e)

renderDayGroup :: (Day, [Event]) -> Html ()
renderDayGroup (day, events) =
  li_ [class_ "event-group"] $ do
    time_
      [ datetime_ $ T.pack (formatTime defaultTimeLocale "%Y-%m-%d" day),
        class_ "date-header"
      ]
      $ toHtml
      $ T.pack (formatTime defaultTimeLocale "%A %d.%m.%y" day)
    ul_ [class_ "daily-events"] $
      mapM_ renderSideEvent events

renderEventList :: [Event] -> Html ()
-- mapM_ only cares about the monad I think? So it throws away the () part
-- mapM applies the monad to everz element of the list and returns monad with a list?
renderEventList events = mapM_ renderDayGroup (groupEvents events)

renderFrontpage :: [Event] -> Html ()
renderFrontpage events = do
  doctype_
  html_ [lang_ "es"] $ do
    renderHead
    body_ $ do
      renderHeader 0
      div_ [class_ "wrapper"] $ do
        div_ [class_ "layout"] $ do
          main_ [id_ "main-content", class_ "content"] $ do
            section_ [class_ "intro"] $ do
              h1_ "Chipburners_"
              p_ [class_ "lead"] $
                "Frase motivadora aqui"
              p_ $ do
                "Buenos dias, "
                br_ []
                "Somos un grupo d personas y entidades interesados en infromatica y \
                \las technologias relacionadas. "
                br_ []
                "Este hackerspace ha sido creado como manera d juntar gente con intereses \
                \similares y compartir conocimientos. "
                br_ []
                "Contactanos en "
                a_ [href_ "/contact"] "signal"
                "!"

            section_ [class_ "image-gallery"] $ do
              renderImage "example.com" "Imagen sobre algo" "Imagen interesante"

          aside_ [class_ "sidebar"] $ do
            section_ [class_ "events-panel"] $ do
              h2_ "Eventos"
              renderEventList events

chunksOf :: Int -> [a] -> [[a]]
chunksOf _ [] = []
chunksOf n xs =
  let (ys, zs) = splitAt n xs
   in ys : chunksOf n zs

padZero :: Int -> String
padZero n = if n < 10 then "0" ++ show n else show n

renderCalendarEvent :: Event -> Html ()
renderCalendarEvent e = do
  let uid = euid e
  li_ [class_ "event-item"] $ do
    -- (toHtml $ summary e)
    a_ [href_ ("#" <> uid), class_ "event-link"] $ toHtml (summary e)
    div_ [class_ "event-popup", id_ uid] $ do
      h1_ [] $ do
        (toHtml $ summary e)
        a_
          [ href_ ("#None"),
            class_ "close-btn"
          ]
          "×"
      p_ [class_ "lead"] $
        toHtml $
          T.pack $
            printf
              "%s -> %s - %s"
              (formatTime defaultTimeLocale "%A %d.%m.%y" $ dtStart e)
              (formatTime defaultTimeLocale "%H:%M" $ dtStart e)
              (formatTime defaultTimeLocale "%H:%M" $ dtEnd e)

      p_ [] $
        toHtml $
          description e

renderMonthview :: (Year, MonthOfYear) -> Day -> [(Day, [Event])] -> Html ()
renderMonthview (year, month) today groupedEvents = do
  let firstOfMonth = fromGregorian year month 1
      wd = dayOfWeek firstOfMonth

      daysToSubtract = fromEnum wd - 1
      startOfGrid = addDays (fromIntegral (-daysToSubtract)) firstOfMonth

      gridDays = [addDays i startOfGrid | i <- [0 .. 41]]
      weeks = chunksOf 7 gridDays

      prevMonthDay = addGregorianMonthsClip (-1) firstOfMonth
      nextMonthDay = addGregorianMonthsClip 1 firstOfMonth
      (py, pm, _) = toGregorian prevMonthDay
      (cy, cm, _) = toGregorian today
      (ny, nm, _) = toGregorian nextMonthDay

      mkLink y m label =
        a_
          [ href_ $ T.pack $ printf "/monthView/%s/%s" (show y) (padZero m),
            class_ "nav-link"
          ]
          label

  renderHead
  renderHeader 1
  div_ [class_ "calendar-wrapper"] $ do
    header_ [class_ "calendar-header"] $ do
      h1_ [class_ "view-title"] "Vista mensual"

      nav_ [class_ "calendar-nav"] $ do
        mkLink py pm "« Mes pasado"
        mkLink cy cm "Este mes"
        mkLink ny nm "Mes siguiente »"

      h2_ [class_ "month-name"] $
        toHtml $
          formatTime defaultTimeLocale "%B %Y" $
            fromGregorian year month 1

    table_ [class_ "calendar-table"] $ do
      thead_ $ do
        tr_ $ do
          th_ "Lunes"
          th_ "Martes"
          th_ "Miercoles"
          th_ "Jueves"
          th_ "Viernes"
          th_ "Sabado"
          th_ "Domingo"

      tbody_ $ do
        forM_ weeks $ \week -> do
          tr_ $ do
            forM_ week $ \d -> do
              let (_, dM, dD) = toGregorian d
                  isCurrentMonth = dM == month
                  isToday = d == today

                  baseClasses = []
                  monthClass = if isCurrentMonth then [] else ["other-month"]
                  todayClass = if isToday then ["current-day"] else []
                  finalClass = T.intercalate " " (baseClasses ++ monthClass ++ todayClass)

                  -- TODO: lookup very slow :(
                  dayEvents = fromMaybe [] (lookup d groupedEvents)

              -- cool
              td_ ([class_ finalClass | not (T.null finalClass)]) $ do
                span_ [class_ "day-number"] (toHtml $ show dD)

                if null dayEvents
                  then return ()
                  else ul_ [class_ "event-list"] $ do
                    forM_ dayEvents $ \e ->
                      renderCalendarEvent e