initial commit

src/Ical.hs

@@ -0,0 +1,226 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Ical (Event (..), readCalendar, getEventsFromTo, groupEvents) where
+
+import Data.Function (on)
+import Data.List (groupBy, sort, sortBy, sortOn)
+import Data.Map qualified as M
+import Data.Maybe (fromMaybe)
+import Data.Ord (comparing)
+import Data.Text qualified as T
+import Data.Text.Read qualified as R
+import Data.Time (Day, DayOfWeek (Monday), addDays, addGregorianMonthsClip, addGregorianYearsClip, defaultTimeLocale, parseTimeM, weekFirstDay)
+import Data.Time.Calendar.WeekDate (toWeekDate)
+import Data.Time.LocalTime
+
+data Limit = Count Int | Until Day | NoLimit
+  deriving (Show, Eq)
+
+data Frequency
+  = Daily
+  | Weekly {byDays :: [Int]}
+  | Monthly
+  | Yearly
+  | NoFreq
+  deriving (Show, Eq)
+
+data RRule = RRule
+  { freq :: Frequency,
+    interval :: Int,
+    limit :: Limit
+  }
+  deriving (Show, Eq)
+
+data Event = Event
+  { summary :: T.Text,
+    euid :: T.Text,
+    description :: T.Text,
+    location :: T.Text,
+    dtStart :: LocalTime,
+    dtEnd :: LocalTime,
+    rrule :: RRule
+  }
+  deriving (Show)
+
+readCalendar :: T.Text -> [Either String Event]
+readCalendar input =
+  let allBlocks = map T.lines $ T.splitOn "BEGIN:VEVENT" input
+      eventBlocks = drop 1 allBlocks -- Skip the header before the first VEVENT
+   in map toEvent eventBlocks
+
+groupEvents :: [Event] -> [(Day, [Event])]
+groupEvents events =
+  let sorted = sortOn dtStart events
+      grouped = groupBy ((==) `on` getDay) sorted
+   in map (\g -> (getDay (head g), g)) grouped
+
+getDay :: Event -> Day
+getDay = localDay . dtStart
+
+getEventsFromTo :: [Event] -> Day -> Day -> [Event]
+getEventsFromTo input startDay endDay =
+  -- let allEvents = foldl (\x y -> x ++ (expandEvent y endDay)) [] input
+  --     sorted = sortBy (comparing dtStart) allEvents
+  -- remove events that are after to avoid expanding, maybe not more efficent
+  let validEvents = filter ((< endDay) . getDay) input
+      allEvents = concatMap (\e -> expandEvent e endDay) validEvents
+      sorted = sortBy (comparing dtStart) allEvents
+   in filter ((> startDay) . getDay) sorted
+
+streamDates :: Day -> RRule -> [Day]
+streamDates start (RRule freq interval _) = case freq of
+  NoFreq -> [start]
+  Daily -> iterate (addDays $ toInteger interval) start
+  Monthly -> [addGregorianMonthsClip (toInteger $ n * interval) start | n <- [0 ..]]
+  Yearly -> [addGregorianYearsClip (toInteger $ n * interval) start | n <- [0 ..]]
+  Weekly days ->
+    let stepDays = toInteger (7 * interval)
+        targetOffsets =
+          if null days
+            then [dayOfWeekToInt start]
+            else sort days
+
+        mondayOfStart = weekFirstDay Monday start
+
+        weekMondays = iterate (addDays stepDays) mondayOfStart
+     in [ d
+        | monday <- weekMondays,
+          offset <- targetOffsets,
+          let d = addDays (toInteger offset) monday,
+          d >= start
+        ]
+
+applyLimit :: Limit -> [Day] -> [Day]
+applyLimit lim dates = case lim of
+  NoLimit -> dates
+  Until u -> takeWhile (<= u) dates
+  Count c -> take c dates
+
+expandEvent :: Event -> Day -> [Event]
+expandEvent e@(Event _ _ _ _ start end rule) maxViewDate =
+  let startDate = localDay start
+      duration = diffLocalTime end start
+
+      infiniteStream = streamDates startDate rule
+
+      validRuleDates = applyLimit (limit rule) infiniteStream
+
+      -- TODO: I think its alway sorted so this works
+      visibleDates = takeWhile (<= maxViewDate) validRuleDates
+   in [ e
+          { dtStart = newStart,
+            dtEnd = addLocalTime duration newStart,
+            rrule = rule {freq = NoFreq}
+          }
+      | d <- visibleDates,
+        let newStart = start {localDay = d}
+      ]
+
+dayOfWeekToInt :: Day -> Int
+dayOfWeekToInt d =
+  let (_, _, dInt) = toWeekDate d
+   in dInt - 1
+
+parseDate :: T.Text -> Either String LocalTime
+parseDate input =
+  let str = T.unpack input
+      fmtDateTime = "%Y%m%dT%H%M%S"
+      fmtDate = "%Y%m%d"
+   in case parseTimeM True defaultTimeLocale fmtDateTime str of
+        Just t -> Right t
+        Nothing -> case parseTimeM True defaultTimeLocale fmtDate str of
+          Just t -> Right t
+          Nothing -> Left $ "Could not parse date: " ++ str
+
+parseLine :: T.Text -> (T.Text, T.Text)
+parseLine line =
+  let (key, value) = T.breakOn ":" line
+   in ( T.takeWhile (/= ';') key,
+        T.drop 1 value
+      )
+
+daynameToInt :: T.Text -> Either String Int
+daynameToInt day
+  | day == "MO" = Right 0
+  | day == "TU" = Right 1
+  | day == "WE" = Right 2
+  | day == "TH" = Right 3
+  | day == "FR" = Right 4
+  | day == "SA" = Right 5
+  | day == "SU" = Right 6
+  | otherwise = Left "Invalid week day"
+
+-- TODO: clean this up
+parseRRule :: T.Text -> Either String RRule
+parseRRule "" = Right $ RRule NoFreq 0 NoLimit
+parseRRule input = do
+  let params = M.fromList $ map parsePair $ T.splitOn ";" input
+
+  freq <- lookupParam "FREQ" params
+
+  let interval = fromMaybe 1 $ do
+        val <- M.lookup "INTERVAL" params
+        case R.decimal val of
+          Right (n, _) -> Just n
+          _ -> Nothing
+
+  limit <- case (M.lookup "COUNT" params, M.lookup "UNTIL" params) of
+    (Just c, _) -> do
+      (n, _) <- R.decimal c <?> "Invalid COUNT"
+      pure $ Count n
+    (_, Just d) -> do
+      date <- parseDate d <+?> "Invalid UNTIL date: "
+      pure $ Until $ localDay date
+    _ -> pure NoLimit
+
+  case freq of
+    "DAILY" -> Right $ RRule Daily interval limit
+    "WEEKLY" -> do
+      days <- parseByDay $ M.lookup "BYDAY" params
+      Right $ RRule (Weekly days) interval limit
+    "MONTHLY" -> Right $ RRule Monthly interval limit
+    "YEARLY" -> Right $ RRule Yearly interval limit
+    _ -> Left $ "Unknown FREQ: " ++ T.unpack freq
+  where
+    parsePair t = let (k, v) = T.breakOn "=" t in (k, T.drop 1 v)
+
+    lookupParam key m = case M.lookup key m of
+      Just v -> Right v
+      Nothing -> Left "Missing FREQ in RRULE"
+
+    parseByDay Nothing = Right []
+    parseByDay (Just txt) = traverse daynameToInt $ T.splitOn "," txt
+
+toEvent :: [T.Text] -> Either String Event
+toEvent input = do
+  let params = M.fromList $ map parseLine input
+
+  let require p = maybe (Left $ "Missing property: " ++ T.unpack p) Right $ M.lookup p params
+  let optional opt p = M.findWithDefault opt p params
+
+  summText <- require "SUMMARY"
+  uid <- require "UID"
+  startText <- require "DTSTART"
+  endText <- require "DTEND"
+
+  let loc = optional "No location" "LOCATION"
+  let descriptionText = optional "No description" "DESCRIPTION"
+  let rruleTxt = M.lookup "RRULE" params
+
+  rrule <- case rruleTxt of
+    Just txt -> parseRRule txt
+    Nothing -> Right $ RRule NoFreq 0 NoLimit
+
+  startDate <- parseDate startText <+?> "Error reading start Date: "
+  endDate <- parseDate endText <+?> "Error reading end Date: "
+  pure $ Event summText uid descriptionText loc startDate endDate rrule
+
+-- This is very nice, replace Left with a different Left
+(<?>) :: Either e a -> String -> Either String a
+Left _ <?> msg = Left msg
+Right x <?> _ = Right x
+
+-- Append prev Left to the end
+(<+?>) :: Either String a -> String -> Either String a
+Left x <+?> msg = Left $ msg ++ x
+Right x <+?> _ = Right x

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