diff options
| -rw-r--r-- | pages/calendar-day.mustache | 2 | ||||
| -rw-r--r-- | src/Index.hs | 29 | ||||
| -rw-r--r-- | src/Main.hs | 50 | ||||
| -rw-r--r-- | src/Util.hs | 8 |
4 files changed, 54 insertions, 35 deletions
diff --git a/pages/calendar-day.mustache b/pages/calendar-day.mustache index 8dc9fa1..5a01acc 100644 --- a/pages/calendar-day.mustache +++ b/pages/calendar-day.mustache @@ -19,7 +19,7 @@ <table id="events"><tbody> {{#events}} <tr{{#classlist}} class="{{.}}"{{/classlist}}> - <td>{{time}}</td> + <td><a href="/cal/{{alias}}/{{date}}?eid={{linkid}}#ev-{{linkid}}" name="ev-{{linkid}}">{{time}}</a></td> <td>{{#nickwrap1}}<span class="nickwrap">{{nickwrap1}}</span>{{/nickwrap1}}{{nick}}{{#nickwrap2}}<span class="nickwrap">{{nickwrap2}}</span>{{/nickwrap2}}</td> <td>{{message}}</td> </tr> diff --git a/src/Index.hs b/src/Index.hs index 69be325..c0f98dd 100644 --- a/src/Index.hs +++ b/src/Index.hs @@ -292,10 +292,13 @@ binSearch vec needle in if vec IGV.! mid <= needle then go mid hi else go lo mid --- | If ID is found, returns index in the linear list of events for this channel -findEventIDLinear :: Index -> Channel -> EventID -> IO (Maybe Int) +-- | If ID is found, returns: +-- - Timestamp of the event +-- - Index in the linear list of events for this channel +-- - Index in the list of events in the channel on that day +findEventIDLinear :: Index -> Channel -> EventID -> IO (Maybe (YMDHMS, Int, Int)) findEventIDLinear index@(Index _ mp _) chan eid = runMaybeT $ do - (YMDHMS ymd hms, idoff) <- hoistMaybe (parseEventID eid) + (ymdhms@(YMDHMS ymd hms), idoff) <- hoistMaybe (parseEventID eid) day <- hoistMaybe (uncurry3 fromGregorianValid (ymdToGregorian ymd)) ci <- lift $ readIORef (mp Map.! chan) @@ -314,7 +317,7 @@ findEventIDLinear index@(Index _ mp _) chan eid = runMaybeT $ do eventsBeforeDay | dayidx == 0 = 0 | otherwise = ciCountUntil ci IGV.! (dayidx - 1) let dayoff = minimumBy (comparing (\off -> abs (off - idoff))) candidates - return (eventsBeforeDay + dayoff) + return (ymdhms, eventsBeforeDay + dayoff, dayoff) -- other methods @@ -331,14 +334,18 @@ indexCalendar (Index _ mp _) chan = do else scan IGV.! i - scan IGV.! (i - 1) | i <- [0 .. IGV.length scan - 1]]) -indexGetEventsDay :: Index -> Channel -> Day -> IO [(HMS, Event)] +indexGetEventsDay :: Index -> Channel -> Day -> IO [(HMS, EventID, Event)] indexGetEventsDay index@(Index _ mp _) chan day = do ci <- readIORef (mp Map.! chan) + let ymd = dayToYMD day if day < ciStartDay ci || day > ciEndDay ci then return [] - else loadDay index chan (dayToYMD day) >>= \case - Just (bs, _lineStarts) -> return (parseLog bs) - Nothing -> return [] -- if the file doesn't exist, there ain't no events + else loadDay index chan ymd <&> \case + Just (bs, _lineStarts) -> + let events = parseLog bs + in zipWith (\(hms, ev) off -> (hms, genEventID (YMDHMS ymd hms) off, ev)) + events [0..] + Nothing -> [] -- if the file doesn't exist, there ain't no events -- utilities @@ -425,12 +432,6 @@ parseFileName name Just r -> r Nothing -> error $ "No read: " ++ show s -ymdToGregorian :: YMD -> (Year, MonthOfYear, DayOfMonth) -ymdToGregorian (YMD y m d) = (fromIntegral y, fromIntegral m, fromIntegral d) - -ymdFromGregorian :: (Year, MonthOfYear, DayOfMonth) -> YMD -ymdFromGregorian (y, m, d) = YMD (fromIntegral y) (fromIntegral m) (fromIntegral d) - toFileName :: YMD -> String toFileName ymd = ymdToString ymd ++ ".log" diff --git a/src/Main.hs b/src/Main.hs index 380c6be..cc4ad7e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -20,7 +20,7 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as TE import Data.Text.IO.Utf8 qualified as T -import Data.Time (Day, fromGregorianValid) +import Data.Time (Day, toGregorian, fromGregorianValid) import Network.Wai import Network.HTTP.Types import Network.Wai.Handler.Warp (runSettings, defaultSettings, setFork, setPort) @@ -79,11 +79,11 @@ pageLog conf pages index req alias = numEvents <- indexNumEvents index chan let npages = (numEvents + numPerPage - 1) `div` numPerPage (mcurpage, mpagehighlight) <- - if | Just (readMaybe . BS8.unpack -> Just pg) <- query "page" -> return (Just (min npages (max 1 pg)), Nothing) - | Just (TE.decodeASCII' -> Just eventID) <- query "eid" -> do + if | Just (readMaybe . BS8.unpack -> Just pg) <- query req "page" -> return (Just (min npages (max 1 pg)), Nothing) + | Just (TE.decodeASCII' -> Just eventID) <- query req "eid" -> do mevidx <- findEventIDLinear index chan eventID case mevidx of - Just evidx -> return (Just (evidx `div` numPerPage + 1), Just (evidx `mod` numPerPage)) + Just (_, evidx, _) -> return (Just (evidx `div` numPerPage + 1), Just (evidx `mod` numPerPage)) Nothing -> return (Nothing, Nothing) | otherwise -> return (Just npages, Nothing) case mcurpage of @@ -126,43 +126,45 @@ pageLog conf pages index req alias = 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 - 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)) - classListAdd :: Maybe Text -> Text -> Text - classListAdd Nothing t = t - classListAdd (Just l) t = l <> " " <> t - -pageCalendarDay :: Config -> Pages -> Index -> Text -> Text -> IO Response -pageCalendarDay conf pages index alias datestr = +pageCalendarDay :: Config -> Pages -> Index -> Request -> Text -> Text -> IO Response +pageCalendarDay conf pages index req 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 + mpagehighlight <- + if | Just (TE.decodeASCII' -> Just eventID) <- query req "eid" -> do + mevidx <- findEventIDLinear index chan eventID + case mevidx of + Just (YMDHMS ymd _, _, evdayidx) + | ymd == ymdFromGregorian (toGregorian day) -> + return (Just evdayidx) + _ -> return Nothing + | otherwise -> return Nothing return $ sendPage200 pages "calendar-day" $ M.object ["network" ~> chanNetwork chan ,"channel" ~> chanChannel chan ,"alias" ~> alias ,"date" ~> ymdToString (dayToYMD day) ,"events" ~> [M.object - ["classlist" ~> classlist + ["classlist" ~> if mpagehighlight == Just dayidx + then Just (classlist `classListAdd` "highlight") + else classlist ,"time" ~> let HMS h mi s = time in pad '0' 2 h ++ ':' : pad '0' 2 mi ++ ':' : pad '0' 2 s + ,"linkid" ~> eid ,"nickwrap1" ~> nickw1 ,"nick" ~> nick ,"nickwrap2" ~> nickw2 ,"message" ~> msg] - | (time, ev) <- events + | ((time, eid, ev), dayidx) <- zip events [0..] , let (classlist, (nickw1, nick, nickw2), msg) = renderEvent ev]] where parseDatestr :: Text -> Maybe Day @@ -179,6 +181,16 @@ pageCalendarDay conf pages index alias datestr = parseInt t | T.all isDigit t = Just (T.foldl' (\n c -> 10 * n + (ord c - ord '0')) 0 t) | otherwise = Nothing +classListAdd :: Maybe Text -> Text -> Text +classListAdd Nothing t = t +classListAdd (Just l) t = l <> " " <> t + +query :: Request -> ByteString -> Maybe ByteString +query req key = case lookup key (queryString req) of + Nothing -> Nothing + Just Nothing -> Nothing -- given but empty; treat as not given + Just (Just value) -> Just value + -- Returns: (classlist, (nickwrap1, nick, nickwrap2), message) renderEvent :: Event -> (Maybe Text, (Maybe Text, Text, Maybe Text), Text) renderEvent = \case @@ -282,7 +294,7 @@ mainServe confpath = do ["cal", alias] -> respond =<< pageCalendar config pages index alias ["cal", alias, date] -> - respond =<< pageCalendarDay config pages index alias date + respond =<< pageCalendarDay config pages index req alias date [fname] | fname `elem` staticFiles -> respond $ responseFile status200 [] ("pages/" ++ T.unpack fname) Nothing _ -> diff --git a/src/Util.hs b/src/Util.hs index 4c09705..64c0bfc 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -3,7 +3,7 @@ module Util (module Util, toList) where import Data.Foldable (toList) import Data.Maybe (fromMaybe) -import Data.Time (Day, toGregorian) +import Data.Time import Data.Word (Word8) @@ -52,3 +52,9 @@ dayToYMD :: Day -> YMD dayToYMD day = let (y, m, d) = toGregorian day in YMD (fromIntegral y) (fromIntegral m) (fromIntegral d) + +ymdToGregorian :: YMD -> (Year, MonthOfYear, DayOfMonth) +ymdToGregorian (YMD y m d) = (fromIntegral y, fromIntegral m, fromIntegral d) + +ymdFromGregorian :: (Year, MonthOfYear, DayOfMonth) -> YMD +ymdFromGregorian (y, m, d) = YMD (fromIntegral y) (fromIntegral m) (fromIntegral d) |