Calendar view

1 files changed, 118 insertions, 31 deletions

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