Timestamp links on calendar-day page

3 files changed, 53 insertions, 34 deletions

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)