From acd9c66c663ea6b0b2fb9dd0a563897c2fae45eb Mon Sep 17 00:00:00 2001 From: Tom Smeding Date: Fri, 3 Apr 2026 22:10:56 +0200 Subject: Calendar view --- src/Calendar.hs | 69 ++++++++++++++++++++++++++ src/Config.hs | 1 - src/Index.hs | 65 +++++++++++++++++------- src/Main.hs | 151 ++++++++++++++++++++++++++++++++++++++++++++------------ src/Util.hs | 20 ++++++++ 5 files changed, 256 insertions(+), 50 deletions(-) create mode 100644 src/Calendar.hs (limited to 'src') 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), "") - where no = Nothing; j = Just - -page404 :: String -> IO Response -page404 thing = return $ responseLBS + 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)) + +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), "") + 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) -- cgit v1.3