Calendar view

author: Tom Smeding <tom@tomsmeding.com> 2026-04-03 22:10:56 +0200
committer: Tom Smeding <tom@tomsmeding.com> 2026-04-03 22:10:56 +0200
commit: acd9c66c663ea6b0b2fb9dd0a563897c2fae45eb (patch)
tree: 03e24cb4475367e55cc613f6b0080de7cf618063
parent: 40d29ea3eef3f7fa15ab629b5f6694dab66d9b68 (diff)
11 files changed, 400 insertions, 58 deletions
diff --git a/aratamete-ircbrowse.cabal b/aratamete-ircbrowse.cabal
index 6b5f720..9ef818d 100644
--- a/aratamete-ircbrowse.cabal
+++ b/aratamete-ircbrowse.cabal
@@ -10,6 +10,7 @@ executable aratamete-ircbrowse
   main-is: Main.hs
   other-modules:
     Cache
+    Calendar
     Config
     Index
     Mmap
@@ -27,6 +28,7 @@ executable aratamete-ircbrowse
     mustache,
     random,
     text >= 2.1.2,
+    transformers,
     time,
     unix,
     vector,
diff --git a/config.txt b/config.txt
index 2745cd3..d0dc1af 100644
--- a/config.txt
+++ b/config.txt
@@ -1,5 +1,5 @@
 port 8000
-logs /home/tom/git/ircbrowse/logs-snapshot
+logs /home/tom/git/ircbrowse/logs-snapshot-UTC
 channel liberachat #haskell haskell
 channel liberachat #kmonad kmonad
 channel liberachat #xmonad xmonad
diff --git a/pages/calendar-day.mustache b/pages/calendar-day.mustache
new file mode 100644
index 0000000..0291226
--- /dev/null
+++ b/pages/calendar-day.mustache
@@ -0,0 +1,36 @@
+<!doctype html>
+<html lang="en">
+<head>
+  <meta charset="utf-8">
+  <title>{{channel}} {{date}} ({{network}}) - ircbrowse2</title>
+  <meta name="viewport" content="width=device-width, initial-scale=1">
+  <link rel="stylesheet" href="/style.css">
+</head>
+<body>
+  <div id="gridwrapper" data-page="withheader">
+    <header>
+      <a href="/" class="hdritem">Home</a>
+      {{network}}/{{channel}}:
+      <a href="/log/{{alias}}" class="hdritem">Logs</a>
+      <a href="/cal/{{alias}}" class="hdritem">Calendar</a>
+    </header>
+    <main>
+      <h1>Logs on {{date}} ({{network}}/{{channel}})</h1>
+      <table id="events"><tbody>
+        {{#events}}
+          <tr{{#classlist}} class="{{.}}"{{/classlist}}>
+            <td>{{time}}</td>
+            <td>{{#nickwrap1}}<span class="nickwrap">{{nickwrap1}}</span>{{/nickwrap1}}{{nick}}{{#nickwrap2}}<span class="nickwrap">{{nickwrap2}}</span>{{/nickwrap2}}</td>
+            <td>{{message}}</td>
+          </tr>
+        {{/events}}
+      </tbody></table>
+      <p>All times are in UTC.</p>
+    </main>
+    <footer>
+      An IRC log viewer by
+      <a href="https://tomsmeding.com">Tom Smeding</a>.
+    </footer>
+  </div>
+</body>
+</html>
diff --git a/pages/calendar.mustache b/pages/calendar.mustache
new file mode 100644
index 0000000..79475cb
--- /dev/null
+++ b/pages/calendar.mustache
@@ -0,0 +1,59 @@
+<!doctype html>
+<html lang="en">
+<head>
+  <meta charset="utf-8">
+  <title>Calendar {{channel}} ({{network}}) - ircbrowse2</title>
+  <meta name="viewport" content="width=device-width, initial-scale=1">
+  <link rel="stylesheet" href="/style.css">
+</head>
+<body>
+  <div id="gridwrapper" data-page="withheader">
+    <header>
+      <a href="/" class="hdritem">Home</a>
+      {{network}}/{{channel}}:
+      <a href="/log/{{alias}}" class="hdritem">Logs</a>
+      <a href="/cal/{{alias}}" class="hdritem">Calendar</a>
+    </header>
+    <main>
+      <h1>Calendar: {{network}}/{{channel}}</h1>
+      {{#years}}
+        <h2>{{year}}</h2>
+        <table><tbody>
+          {{#monrows}}
+            <tr>
+              {{#months}}
+                <td class="calmonth">
+                  {{#monthname}}
+                    <b>{{monthname}}</b><br>
+                    <table class="calmonth"><tbody>
+                      {{#weeks}}
+                        <tr>
+                          {{#days}}
+                            <td>{{#date}}<a href="/cal/{{alias}}/{{year}}-{{month00}}-{{date00}}">{{date}}</a>{{/date}}</td>
+                          {{/days}}
+                          {{^days}}
+                            <td>&nbsp;</td>
+                          {{/days}}
+                        </tr>
+                      {{/weeks}}
+                      {{#phantomweek}}
+                        <tr style="opacity:0">
+                          <td>30</td><td>30</td><td>30</td><td>30</td><td>30</td><td>30</td><td>30</td>
+                        </tr>
+                      {{/phantomweek}}
+                    </tbody></table>
+                  {{/monthname}}
+                </td>
+              {{/months}}
+            </tr>
+          {{/monrows}}
+        </tbody></table>
+      {{/years}}
+    </main>
+    <footer>
+      An IRC log viewer by
+      <a href="https://tomsmeding.com">Tom Smeding</a>.
+    </footer>
+  </div>
+</body>
+</html>
diff --git a/pages/log.mustache b/pages/log.mustache
index 254a9cd..1257d7e 100644
--- a/pages/log.mustache
+++ b/pages/log.mustache
@@ -2,7 +2,7 @@
 <html lang="en">
 <head>
   <meta charset="utf-8">
-  <title>ircbrowse2: {{channel}} ({{network}})</title>
+  <title>{{channel}} ({{network}}) - ircbrowse2</title>
   <meta name="viewport" content="width=device-width, initial-scale=1">
   <link rel="stylesheet" href="/style.css">
 </head>
@@ -10,7 +10,8 @@
   <div id="gridwrapper" data-page="withheader">
     <header>
       <a href="/" class="hdritem">Home</a>
-      <span class="hdrspacer"></span>
+      {{network}}/{{channel}}:
+      <a href="/log/{{alias}}" class="hdritem">Logs</a>
       <a href="/cal/{{alias}}" class="hdritem">Calendar</a>
     </header>
     <main>
@@ -81,9 +82,8 @@
             {{/lastpage}}
           </div>
         {{/picker}}
-        <span style="margin: 0 9px 0 4px">&mdash;</span>
-        {{totalevents}} events total
       </div>
+      <p>All times are in UTC.</p>
     </main>
     <footer>
       An IRC log viewer by
diff --git a/pages/style.css b/pages/style.css
index 6fb9fbe..e7f0b43 100644
--- a/pages/style.css
+++ b/pages/style.css
@@ -9,6 +9,7 @@ body {
   --leave-color: #b66;
   --nickwrap-color: #999;
   --link-color: #33f;
+  --calendar-month-stripe-color: #c6c6da;
 }
 
 @media (prefers-color-scheme: dark) {
@@ -23,6 +24,7 @@ body {
     --leave-color: #b05757;
     --nickwrap-color: var(--meta-color);
     --link-color: #abf;
+    --calendar-month-stripe-color: #446;
   }
 }
 
@@ -32,7 +34,6 @@ html, body {
 
 body {
   font-family: "Adwaita Sans", system-ui, sans-serif;
-  font-variant-numeric: tabular-nums;
   background-color: var(--bg-color);
   color: var(--font-color);
 }
@@ -77,9 +78,12 @@ footer {
   color: var(--footer-text-color);
 }
 
-.hdrspacer {
-  display: inline-block;
-  width: 15px;
+header > .hdritem:first-child {
+  margin-right: 30px;
+}
+
+header > .hdritem:nth-child(n + 2) {
+  margin-left: 15px;
 }
 
 .hdritem {
@@ -120,6 +124,10 @@ table#events td {
   vertical-align: top;
 }
 
+table#events td:first-child {
+  font-variant-numeric: tabular-nums;
+}
+
 table#events td:nth-child(2) {
   text-align: right;
 }
@@ -136,3 +144,34 @@ table#events tr.ev-leave > td:nth-child(n + 2) { color: var(--leave-color); }
 table#events tr.ev-act > td:nth-child(n + 2) { font-style: italic; }
 table#events tr.ev-notice > td:nth-child(n + 2) { font-weight: bold; }
 table#events tr.ev-parseerror > td:nth-child(n + 2) { color: red; }
+
+/* calendar page */
+table.calmonth {
+  border-top: 1px var(--calendar-month-stripe-color) solid;
+}
+
+table.calmonth > tbody > tr {
+  padding: 0;
+}
+
+table.calmonth > tbody > tr > td {
+  text-align: right;
+  padding: 1px 2px;
+}
+
+table.calmonth > tbody > tr > td > a {
+  font-variant-numeric: tabular-nums;
+
+  /* make link fill entire cell */
+  display: inline-block;
+  width: 100%;
+}
+
+td.calmonth {
+  vertical-align: top;
+  padding: 0 10px 10px 0;
+}
+
+td.calmonth > b {
+  padding-left: 4px;
+}
diff --git a/src/Calendar.hs b/src/Calendar.hs
new file mode 100644
index 0000000..337e4ea
--- /dev/null
+++ b/src/Calendar.hs
@@ -0,0 +1,69 @@
+module Calendar where
+
+import Control.Monad (forM)
+import Control.Monad.Trans.State.Strict (evalState, state)
+import Data.Maybe (isNothing)
+import Data.Time
+
+import Util
+
+
+-- | The list of @a@ values must be as long as the number of days between the
+-- two bounds, which are inclusive. Values are returned with the appropriate
+-- day in the table.
+--
+-- * Returns a list of years with:
+--   * a list of rows, with in each row
+--     * a list of months (empty spacer if Nothing), with inside each month
+--       * a list of weeks (rows), with in each week
+--         * a list of dates in the week (empty spacer if Nothing).
+--
+-- >>> calendarLayout (fromGregorian 2025 12 16) (fromGregorian 2026 2 3) (cycle ['A'..'Z'])
+calendarLayout :: Day -> Day -> [a] -> [(Year, [[Maybe (MonthOfYear, [[Maybe (DayOfMonth, a)]])]])]
+calendarLayout startDay endDay values =
+  let (startYear, startMonth, startDate) = toGregorian startDay
+      (endYear, endMonth, endDate) = toGregorian endDay
+      takeValue = state $ \case val:vals -> (val, vals)
+                                [] -> error "calendarLayout: too few values"
+  in flip evalState values $
+       forM [startYear .. endYear] $ \year -> do
+         let row1 | year == startYear = (startMonth - 1) `div` 4
+                  | otherwise = 0
+             row2 | year == endYear = (endMonth - 1) `div` 4
+                  | otherwise = 2
+         fmap (year,) . forM [row1..row2] $ \monRowIdx -> do
+           let mon1 | year == startYear && monRowIdx == row1 = startMonth
+                    | otherwise = 4 * monRowIdx + 1
+               mon2 | year == endYear && monRowIdx == row2 = endMonth
+                    | otherwise = 4 * monRowIdx + 4
+           forM [4 * monRowIdx + 1 .. 4 * monRowIdx + 4] $ \month ->
+             if month < mon1 || month > mon2 then return Nothing else fmap Just $ do
+               let cal = monthCalendar year month
+                   filterCal predicate = map (map (\md -> if maybe False predicate md then md else Nothing))
+                   cal' | year == startYear && monRowIdx == row1 && month == mon1 = filterCal (>= startDate) cal
+                        | year == endYear   && monRowIdx == row2 && month == mon2 = filterCal (<= endDate)   cal
+                        | otherwise = cal
+                   cal'' = dropWhileEnd null $ map (\week -> if all isNothing week then [] else week) cal'
+               fmap (month,) . forM cal'' $ \week ->
+                 forM week $ \mdate ->
+                   traverse (\d -> (d,) <$> takeValue) mdate
+
+-- >>> import Text.Printf
+-- >>> error $ unlines . map (unwords . map (maybe "  " (printf "%2d"))) $ monthCalendar 2026 4
+--        1  2  3  4  5
+--  6  7  8  9 10 11 12
+-- 13 14 15 16 17 18 19
+-- 20 21 22 23 24 25 26
+-- 27 28 29 30
+monthCalendar :: Year -> MonthOfYear -> [[Maybe DayOfMonth]]
+monthCalendar year month
+  | [1, 7] <- map fromEnum [Monday, Sunday] =
+      let wkday1 = dayOfWeek (fromGregorian year month 1)
+          nskipsRow1 = fromEnum wkday1 - 1
+          lastDate = gregorianMonthLength year month
+          genRows date =
+            map Just [date .. min (date + 6) lastDate] : (if lastDate <= date + 6 then [] else genRows (date + 7))
+      in (replicate nskipsRow1 Nothing ++ map Just [1 .. 7 - nskipsRow1])
+         : genRows (7 - nskipsRow1 + 1)
+
+  | otherwise = error "DayOfWeek enum is unexpected"
diff --git a/src/Config.hs b/src/Config.hs
index 7fe9e6a..ee2909c 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -10,7 +10,6 @@ module Config (
 ) where
 
 import Data.Char (isSpace)
-import Data.List (foldl')
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
 import Data.Text (Text)
diff --git a/src/Index.hs b/src/Index.hs
index 5754e33..5486692 100644
--- a/src/Index.hs
+++ b/src/Index.hs
@@ -2,7 +2,9 @@ module Index (
   Index,
   initIndex,
   indexGetEventsLinear,
+  indexGetEventsDay,
   indexNumEvents,
+  indexCalendar,
 ) where
 
 import Data.Time.Calendar
@@ -16,6 +18,7 @@ import Data.Map.Strict qualified as Map
 import Data.Text qualified as T
 import Data.Vector.Storable qualified as VS
 import Data.Word (Word32)
+import System.Clock qualified as Clock
 import System.Directory
 import System.FilePath
 import Text.Read (readMaybe)
@@ -28,13 +31,15 @@ import ZNC
 
 
 data ChanIndex = ChanIndex
-  { ciStartDay :: Day
-  , ciEndDay :: Day
-  , ciCountUntil :: VS.Vector Int  -- ^ number of events up to and /including/ this day
-  , ciTotal :: Int }
+  { ciStartDay :: !Day
+  , ciEndDay :: !Day  -- ^ inclusive
+  , ciCountUntil :: !(VS.Vector Int)  -- ^ number of events up to and /including/ this day
+  , ciTotal :: !Int }
   deriving (Show)
 
-data Index = Index FilePath (Map Channel ChanIndex) (Cache (Channel, YMD) (ByteString, VS.Vector Word32))
+data Index = Index !FilePath
+                   !(Map Channel ChanIndex)
+                   !(Cache (Channel, YMD) (ByteString, VS.Vector Word32))
 
 -- init
 
@@ -42,6 +47,7 @@ initIndex :: FilePath -> [Channel] -> IO Index
 initIndex basedir toimport = do
   cache <- cacheNew 100
 
+  c_start <- Clock.getTime Clock.Realtime
   items <-
     fmap concat . forM (map chanNetwork toimport) $ \nwT -> do
       let nw = T.unpack nwT
@@ -56,7 +62,7 @@ initIndex basedir toimport = do
         let minday = minimum (map fst days)
             maxday = maximum (map fst days)
             ndays = fromIntegral @Integer @Int (diffDays maxday minday + 1)
-        -- traceM $ nw ++ "/" ++ ch ++ ": days = " ++ show [(toFileName (dayToDate d), i) | (d, i) <- days]
+        -- traceM $ nw ++ "/" ++ ch ++ ": days = " ++ show [(toFileName (dayToYMD d), i) | (d, i) <- days]
         let countScan = VS.fromListN ndays (drop 1 $ scanl' (+) 0 (makeCounts [minday..maxday] days))
         let ntotal = sum (map snd days)
         return (Channel nwT chT
@@ -65,6 +71,10 @@ initIndex basedir toimport = do
                   , ciEndDay = maxday
                   , ciCountUntil = countScan
                   , ciTotal = ntotal})
+  c_end <- Clock.getTime Clock.Realtime
+  let timetakenSecs = fromIntegral @_ @Double (Clock.toNanoSecs (Clock.diffTimeSpec c_start c_end)) / 1e9
+  putStrLn $ "Parsing/indexing logs in " ++ show basedir ++ " took " ++ show timetakenSecs ++ " secs"
+
   return (Index basedir (Map.fromList items) cache)
 
 makeCounts :: [Day] -> [(Day, Int)] -> [Int]
@@ -81,7 +91,7 @@ makeCounts (_:ds) [] = 0 : makeCounts ds []
 -- | Returns proper lazy list of events. Reading the files happens strictly,
 -- but parsing the events happens lazily.
 indexGetEventsLinear :: Index -> Channel -> Int -> Int -> IO [(YMDHMS, Event)]
-indexGetEventsLinear (Index basedir mp cache) chan@(Channel network channel) from count
+indexGetEventsLinear index@(Index _ mp _) chan from count
   | from + count < 0 = return []
   | from >= ciTotal ci = return []
   | otherwise = do
@@ -132,13 +142,7 @@ indexGetEventsLinear (Index basedir mp cache) chan@(Channel network channel) fro
                    ymd = YMD (fromIntegral y) (fromIntegral month) (fromIntegral d)
                    fixDate = map $ \(tod, ev) -> (YMDHMS ymd tod, ev)
                in if neventsOnDay > 0
-                    then do (bs, lineStarts) <- cacheLookup cache (chan, ymd) >>= \case
-                              Nothing -> do
-                                bs <- mapFile (basedir </> T.unpack network </> T.unpack channel </> toFileName (toGregorian day))
-                                let lineStarts = preparseLog bs
-                                cacheAdd cache (chan, ymd) (bs, lineStarts)
-                                return (bs, lineStarts)
-                              Just (bs, lineStarts) -> return (bs, lineStarts)
+                    then do (bs, lineStarts) <- loadDay index chan ymd
                             return (fixDate (parse lineStarts bs))
                     else return []
 
@@ -174,8 +178,36 @@ binSearch vec needle
 indexNumEvents :: Index -> Channel -> Int
 indexNumEvents (Index _ mp _) chan = ciTotal (mp Map.! chan)
 
+indexCalendar :: Index -> Channel -> ((Day, Day), [Int])
+indexCalendar (Index _ mp _) chan =
+  let ci = mp Map.! chan
+  in ((ciStartDay ci, ciEndDay ci)
+     ,[if i == 0
+         then ciCountUntil ci VS.! 0
+         else ciCountUntil ci VS.! i - ciCountUntil ci VS.! (i - 1)
+      | i <- [0 .. VS.length (ciCountUntil ci) - 1]])
+
+indexGetEventsDay :: Index -> Channel -> Day -> IO [(HMS, Event)]
+indexGetEventsDay index@(Index _ mp _) chan day
+  | day < ciStartDay ci || day > ciEndDay ci = return []
+  | otherwise = do
+      (bs, _lineStarts) <- loadDay index chan (dayToYMD day)
+      return (parseLog bs)
+  where
+    ci = mp Map.! chan
+
 -- utilities
 
+loadDay :: Index -> Channel -> YMD -> IO (ByteString, VS.Vector Word32)
+loadDay (Index basedir _ cache) chan@(Channel network channel) ymd = do
+  cacheLookup cache (chan, ymd) >>= \case
+    Nothing -> do
+      bs <- mapFile (basedir </> T.unpack network </> T.unpack channel </> toFileName ymd)
+      let lineStarts = preparseLog bs
+      cacheAdd cache (chan, ymd) (bs, lineStarts)
+      return (bs, lineStarts)
+    Just (bs, lineStarts) -> return (bs, lineStarts)
+
 parseFileName :: String -> (Year, MonthOfYear, DayOfMonth)
 parseFileName name
   | (y, '-' : s1) <- splitAt 4 name
@@ -194,9 +226,8 @@ parseFileName name
                 Just r -> r
                 Nothing -> error $ "No read: " ++ show s
 
-toFileName :: (Year, MonthOfYear, DayOfMonth) -> String
-toFileName (y, m, d) =
-  pad '0' 4 y ++ '-' : pad '0' 2 m ++ '-' : pad '0' 2 d ++ ".log"
+toFileName :: YMD -> String
+toFileName ymd = ymdToString ymd ++ ".log"
 
 addDays' :: Int -> Day -> Day
 addDays' = addDays . fromIntegral
diff --git a/src/Main.hs b/src/Main.hs
index 45f34db..bb5bdf7 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -4,11 +4,12 @@
 module Main (main) where
 
 import Control.Exception (mask_)
-import Control.Monad (when)
+import Control.Monad (when, forM, guard)
 import Data.ByteString (ByteString)
 import Data.ByteString qualified as BS
 import Data.ByteString.Char8 qualified as BS8
-import Data.ByteString.Lazy.Char8 qualified as BSL8
+import Data.ByteString.Lazy qualified as BSL
+import Data.Char (isDigit, ord)
 import Data.Function (on, (&))
 import Data.IORef
 import Data.List.NonEmpty (NonEmpty((:|)), groupBy)
@@ -18,6 +19,7 @@ import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Text.Encoding qualified as TE
 import Data.Text.IO qualified as T
+import Data.Time (Day, fromGregorianValid)
 import Network.Wai
 import Network.HTTP.Types
 import Network.Wai.Handler.Warp (runSettings, defaultSettings, setFork, setPort)
@@ -30,8 +32,9 @@ import Text.Mustache qualified as M
 import Text.Mustache.Types (Value(..))
 import Text.Read (readMaybe)
 
-import Debug.Trace
+-- import Debug.Trace
 
+import Calendar
 import Config
 import Index
 import Util
@@ -69,7 +72,7 @@ pageIndex conf pages =
 pageLog :: Config -> Pages -> Index -> Request -> Text -> IO Response
 pageLog conf pages index req alias =
   case econfAlias2Chan conf Map.!? alias of
-    Nothing -> page404 "Channel"
+    Nothing -> page404 "Channel not found"
     Just chan -> do
       let npages = (indexNumEvents index chan + numPerPage - 1) `div` numPerPage
           curpage | Just (readMaybe . BS8.unpack -> Just pg) <- query "page" = min npages (max 1 pg)
@@ -82,7 +85,7 @@ pageLog conf pages index req alias =
         ["network" ~> chanNetwork chan
         ,"channel" ~> chanChannel chan
         ,"alias" ~> alias
-        ,"totalevents" ~> indexNumEvents index chan
+        ,"totalevents" ~> renderLargeNumber (indexNumEvents index chan)
         ,"picker" ~> M.object
           ["prevpage" ~> if curpage > 1 then Just (curpage - 1) else Nothing
           ,"nextpage" ~> if curpage < npages then Just (curpage + 1) else Nothing
@@ -114,26 +117,105 @@ pageLog conf pages index req alias =
                   Just Nothing -> Nothing  -- given but empty; treat as not given
                   Just (Just value) -> Just value
 
-    renderEvent :: Event -> (Maybe Text, (Maybe Text, Text, Maybe Text), Text)
-    renderEvent = \case
-      Join n addr      -> (j "ev-join",   (no, "", j "→"),   n <> " joins (" <> addr <> ")")
-      Part n addr reas -> (j "ev-leave",  (no, "", j "←"),   n <> " parts (" <> addr <> ") (" <> reas <> ")")
-      Quit n addr reas -> (j "ev-leave",  (no, "", j "×"),   n <> " quits (" <> addr <> ") (" <> reas <> ")")
-      ReNick n n'      -> (j "ev-meta",   (no, n, no),       "is now known as " <> n')
-      Talk n m         -> (no,            (j "<", n, j ">"), m)
-      Notice n m       -> (j "ev-notice", (j "-", n, j "-"), m)
-      Act n m          -> (j "ev-act",    (no, n, no),       m)
-      Kick n by reas   -> (j "ev-meta",   (no, n, no),       "is kicked by " <> by <> " (" <> reas <> ")")
-      Mode n m         -> (j "ev-meta",   (no, n, no),       "sets mode " <> m)
-      Topic n m        -> (j "ev-meta",   (no, n, no),       "sets topic to \"" <> m <> "\"")
-      ParseError       -> (j "ev-parseerror", (no, "", no),  "<parse error>")
-      where no = Nothing; j = Just
+    renderLargeNumber :: Int -> Text
+    renderLargeNumber n
+      | n < 0 = "-" <> renderLargeNumber n
+      | n < 1000 = T.show n
+      | otherwise = renderLargeNumber (n `div` 1000) <> "," <> T.pack (pad '0' 3 (n `mod` 1000))
 
-page404 :: String -> IO Response
-page404 thing = return $ responseLBS
+pageCalendarDay :: Config -> Pages -> Index -> Text -> Text -> IO Response
+pageCalendarDay conf pages index alias datestr =
+  case (econfAlias2Chan conf Map.!? alias, parseDatestr datestr) of
+    (Nothing, _) -> page404 "Channel not found"
+    (_, Nothing) -> page404 "Invalid date"
+    (Just chan, Just day) -> do
+      events <- indexGetEventsDay index chan day
+      return $ sendPage200 pages "calendar-day" $ M.object
+        ["network" ~> chanNetwork chan
+        ,"channel" ~> chanChannel chan
+        ,"alias" ~> alias
+        ,"date" ~> ymdToString (dayToYMD day)
+        ,"events" ~> [M.object
+                       ["classlist" ~> classlist
+                       ,"time" ~> let HMS h mi s = time
+                                  in pad '0' 2 h ++ ':' : pad '0' 2 mi ++ ':' : pad '0' 2 s
+                       ,"nickwrap1" ~> nickw1
+                       ,"nick" ~> nick
+                       ,"nickwrap2" ~> nickw2
+                       ,"message" ~> msg]
+                     | (time, ev) <- events
+                     , let (classlist, (nickw1, nick, nickw2), msg) = renderEvent ev]]
+  where
+    parseDatestr :: Text -> Maybe Day
+    parseDatestr t = do  -- YYYY-mm-dd
+      guard (T.length t == 4 + 1 + 2 + 1 + 2)
+      y <- parseInt (T.take 4 t)
+      guard (T.index t 4 == '-')
+      m <- parseInt (T.take 2 (T.drop 5 t))
+      guard (T.index t 7 == '-')
+      d <- parseInt (T.take 2 (T.drop 8 t))
+      fromGregorianValid (fromIntegral y) m d
+
+    parseInt :: Text -> Maybe Int
+    parseInt t | T.all isDigit t = Just (T.foldl' (\n c -> 10 * n + (ord c - ord '0')) 0 t)
+               | otherwise = Nothing
+
+-- Returns: (classlist, (nickwrap1, nick, nickwrap2), message)
+renderEvent :: Event -> (Maybe Text, (Maybe Text, Text, Maybe Text), Text)
+renderEvent = \case
+  Join n addr      -> (j "ev-join",   (no, "", j "→"),   n <> " joins (" <> addr <> ")")
+  Part n addr reas -> (j "ev-leave",  (no, "", j "←"),   n <> " parts (" <> addr <> ") (" <> reas <> ")")
+  Quit n addr reas -> (j "ev-leave",  (no, "", j "×"),   n <> " quits (" <> addr <> ") (" <> reas <> ")")
+  ReNick n n'      -> (j "ev-meta",   (no, n, no),       "is now known as " <> n')
+  Talk n m         -> (no,            (j "<", n, j ">"), m)
+  Notice n m       -> (j "ev-notice", (j "-", n, j "-"), m)
+  Act n m          -> (j "ev-act",    (no, n, no),       m)
+  Kick n by reas   -> (j "ev-meta",   (no, n, no),       "is kicked by " <> by <> " (" <> reas <> ")")
+  Mode n m         -> (j "ev-meta",   (no, n, no),       "sets mode " <> m)
+  Topic n m        -> (j "ev-meta",   (no, n, no),       "sets topic to \"" <> m <> "\"")
+  ParseError       -> (j "ev-parseerror", (no, "", no),  "<parse error>")
+  where no = Nothing; j = Just
+
+pageCalendar :: Config -> Pages -> Index -> Text -> IO Response
+pageCalendar conf pages index alias =
+  case econfAlias2Chan conf Map.!? alias of
+    Nothing -> page404 "Channel not found"
+    Just chan -> do
+      let ((startDay, endDay), counts) = indexCalendar index chan
+      return $ sendPage200 pages "calendar" $ M.object
+        ["network" ~> chanNetwork chan
+        ,"channel" ~> chanChannel chan
+        ,"alias" ~> alias
+        ,"years" ~> flip map (reverse (calendarLayout startDay endDay counts)) (\(year, monrows) ->
+          M.object
+            ["year" ~> year
+            ,"monrows" ~> flip map monrows (\monrow ->
+              M.object
+                ["months" ~> flip map monrow (\mmonth ->
+                  case mmonth of
+                    Nothing -> M.object ["monthname" ~> Null]
+                    Just (month, weeks) ->
+                      M.object
+                        ["month" ~> month
+                        ,"month00" ~> pad '0' 2 month
+                        ,"monthname" ~> monthNames !! (month - 1)
+                        ,"weeks" ~> flip map weeks (\week ->
+                          M.object
+                            ["days" ~> flip map week (\mday ->
+                              fmap (\(d, _count) -> M.object ["date" ~> d, "date00" ~> pad '0' 2 d])
+                                   mday)])
+                        ,"phantomweek" ~> (length weeks <= 3)])])])]
+  where
+    monthNames :: [Text]
+    monthNames = ["January", "February", "March", "April"
+                 ,"May", "June", "July", "August"
+                 ,"September", "October", "November", "December"]
+
+page404 :: BSL.ByteString -> IO Response
+page404 message = return $ responseLBS
   status404
   [("Content-Type", "text/plain")]
-  (BSL8.pack thing <> " not found")
+  message
 
 getUlimitFiles :: IO Int
 getUlimitFiles = do
@@ -149,22 +231,23 @@ mainServe confpath = do
 
   index <- initIndex (confLogsDir config) (econfChannels config)
 
-  pages <- Pages . Map.fromList <$> sequence
-    [do src <- T.readFile ("pages/" ++ name ++ ".mustache")
-        case compileTemplate name src of
-          Right tpl -> return (name, tpl)
-          Left err -> die (show err)
-    | name <- ["index", "log"]]
+  let templateFiles = ["index", "log", "calendar", "calendar-day"]
+      staticFiles = ["style.css"]
 
-  let staticFiles = ["style.css"]
+  pages <- fmap (Pages . Map.fromList) . forM templateFiles $ \name -> do
+             src <- T.readFile ("pages/" ++ name ++ ".mustache")
+             case compileTemplate name src of
+               Right tpl -> return (name, tpl)
+               Left err -> die (show err)
 
+  -- TODO: handle this more properly with making clients wait (or dropping them
+  -- in the kernel already) instead of dropping connections here
   ulimitFiles <- getUlimitFiles
   counter <- newIORef 0
   let connectionLimit = max 2 (ulimitFiles - 100)
       checkedFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO ()
       checkedFork k = mask_ $ do
         count <- atomicModifyIORef' counter (\i -> (i + 1, i + 1))
-        print (connectionLimit, count)
         when (count <= connectionLimit) $
           settingsFork defaultSettings k
         atomicModifyIORef' counter (\i -> (i - 1, ()))
@@ -177,10 +260,14 @@ mainServe confpath = do
       respond =<< pageIndex config pages
     ["log", alias] ->
       respond =<< pageLog config pages index req alias
+    ["cal", alias] ->
+      respond =<< pageCalendar config pages index alias
+    ["cal", alias, date] ->
+      respond =<< pageCalendarDay config pages index alias date
     [fname] | fname `elem` staticFiles ->
       respond $ responseFile status200 [] ("pages/" ++ T.unpack fname) Nothing
     _ ->
-      respond =<< page404 "URL"
+      respond =<< page404 "URL not found"
 
 testParseLog :: FilePath -> IO ()
 testParseLog fname = print =<< parseLog <$> BS.readFile fname
diff --git a/src/Util.hs b/src/Util.hs
index 1e10eec..95cc4ce 100644
--- a/src/Util.hs
+++ b/src/Util.hs
@@ -2,6 +2,8 @@
 module Util (module Util, toList) where
 
 import Data.Foldable (toList)
+import Data.Maybe (fromMaybe)
+import Data.Time (Day, toGregorian)
 import Data.Word (Word8)
 
 
@@ -32,3 +34,21 @@ pad c w val =
 
 uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
 uncurry3 f (x, y, z) = f x y z
+
+dropWhileEnd :: (a -> Bool) -> [a] -> [a]
+dropWhileEnd p = fromMaybe [] . go
+  where
+    go [] = Nothing
+    go (x:xs) =
+      case go xs of
+        Nothing | p x -> Nothing
+                | otherwise -> Just [x]
+        Just xs' -> Just (x : xs')
+
+ymdToString :: YMD -> String
+ymdToString (YMD y m d) = pad '0' 4 y ++ '-' : pad '0' 2 m ++ '-' : pad '0' 2 d
+
+dayToYMD :: Day -> YMD
+dayToYMD day =
+  let (y, m, d) = toGregorian day
+  in YMD (fromIntegral y) (fromIntegral m) (fromIntegral d)
author	Tom Smeding <tom@tomsmeding.com>	2026-04-03 22:10:56 +0200
committer	Tom Smeding <tom@tomsmeding.com>	2026-04-03 22:10:56 +0200
commit	acd9c66c663ea6b0b2fb9dd0a563897c2fae45eb (patch)
tree	03e24cb4475367e55cc613f6b0080de7cf618063
parent	40d29ea3eef3f7fa15ab629b5f6694dab66d9b68 (diff)