initial commit

src/Render.hs

@@ -0,0 +1,224 @@
+{-# 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