Prototype compressed event listing

1 files changed, 24 insertions, 6 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 5739065..246b5d3 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE ViewPatterns #-}
 module Main (main) where
 
+import Control.Applicative ((<|>))
 import Control.Monad (guard, forM_)
 import Data.ByteString (ByteString)
 import Data.ByteString qualified as BS
@@ -63,12 +64,17 @@ pageLog conf index req alias =
   case econfAlias2Chan conf Map.!? alias of
     Nothing -> sendText404 "Channel not found"
     Just chan -> do
-      numEvents <- indexNumEvents index chan
+      let (kind, kindCookie) =
+            case query req "ef" <|> cookie req "ef" of  -- event filter
+              Just "all" -> (CKAll, Just "ef=all")
+              Just "compr" -> (CKCompressed, Just "ef=compr")
+              _ -> (CKAll, Nothing)
+      numEvents <- indexNumEvents index chan kind
       let npages = (numEvents + numPerPage - 1) `div` numPerPage
       (mcurpage, mpagehighlight) <-
         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
+               mevidx <- findEventIDLinear index chan kind eventID
                case mevidx of
                  Just (_, evidx, _) -> return (Just (evidx `div` numPerPage + 1), Just (evidx `mod` numPerPage))
                  Nothing -> return (Nothing, Nothing)
@@ -79,13 +85,17 @@ pageLog conf index req alias =
           let ntoleft = min 5 (curpage - 1)
               ntoright = min 5 (npages - curpage)
           -- traceShowM (indexNumEvents index chan, npages, curpage, ntoleft, ntoright)
-          events <- indexGetEventsLinear index chan ((curpage - 1) * numPerPage) numPerPage
-          sendHtml200 $
+          events <- indexGetEventsLinear index chan kind ((curpage - 1) * numPerPage) numPerPage
+          let headers = [("Content-Type", "text/html")] ++
+                        maybe [] (\s -> [("Set-Cookie", s)]) kindCookie
+          return $ responseBS status200 headers $
             renderPageLog LogData
               { network = chanNetwork chan
               , channel = chanChannel chan
               , alias = alias
               , totalevents = renderLargeNumber numEvents
+              , efAll = kind == CKAll
+              , efCompr = kind == CKCompressed
               , picker = PickerData
                   { prevpage = if curpage > 1 then Just (curpage - 1) else Nothing
                   , nextpage = if curpage < npages then Just (curpage + 1) else Nothing
@@ -130,10 +140,14 @@ pageCalendarDay conf index req alias datestr =
     (Nothing, _) -> sendText404 "Channel not found"
     (_, Nothing) -> sendText404 "Invalid date"
     (Just chan, Just day) -> do
-      events <- indexGetEventsDay index chan day
+      let kind = case query req "ef" of
+                   Just "all" -> CKAll
+                   Just "compr" -> CKCompressed
+                   _ -> CKAll
+      events <- indexGetEventsDay index chan kind day
       mpagehighlight <-
         if | Just (TE.decodeASCII' -> Just eventID) <- query req "eid" -> do
-               mevidx <- findEventIDLinear index chan eventID
+               mevidx <- findEventIDLinear index chan kind eventID
                case mevidx of
                  Just (YMDHMS ymd _, _, evdayidx)
                    | ymd == ymdFromGregorian (toGregorian day) ->
@@ -184,6 +198,9 @@ classListAdd (Just l) t = l <> " " <> t
 query :: Request -> ByteString -> Maybe ByteString
 query req key = lookup key (reqQuery req)
 
+cookie :: Request -> ByteString -> Maybe ByteString
+cookie req name = lookup name (reqCookies req)
+
 -- Returns: (classlist, (nickwrap1, nick, nickwrap2), message)
 renderEvent :: Event -> (Maybe Text, (Maybe Text, Text, Maybe Text), Text)
 renderEvent = \case
@@ -198,6 +215,7 @@ renderEvent = \case
   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>")
+  Compressed text  -> (j "ev-meta",   (no, "", no),      text)
   where no = Nothing; j = Just
 
 pageCalendar :: Config -> Index -> Text -> IO Response