Initial

author: Tom Smeding <tom@tomsmeding.com> 2026-03-29 23:25:10 +0200
committer: Tom Smeding <tom@tomsmeding.com> 2026-03-29 23:25:10 +0200
commit: f21dcde54b09913550036e6501cca935278597d9 (patch)
tree: 505f373b1bce690f0bafc2038636721126d9bcad
15 files changed, 1030 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..c33954f
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1 @@
+dist-newstyle/
diff --git a/aratamete-ircbrowse.cabal b/aratamete-ircbrowse.cabal
new file mode 100644
index 0000000..2cef3f6
--- /dev/null
+++ b/aratamete-ircbrowse.cabal
@@ -0,0 +1,43 @@
+cabal-version:   3.0
+name:            aratamete-ircbrowse
+version:         0.1.0.0
+author:          Tom Smeding
+maintainer:      Tom Smeding
+license:         BSD-3-Clause
+build-type:      Simple
+
+executable aratamete-ircbrowse
+  main-is: Main.hs
+  other-modules:
+    -- Cache
+    Config
+    Index
+    Mmap
+    Util
+    ZNC
+  build-depends:
+    base >= 4.21,
+    attoparsec,
+    bytestring,
+    chronos,
+    containers,
+    directory,
+    filepath,
+    http-types,
+    mustache,
+    stm,
+    text >= 2.1.2,
+    torsor,
+    unix,
+    vector,
+    wai,
+    warp >= 3.4.12
+  hs-source-dirs: src
+  c-sources: cbits/mmap.c
+  default-language: Haskell2010
+  default-extensions:
+    ImportQualifiedPost
+    LambdaCase
+    TypeApplications
+    TupleSections
+  ghc-options: -Wall -threaded
diff --git a/cabal.project b/cabal.project
new file mode 100644
index 0000000..e16ebb1
--- /dev/null
+++ b/cabal.project
@@ -0,0 +1,2 @@
+packages: .
+with-compiler: ghc-9.12
diff --git a/cbits/mmap.c b/cbits/mmap.c
new file mode 100644
index 0000000..079959f
--- /dev/null
+++ b/cbits/mmap.c
@@ -0,0 +1,26 @@
+#include <stdio.h>
+#include <sys/mman.h>
+#include <sys/stat.h>
+
+
+void* ircbrowse_mmap(int fd, size_t *lengthp) {
+  struct stat statbuf;
+  int ret = fstat(fd, &statbuf);
+  if (ret < 0) {
+    perror("stat");
+    return NULL;
+  }
+  void *addr = mmap(NULL, statbuf.st_size, PROT_READ, MAP_SHARED, fd, 0);
+  if (addr == NULL) {
+    perror("mmap");
+  }
+  if (lengthp != NULL) *lengthp = statbuf.st_size;
+  return addr;
+}
+
+void ircbrowse_munmap(void *addr, size_t length) {
+  int ret = munmap(addr, length);
+  if (ret < 0) {
+    perror("munmap");
+  }
+}
diff --git a/config.txt b/config.txt
new file mode 100644
index 0000000..2745cd3
--- /dev/null
+++ b/config.txt
@@ -0,0 +1,7 @@
+port 8000
+logs /home/tom/git/ircbrowse/logs-snapshot
+channel liberachat #haskell haskell
+channel liberachat #kmonad kmonad
+channel liberachat #xmonad xmonad
+channel freenode #haskell fn-haskell
+channel freenode #xmonad fn-xmonad
diff --git a/pages/index.mustache b/pages/index.mustache
new file mode 100644
index 0000000..cc0a8f4
--- /dev/null
+++ b/pages/index.mustache
@@ -0,0 +1,25 @@
+<!doctype html>
+<html lang="en">
+<head>
+  <meta charset="utf-8">
+  <title>Ircbrowse2</title>
+  <link rel="stylesheet" href="/style.css">
+</head>
+<body>
+  <div id="gridwrapper" data-page="index">
+    <main>
+      <h1>改めて ircbrowse</h1>
+      {{#networks}}
+        <h2>{{name}}</h2>
+        {{#channels}}
+          <a class="chanlink" href="/log/{{alias}}">{{name}}</a><br>
+        {{/channels}}
+      {{/networks}}
+    </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
new file mode 100644
index 0000000..24b7b78
--- /dev/null
+++ b/pages/log.mustache
@@ -0,0 +1,59 @@
+<!doctype html>
+<html lang="en">
+<head>
+  <meta charset="utf-8">
+  <title>Ircbrowse2: {{channel}} ({{network}})</title>
+  <link rel="stylesheet" href="/style.css">
+</head>
+<body>
+  <div id="gridwrapper" data-page="withheader">
+    <header>
+      <a href="/" class="hdritem">Home</a>
+      <span class="hdrspacer"></span>
+      <span class="hdrchannel">{{network}}/{{channel}}</span>
+      <span class="hdrspacer"></span>
+      <a href="/cal/{{alias}}" class="hdritem">Calendar</a>
+    </header>
+    <main>
+      <h1>Logs for {{channel}} on {{network}}</h1>
+      <div id="pagepicker">
+        {{#picker}}
+          Page
+          {{#prevpage}}
+            <a href="?page=1">1</a>
+            ..
+            <a href="?page={{prevpage}}">&lt;Prev</a>
+          {{/prevpage}}
+          {{#leftnums}}
+            <a href="?page={{.}}">{{.}}</a>
+          {{/leftnums}}
+          <b>{{curnum}}</b>
+          {{#rightnums}}
+            <a href="?page={{.}}">{{.}}</a>
+          {{/rightnums}}
+          {{#nextpage}}
+            <a href="?page={{nextpage}}">Next&gt;</a>
+            ..
+            <a href="?page={{npages}}">{{npages}}</a>
+          {{/nextpage}}
+        {{/picker}}
+        <span style="margin: 0 10px 0 11px">&mdash;</span>
+        {{totalevents}} events total.
+      </div>
+      <table id="events"><tbody>
+        {{#events}}
+          <tr{{#classlist}} class="{{.}}"{{/classlist}}>
+            <td>{{datetime}}</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>
+    </main>
+    <footer>
+      An IRC log viewer by
+      <a href="https://tomsmeding.com">Tom Smeding</a>.
+    </footer>
+  </div>
+</body>
+</html>
diff --git a/pages/style.css b/pages/style.css
new file mode 100644
index 0000000..e7c850a
--- /dev/null
+++ b/pages/style.css
@@ -0,0 +1,89 @@
+html, body {
+  margin: 0;
+}
+
+body {
+  font-family: sans-serif;
+}
+
+#gridwrapper {
+  min-height: 100vh;
+  display: grid;
+}
+
+#gridwrapper[data-page="index"] {
+  grid-template-rows: 1fr auto;
+}
+
+#gridwrapper[data-page="withheader"] {
+  grid-template-rows: auto 1fr auto;
+}
+
+header {
+  background-color: #ddd;
+  padding: 10px;
+  padding-left: 20px;
+}
+
+main {
+  margin: 0 20px 30px 20px;
+}
+
+footer {
+  background-color: #eee;
+  padding: 20px;
+  font-size: smaller;
+  color: #333;
+}
+
+.hdrspacer {
+  display: inline-block;
+  width: 15px;
+}
+
+.hdrchannel {
+  font-size: larger;
+  font-weight: bold;
+  vertical-align: middle;
+  margin-left: 15px;
+}
+
+.hdritem {
+  margin-top: auto;
+  margin-bottom: auto;
+}
+
+/* index page */
+.chanlink {
+  font-weight: bold;
+  font-size: large;
+}
+
+/* log page */
+#pagepicker {
+  display: inline-block;
+  background-color: #eee;
+  padding: 5px;
+  border-radius: 5px;
+  margin-bottom: 10px;
+}
+
+table#events td {
+  padding: 2px;
+  vertical-align: top;
+}
+
+table#events td:nth-child(2) {
+  text-align: right;
+}
+
+table#events td:nth-child(-n + 2) {
+  white-space: nowrap;
+  padding-right: 10px;
+}
+
+span.nickwrap { color: #888; }
+table#events tr.ev-meta > td:nth-child(n + 2) { color: #666; }
+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; }
diff --git a/src/Cache.hs b/src/Cache.hs
new file mode 100644
index 0000000..53d2185
--- /dev/null
+++ b/src/Cache.hs
@@ -0,0 +1,87 @@
+module Cache where
+
+import Control.Concurrent.STM
+import Control.Monad (forM_)
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as BS
+import Data.Map.Strict (Map)
+import Data.Map.Strict qualified as Map
+
+import ZNC
+
+
+-- value, previous (more recently accessed), next (less recently accessed)
+data LRUNode a = LRUNode a (TVar (Maybe (LRUNode a))) (TVar (Maybe (LRUNode a)))
+
+-- head (most recent), last (least recent)
+data LRUChain a = LRUChain (TVar (Maybe (LRUNode a))) (TVar (Maybe (LRUNode a)))
+
+lruchainNew :: IO (LRUChain a)
+lruchainNew = LRUChain <$> newTVarIO Nothing <*> newTVarIO Nothing
+
+lruchainAdd :: LRUChain a -> a -> STM (LRUNode a)
+lruchainAdd (LRUChain hd tl) x = do
+  mhdnode <- readTVar hd
+  case mhdnode of
+    Nothing -> do  -- chain empty
+      node <- LRUNode x <$> newTVar Nothing <*> newTVar Nothing
+      writeTVar hd (Just node)
+      writeTVar tl (Just node)
+      return node
+    Just hdnode -> do
+      node <- LRUNode x <$> newTVar Nothing <*> newTVar (Just hdnode)
+      writeTVar hd (Just node)
+      return node
+
+lruchainBump :: LRUChain a -> LRUNode a -> STM ()
+lruchainBump (LRUChain hd _) node@(LRUNode _ prevvar nextvar) = do
+  mprev <- readTVar prevvar
+  case mprev of
+    Nothing -> return ()  -- already most recent
+    Just (LRUNode _ _ prevnextvar) -> do
+      -- remove node from chain where it is now
+      mnext <- readTVar nextvar
+      writeTVar prevnextvar mnext
+      case mnext of
+        Nothing -> return ()
+        Just (LRUNode _ nextprevvar _) -> writeTVar nextprevvar mprev
+      -- add node to chain at head
+      writeTVar nextvar =<< readTVar hd
+      writeTVar hd (Just node)
+
+lruchainEvict :: LRUChain a -> STM (Maybe a)
+lruchainEvict (LRUChain _ tl) = do
+  mtlnode <- readTVar tl
+  case mtlnode of
+    Nothing -> return Nothing
+    Just (LRUNode x prevvar _) -> do
+      mprev <- readTVar prevvar
+      writeTVar tl mprev
+      case mprev of
+        Nothing -> return ()
+        Just (LRUNode _ _ prevnextvar) -> writeTVar prevnextvar Nothing
+      return (Just x)
+
+-- maxsize, elements in cache, linked list
+data LRU a = LRU Int (TVar (Map a (LRUNode a))) (LRUChain a)
+
+lruNew :: Ord a => Int -> IO (LRU a)
+lruNew maxsize = LRU maxsize <$> newTVarIO mempty <*> lruchainNew
+
+-- | If a value got evicted, it is returned
+lruBump :: Ord a => LRU a -> a -> IO (Maybe a)
+lruBump (LRU maxsize mapvar chain) value = atomically $ do
+  mp <- readTVar mapvar
+  case Map.lookup value mp of
+    Nothing -> do
+      node <- lruchainAdd chain value
+      writeTVar mapvar $! Map.insert value node mp
+      if Map.size mp >= maxsize
+        then do
+          mret <- lruchainEvict chain
+          forM_ mret $ \ret -> writeTVar mapvar $! Map.delete ret mp
+          return mret
+        else return Nothing
+    Just node -> do
+      lruchainBump chain node
+      return Nothing
diff --git a/src/Config.hs b/src/Config.hs
new file mode 100644
index 0000000..7fe9e6a
--- /dev/null
+++ b/src/Config.hs
@@ -0,0 +1,125 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeData #-}
+{-# LANGUAGE TypeFamilies #-}
+module Config (
+  Config, Config'(..), ConfigStage(..), IfFull,
+  Channel(..),
+  readConfig, enrichConfig,
+) 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)
+import Data.Text qualified as T
+import Text.Read (readMaybe)
+
+import Util
+
+
+-- Example config file:
+--
+-- ```
+-- port 8080
+-- logs /var/lib/znc/users/ircbrowse/moddata/log
+-- channel freenode #haskell fn-haskell
+-- channel liberachat #haskell haskell
+-- channel liberachat #xmonad xmonad
+-- ```
+--
+-- Lines starting with '#' are ignored.
+
+
+type Config = Config' Full
+
+-- | Whether a 'Config' is straight from the 'User', or enriched with more
+-- information ('Full').
+type data ConfigStage = User | Full
+
+data Config' (stage :: ConfigStage) = Config
+  { uconfChannels :: IfUser stage (Snoc (Text, Text, Text))
+      -- ^ (network, channel, alias); channel includes '#'. Alias is used for
+      -- URLs and must be globally unique.
+
+  , confLogsDir :: FilePath
+  , confPort :: Int
+      -- ^ Port at which to host the HTTP server
+
+  , econfChannels :: IfFull stage [Channel]
+      -- ^ Network-channel pairs, in user-specified order
+  , econfChan2Alias :: IfFull stage (Map Channel Text)
+      -- ^ The URL alias of a network-channel pair
+  , econfAlias2Chan :: IfFull stage (Map Text Channel)
+      -- ^ The network-channel pair corresponding to each alias
+  }
+
+deriving instance Show (Config' User)
+deriving instance Show (Config' Full)
+
+type family IfUser stage a where
+  IfUser User a = a
+  IfUser Full a = ()
+
+type family IfFull stage a where
+  IfFull User a = ()
+  IfFull Full a = a
+
+-- | network, channelname
+data Channel = Channel { chanNetwork :: Text, chanChannel :: Text }
+  deriving (Show, Eq, Ord)
+
+readConfig :: FilePath -> IO (Config' User)
+readConfig path = foldl' parseLine initConfig . lines <$> readFile path
+
+enrichConfig :: Config' User -> Config
+enrichConfig conf = conf
+  { uconfChannels = ()
+  , econfChannels = [Channel nw ch | (nw, ch, _) <- uchannels]
+  , econfChan2Alias = Map.fromList [(Channel nw ch, alias) | (nw, ch, alias) <- uchannels]
+  , econfAlias2Chan = Map.fromList [(alias, Channel nw ch) | (nw, ch, alias) <- uchannels]
+  }
+  where
+    uchannels = toList (uconfChannels conf)
+
+initConfig :: Config' User
+initConfig = Config
+  { uconfChannels = SnocNil
+  , confLogsDir = error "config: Log directory not set with 'logs'"
+  , confPort = 8000
+  , econfChannels = ()
+  , econfChan2Alias = ()
+  , econfAlias2Chan = ()
+  }
+
+parseLine :: Config' User -> String -> Config' User
+parseLine conf line  -- skip empty lines and comments
+  | case dropWhile isSpace line of
+      [] -> True
+      '#':_ -> True
+      _ -> False
+  = conf
+parseLine conf line =
+  let (cmd, rest) = break (== ' ') line
+  in case cmd of
+       "port" ->
+         case readMaybe (trim rest) of
+           Just port | 0 <= port, port < 65536 -> conf { confPort = port }
+           _ -> error "config: Invalid port number"
+       "logs" ->
+         let dir = dropWhile isSpace rest
+         in if null dir
+              then error "config: Empty 'logs' directory"
+              else conf { confLogsDir = dropWhile isSpace rest }
+       "channel" ->
+         case words (trim rest) of
+           [network, chan, alias]
+             | all (not . null) [network, chan, alias]
+             -> conf { uconfChannels = uconfChannels conf `Snoc` (T.pack network, T.pack chan, T.pack alias) }
+           _ -> error $ "config: Invalid channel spec: " ++ trim rest
+       _ -> error $ "config: Invalid line with command '" ++ cmd ++ "'"
+  where
+    trim :: String -> String
+    trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse
diff --git a/src/Index.hs b/src/Index.hs
new file mode 100644
index 0000000..4de4c6c
--- /dev/null
+++ b/src/Index.hs
@@ -0,0 +1,193 @@
+module Index (
+  Index,
+  initIndex,
+  indexGetEventsLinear,
+  indexNumEvents,
+) where
+
+import Chronos hiding (day)
+import Control.Monad (forM)
+import Data.ByteString qualified as BS
+import Data.Char (isDigit)
+import Data.List (sort, scanl')
+import Data.Map.Strict (Map)
+import Data.Map.Strict qualified as Map
+import Data.Text qualified as T
+import Data.Vector.Storable qualified as VS
+import System.Directory
+import System.FilePath
+import Text.Read (readMaybe)
+import Torsor (add, difference)
+
+import Debug.Trace
+
+import Config (Channel(..))
+import Mmap
+import Util
+import ZNC
+
+
+data ChanIndex = ChanIndex
+  { ciStartDay :: Day
+  , ciEndDay :: Day
+  , ciCountUntil :: VS.Vector Int  -- ^ number of events up to and /including/ this day
+  , ciTotal :: Int }
+  deriving (Show)
+
+data Index = Index FilePath (Map Channel ChanIndex)
+  deriving (Show)
+
+-- init
+
+initIndex :: FilePath -> [Channel] -> IO Index
+initIndex basedir toimport = do
+  items <-
+    fmap concat . forM (map chanNetwork toimport) $ \nwT -> do
+      let nw = T.unpack nwT
+      forM [ch | Channel nwT' ch <- toimport, nwT' == nwT] $ \chT -> do
+        let ch = T.unpack chT
+        files <- listDirectory (basedir </> nw </> ch)
+        days <- fmap sort . forM files $ \fn -> do
+          let path = basedir </> nw </> ch </> fn
+          -- putStrLn $ "Parsing " ++ path ++ " (" ++ show (parseFileName fn) ++ " -> " ++ show (dateToDay (parseFileName fn)) ++ ")"
+          events <- parseLog <$> BS.readFile path
+          return (dateToDay (parseFileName fn), length events)
+        let minday = minimum (map fst days)
+            maxday = maximum (map fst days)
+            ndays = difference maxday minday + 1
+        -- traceM $ nw ++ "/" ++ ch ++ ": days = " ++ show [(toFileName (dayToDate 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
+               ,ChanIndex
+                  { ciStartDay = minday
+                  , ciEndDay = maxday
+                  , ciCountUntil = countScan
+                  , ciTotal = ntotal})
+  return (Index basedir (Map.fromList items))
+
+makeCounts :: [Day] -> [(Day, Int)] -> [Int]
+makeCounts [] [] = []
+makeCounts [] _ = error "makeCounts: more entries than days in range"
+makeCounts (d:ds) ents@((d',n):ents')
+  | d == d' = n : makeCounts ds ents'
+  | d < d'  = 0 : makeCounts ds ents
+  | otherwise = error $ "makeCounts: duplicate entry? " ++ show (d, dayToDate d, d', dayToDate d')
+makeCounts (_:ds) [] = 0 : makeCounts ds []
+
+-- search
+
+-- | 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) chan@(Channel network channel) from count
+  | from + count < 0 = return []
+  | from >= ciTotal ci = return []
+  | otherwise = do
+      let scan = ciCountUntil ci
+          day1idx = binSearch scan from
+          day1 = day1idx `add` ciStartDay ci
+          neventBeforeDay1 | day1idx == 0 = 0
+                           | otherwise = scan VS.! (day1idx - 1)
+          neventInclDay1 = scan VS.! day1idx
+          neventOnDay1 = neventInclDay1 - neventBeforeDay1
+          off1 = from - neventBeforeDay1
+          -- day2 is inclusive, off2 is exclusive
+          (day2, off2)
+            | from + count <= neventInclDay1 = (day1, off1 + count)
+            | day1idx == VS.length scan - 1 = (day1, neventOnDay1)
+            | otherwise =
+                let loop day2idx nbefore nseen 
+                      | nseen + nOnDay2 >= count =
+                          (day2idx `add` ciStartDay ci, count - nseen)
+                      | day2idx == VS.length scan - 1 =
+                          (day2idx `add` ciStartDay ci, nOnDay2)
+                      | otherwise =
+                          loop (day2idx + 1) (scan VS.! day2idx) (nseen + nOnDay2)
+                      where
+                        nOnDay2 = scan VS.! day2idx - nbefore
+                in loop (day1idx + 1) (neventBeforeDay1 + neventOnDay1) (neventOnDay1 - off1)
+
+      -- traceM ("ci = " ++ show ci)
+      -- traceM ("binSearch " ++ show from ++ " =")
+      -- traceM ("  " ++ show day1idx)
+      -- traceM ("day1 = " ++ show day1)
+      -- traceM ("off1 = " ++ show off1)
+      -- traceM ("neventOnDay1 = " ++ show neventOnDay1)
+      -- traceM ("count = " ++ show count)
+      -- traceM ("day2 = " ++ show day2)
+      -- traceM ("off2 = " ++ show off2)
+      evs <- forM (zip [day1 .. day2] [day1idx..]) $ \(day, dayidx) ->
+               let neventsOnDay | dayidx == 0 = scan VS.! 0
+                                | otherwise = scan VS.! dayidx - scan VS.! (dayidx - 1)
+                   parse
+                     | day == day1 =
+                         if day1 == day2
+                           then parseLogRange (off1, Just (off2 - off1))
+                           else parseLogRange (off1, Nothing)
+                     | day == day2 = parseLogRange (0, Just off2)
+                     | otherwise = parseLog
+                   Date (Year y) (Month monthm1) (DayOfMonth d) = dayToDate day
+                   fixDate = map $ \(tod, ev) ->
+                               (YMDHMS (YMD y (fromIntegral monthm1 + 1) (fromIntegral d)) tod
+                               ,ev)
+               in if neventsOnDay > 0
+                    then fixDate . parse <$>
+                           mapFile (basedir </> T.unpack network </> T.unpack channel </> toFileName (dayToDate day))
+                    else return []
+
+      return (concat evs)
+  where
+    ci = mp Map.! chan
+
+-- | The vector must be sorted.
+-- Returns index of the first element x such that needle < x. If there is no
+-- such element (i.e. needle is greater-equal the last element of vec), returns
+-- the length of vec.
+--
+-- TODO: proportional binary search
+binSearch :: VS.Vector Int -> Int -> Int
+binSearch vec needle
+  | veclen == 0 || vec VS.! (veclen - 1) < needle = veclen
+  | needle < vec VS.! 0 = 0
+  | otherwise = go 0 (veclen - 1)
+  where
+    veclen = VS.length vec
+
+    -- Invariant: vec[lo] <= needle < vec[hi]
+    go :: Int -> Int -> Int
+    go lo hi
+      | lo + 1 == hi = hi
+      | otherwise =
+          let mid = lo + (hi - lo) `div` 2
+          in if vec VS.! mid <= needle
+               then go mid hi else go lo mid
+
+-- other methods
+
+indexNumEvents :: Index -> Channel -> Int
+indexNumEvents (Index _ mp) chan = ciTotal (mp Map.! chan)
+
+-- utilities
+
+parseFileName :: String -> Date
+parseFileName name
+  | (y, '-' : s1) <- splitAt 4 name
+  , (m, '-' : s2) <- splitAt 2 s1
+  , (d, ".log") <- splitAt 2 s2
+  , all isDigit y, all isDigit m, all isDigit d
+  , let y' = read' y ; m' = read' m - 1 ; d' = read' d
+  , 0 <= m', m' < 12
+  , 1 <= d', d' <= daysInMonth (isLeapYear (Year y')) (Month m')
+  = Date (Year y') (Month m') (DayOfMonth d')
+  | otherwise
+  = error $ "Invalid ZNC log file name: " ++ name
+  where
+    read' :: Read a => String -> a
+    read' s = case readMaybe s of
+                Just r -> r
+                Nothing -> error $ "No read: " ++ show s
+
+toFileName :: Date -> String
+toFileName (Date (Year y) (Month m) (DayOfMonth d)) =
+  pad '0' 4 y ++ '-' : pad '0' 2 (m + 1) ++ '-' : pad '0' 2 d ++ ".log"
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
index 0000000..75b9a96
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,188 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+module Main (main) where
+
+import Control.Exception (mask_)
+import Control.Monad (when)
+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.Function (on, (&))
+import Data.IORef
+import Data.List.NonEmpty (NonEmpty((:|)), groupBy)
+import Data.Map.Strict (Map)
+import Data.Map.Strict qualified as Map
+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 Network.Wai
+import Network.HTTP.Types
+import Network.Wai.Handler.Warp (runSettings, defaultSettings, setFork, setPort)
+import Network.Wai.Handler.Warp.Internal (Settings(..))
+import System.Environment
+import System.Exit (die)
+import System.Posix.Resource
+import Text.Mustache (Template, compileTemplate, substituteValue, (~>))
+import Text.Mustache qualified as M
+import Text.Mustache.Types (Value(..))
+import Text.Read (readMaybe)
+
+import Debug.Trace
+
+import Config
+import Index
+import Util
+import ZNC
+
+
+newtype Pages = Pages (Map String Template)
+
+getPage :: Pages -> String -> Template
+getPage (Pages mp) name =
+  case Map.lookup name mp of
+    Just tpl -> tpl
+    Nothing -> error $ "Not a page: " ++ name
+
+sendPage200 :: Pages -> String -> Value -> Response
+sendPage200 pages name sub =
+  responseBuilder
+    status200
+    [("Content-Type", "text/html")]
+    (TE.encodeUtf8Builder (substituteValue (getPage pages name) sub))
+
+pageIndex :: Config -> Pages -> IO Response
+pageIndex conf pages =
+  return $ sendPage200 pages "index" $ M.object
+    ["networks" ~>
+      [M.object
+        ["name" ~> nw
+        ,"channels" ~>
+          [M.object ["name" ~> ch, "alias" ~> econfChan2Alias conf Map.! Channel nw ch]
+          | ch <- chs]]
+      | (nw, chs) <-
+          [(nw, ch : map chanChannel chs)
+          | Channel nw ch :| chs <- groupBy ((==) `on` chanNetwork) (econfChannels conf)]]]
+
+pageLog :: Config -> Pages -> Index -> Request -> Text -> IO Response
+pageLog conf pages index req alias =
+  case econfAlias2Chan conf Map.!? alias of
+    Nothing -> page404 "Channel"
+    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)
+                  | otherwise = npages
+          ntoleft = min 5 (curpage - 1)
+          ntoright = min 5 (npages - curpage)
+      -- traceShowM (indexNumEvents index chan, npages, curpage, ntoleft, ntoright)
+      events <- indexGetEventsLinear index chan ((curpage - 1) * numPerPage) numPerPage
+      return $ sendPage200 pages "log" $ M.object
+        ["network" ~> chanNetwork chan
+        ,"channel" ~> chanChannel chan
+        ,"alias" ~> alias
+        ,"totalevents" ~> indexNumEvents index chan
+        ,"picker" ~> M.object
+          ["prevpage" ~> if curpage > 1 then Just (curpage - 1) else Nothing
+          ,"leftnums" ~> [curpage - ntoleft .. curpage - 1]
+          ,"curnum" ~> curpage
+          ,"rightnums" ~> [curpage + 1 .. curpage + ntoright]
+          ,"nextpage" ~> if curpage < npages then Just (curpage + 1) else Nothing
+          ,"npages" ~> npages]
+        ,"events" ~> [M.object
+                       ["classlist" ~> classlist
+                       ,"datetime" ~> let YMDHMS (YMD y mo d) (HMS h mi s) = time
+                                      in pad '0' 4 y ++ '-' : pad '0' 2 mo ++ '-' : pad '0' 2 d ++ ' ' :
+                                         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
+    numPerPage = 100
+
+    query :: ByteString -> Maybe ByteString
+    query key = case lookup key (queryString req) of
+                  Nothing -> Nothing
+                  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-meta",   (no, n, j " →"),   "Joins (" <> addr <> ")")
+      Part n addr reas -> (j "ev-meta",   (no, n, j " ←"),   "Parts (" <> addr <> ") (" <> reas <> ")")
+      Quit n addr reas -> (j "ev-meta",   (no, n, j " ×"),   "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
+
+page404 :: String -> IO Response
+page404 thing = return $ responseLBS
+  status404
+  [("Content-Type", "text/plain")]
+  (BSL8.pack thing <> " not found")
+
+getUlimitFiles :: IO Int
+getUlimitFiles = do
+  limits <- getResourceLimit ResourceOpenFiles
+  let infer ResourceLimitInfinity = maxBound
+      infer ResourceLimitUnknown = maxBound
+      infer (ResourceLimit n) = fromIntegral n
+  return (infer (softLimit limits) `min` infer (hardLimit limits))
+
+mainServe :: FilePath -> IO ()
+mainServe confpath = do
+  config <- enrichConfig <$> readConfig confpath
+
+  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 staticFiles = ["style.css"]
+
+  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, ()))
+      settings = defaultSettings & setFork checkedFork
+                                 & setPort (confPort config)
+
+  putStrLn $ "Listening on port " ++ show (confPort config)
+  runSettings settings $ \req respond -> case pathInfo req of
+    [] ->
+      respond =<< pageIndex config pages
+    ["log", alias] ->
+      respond =<< pageLog config pages index req alias
+    [fname] | fname `elem` staticFiles ->
+      respond $ responseFile status200 [] ("pages/" ++ T.unpack fname) Nothing
+    _ ->
+      respond =<< page404 "URL"
+
+testParseLog :: FilePath -> IO ()
+testParseLog fname = print =<< parseLog <$> BS.readFile fname
+
+main :: IO ()
+main = getArgs >>= \case
+  ["test", "parselog", fname] -> testParseLog fname
+  ["serve", fname] -> mainServe fname
+  _ -> die "Expected command-line argument (see Main.hs)"
diff --git a/src/Mmap.hs b/src/Mmap.hs
new file mode 100644
index 0000000..bfe6042
--- /dev/null
+++ b/src/Mmap.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+module Mmap where
+
+import Control.Exception
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Unsafe as BS
+import Foreign
+import Foreign.C.Types
+import System.Posix.IO
+import System.Posix.Types
+
+foreign import ccall "ircbrowse_mmap"
+  c_mmap :: CInt -> Ptr CSize -> IO (Ptr Word8)
+  --        fd      out length
+
+foreign import ccall "ircbrowse_munmap"
+  c_munmap :: Ptr Word8 -> CSize -> IO ()
+  --          addr         length
+
+mapFile :: FilePath -> IO ByteString
+mapFile path = mask_ $ do
+  -- open can fail without repercussions
+  Fd fd <- openFd path ReadOnly defaultFileFlags
+
+  -- do the mmap; if it fails, close the file, ignoring exceptions there
+  (addr, filelen) <-
+    catchNoPropagate @SomeException
+      (alloca $ \lengthp -> do
+        addr <- c_mmap fd lengthp
+        lengthval <- peek lengthp
+        return (addr, lengthval))
+      (\e -> do
+          catch @SomeException (closeFd (Fd fd))
+            (\_ -> return ())
+          rethrowIO e)
+
+  -- mmap succeeded, close the file
+  catchNoPropagate @SomeException (closeFd (Fd fd))
+    (\e -> do
+      -- putStrLn ("[munmap " ++ show addr ++ " as close(2) handler]")
+      c_munmap addr filelen
+      rethrowIO e)
+
+  -- close succeeded, we're safe now since bytestring construction will not
+  -- fail (and no exceptions are coming from outside as we're masked)
+  if addr == nullPtr
+    then fail "mapFile: could not mmap"
+    else BS.unsafePackCStringFinalizer addr (fromIntegral @CSize @Int filelen)
+            (do -- putStrLn ("[munmap " ++ show addr ++ "]")
+                c_munmap addr filelen)
diff --git a/src/Util.hs b/src/Util.hs
new file mode 100644
index 0000000..ca31258
--- /dev/null
+++ b/src/Util.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE DeriveFoldable #-}
+module Util (module Util, toList) where
+
+import Data.Foldable (toList)
+import Data.Word (Word8)
+
+
+data Snoc a = SnocNil | Snoc (Snoc a) a
+  deriving (Show, Foldable)
+
+-- | Time-of-day, in unspecified time zone
+data YMDHMS = YMDHMS {-# UNPACK #-} !YMD
+                     {-# UNPACK #-} !HMS
+  deriving (Show)
+
+-- | Calendar day
+data YMD = YMD {-# UNPACK #-} !Int
+               {-# UNPACK #-} !Word8  -- ^ 1-based
+               {-# UNPACK #-} !Word8
+  deriving (Show)
+
+-- | Time-of-day in seconds, in unspecified time zone
+data HMS = HMS {-# UNPACK #-} !Word8
+               {-# UNPACK #-} !Word8
+               {-# UNPACK #-} !Word8
+  deriving (Show)
+
+pad :: Show a => Char -> Int -> a -> String
+pad c w val =
+  let s = show val
+  in replicate (w - length s) c ++ s
diff --git a/src/ZNC.hs b/src/ZNC.hs
new file mode 100644
index 0000000..35eafe0
--- /dev/null
+++ b/src/ZNC.hs
@@ -0,0 +1,104 @@
+{-# LANGUAGE OverloadedStrings #-}
+module ZNC (
+  -- Log(..),
+  Nick, Event(..),
+  parseLog, parseLogRange,
+) where
+
+import Control.Applicative
+import Data.Attoparsec.ByteString.Char8 qualified as P
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as BS
+import Data.ByteString.Char8 qualified as BS8
+import Data.Char (ord)
+import Data.Either (fromRight)
+import Data.Text (Text)
+import Data.Text.Encoding qualified as TE
+-- import Data.Vector qualified as V
+-- import Data.Vector (Vector)
+import Data.Word (Word8)
+
+import Util
+
+
+-- newtype Log = Log (Vector (TOD, Event))
+--   deriving (Show)
+
+type Nick = Text
+
+-- Adapted from clogparse by Keegan McAllister (BSD3) (https://hackage.haskell.org/package/clogparse).
+data Event
+  = Join   Nick      Text  -- ^ User joined.
+  | Part   Nick Text Text  -- ^ User left the channel. (address, reason)
+  | Quit   Nick Text Text  -- ^ User quit the server. (address, reason)
+  | ReNick Nick Nick       -- ^ User changed from one to another nick.
+  | Talk   Nick      Text  -- ^ User spoke (@PRIVMSG@).
+  | Notice Nick      Text  -- ^ User spoke (@NOTICE@).
+  | Act    Nick      Text  -- ^ User acted (@CTCP ACTION@).
+  | Kick   Nick Nick Text  -- ^ User was kicked by user. (kicked, kicker, reason)
+  | Mode   Nick      Text  -- ^ User set mode on the channel.
+  | Topic  Nick      Text  -- ^ Topic change.
+  | ParseError
+  deriving (Show)
+
+-- these INLINE/NOINLINE pragmas are optimisation without testing or profiling, have fun
+{-# INLINE parseLog #-}
+parseLog :: ByteString -> [(HMS, Event)]
+parseLog = parseLogRange (0, Nothing)
+
+-- (start line, number of lines (default to rest of file))
+{-# INLINE parseLogRange #-}
+parseLogRange :: (Int, Maybe Int) -> ByteString -> [(HMS, Event)]
+parseLogRange (startln, mnumln) =
+  -- Log . V.fromList .
+  map go . maybe id take mnumln . drop startln . BS8.lines
+  where
+    {-# NOINLINE go #-}
+    go = fromRight (HMS 0 0 0, ParseError) . P.parseOnly parseLine
+
+parseLine :: P.Parser (HMS, Event)
+parseLine = (,) <$> parseTOD <*> parseEvent
+
+parseTOD :: P.Parser HMS
+parseTOD = do
+  _ <- P.char '['
+  tod <- HMS <$> pTwoDigs <*> (P.char ':' >> pTwoDigs) <*> (P.char ':' >> pTwoDigs)
+  _ <- P.string "] "
+  return tod
+
+-- Adapted from clogparse by Keegan McAllister (BSD3) (https://hackage.haskell.org/package/clogparse).
+parseEvent :: P.Parser Event
+parseEvent = asum
+  [ P.string "*** " *> asum
+    [ userAct Join  "Joins: "
+    , userAct' Part "Parts: "
+    , userAct' Quit "Quits: "
+    , ReNick <$> nick <*> (P.string " is now known as " *> nick)
+    , Mode   <$> nick <*> (P.string " sets mode: " *> remaining)
+    , Kick <$> (nick <* P.string " was kicked by ") <*> nick <* P.char ' ' <*> encloseTail '(' ')'
+    , Topic <$> (nick <* P.string " changes topic to ") <*> encloseTail '\'' '\''
+    ]
+  , Talk   <$ P.char '<'    <*> nick <*  P.string "> " <*> remaining
+  , Notice <$ P.char '-'    <*> nick <*> remaining -- FIXME: parse host
+  , Act    <$ P.string "* " <*> nick <*  P.char ' '  <*> remaining
+  ] where
+    nick = utf8 <$> P.takeWhile (not . P.inClass " \n\r\t\v<>")
+    userAct f x = f <$ P.string x <*> nick <* P.char ' ' <*> parens
+    userAct' f x = f <$ P.string x <*> nick <* P.char ' ' <*> parens <* P.char ' ' <*> encloseTail '(' ')'
+    parens = P.char '(' >> (utf8 <$> P.takeWhile (/= ')')) <* P.char ')'
+    encloseTail c1 c2 = do _ <- P.char c1
+                           bs <- P.takeByteString
+                           case BS.unsnoc bs of
+                             Just (s, c) | c == fromIntegral (ord c2) -> return (utf8 s)
+                             _ -> fail "Wrong end char"
+    utf8 = TE.decodeUtf8Lenient
+    remaining = utf8 <$> P.takeByteString
+
+pTwoDigs :: P.Parser Word8
+pTwoDigs = do
+  let digit = do
+        c <- P.satisfy (\c -> '0' <= c && c <= '9')
+        return (fromIntegral (ord c - ord '0'))
+  c1 <- digit
+  c2 <- digit
+  return (10 * c1 + c2)
author	Tom Smeding <tom@tomsmeding.com>	2026-03-29 23:25:10 +0200
committer	Tom Smeding <tom@tomsmeding.com>	2026-03-29 23:25:10 +0200
commit	f21dcde54b09913550036e6501cca935278597d9 (patch)
tree	505f373b1bce690f0bafc2038636721126d9bcad