diff options
Diffstat (limited to 'src/Main.hs')
| -rw-r--r-- | src/Main.hs | 50 |
1 files changed, 31 insertions, 19 deletions
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 _ -> |