diff options
| -rw-r--r-- | aratamete-ircbrowse.cabal | 2 | ||||
| -rw-r--r-- | config.txt | 2 | ||||
| -rw-r--r-- | pages/calendar-day.mustache | 36 | ||||
| -rw-r--r-- | pages/calendar.mustache | 59 | ||||
| -rw-r--r-- | pages/log.mustache | 8 | ||||
| -rw-r--r-- | pages/style.css | 47 | ||||
| -rw-r--r-- | src/Calendar.hs | 69 | ||||
| -rw-r--r-- | src/Config.hs | 1 | ||||
| -rw-r--r-- | src/Index.hs | 65 | ||||
| -rw-r--r-- | src/Main.hs | 149 | ||||
| -rw-r--r-- | src/Util.hs | 20 |
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, @@ -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> </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">—</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) |