Clean up

4 files changed, 33 insertions, 209 deletions

diff --git a/server-test/Main.hs b/server-test/Main.hs
index d15ad70..43cba76 100644
--- a/server-test/Main.hs
+++ b/server-test/Main.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Main where
 
+import Control.Monad (when)
 import Control.Monad.Trans.State.Strict
 import Data.ByteString (ByteString)
 import Data.ByteString qualified as BS
@@ -19,7 +20,8 @@ randomSlicing 1 target = return [target]
 randomSlicing numslice target = do
   n1 <- Gen.integral (Range.constant 1 (target - numslice))
   ns <- (n1:) <$> go (numslice - 1) (target - n1)
-  if sum ns /= target || any (== 0) ns then error (show (ns, target)) else return ()
+  when (sum ns /= target || any (== 0) ns) $
+    error (show (ns, target))
   Gen.shuffle ns
   where
     go 1 tg
diff --git a/src/Index.hs b/src/Index.hs
index 3e40cac..94c3f9e 100644
--- a/src/Index.hs
+++ b/src/Index.hs
@@ -418,7 +418,7 @@ parseEventID (T.uncons -> Just ('a', eid)) = do
                  (HMS (cast hh) (cast mm) (cast ss))
          ,cast off)
   where
-    multiply = sum . map (uncurry (*)) . zip (iterate (*62) 1) . reverse
+    multiply = sum . zipWith (*) (iterate (*62) 1) . reverse
     unbase62char c
       | '0' <= c, c <= '9' = Just (ord c - ord '0')
       | 'A' <= c, c <= 'Z' = Just (ord c - ord 'A' + 10)
diff --git a/src/Main.hs b/src/Main.hs
index 7cd2c65..5739065 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,74 +1,51 @@
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DisambiguateRecordFields #-}
-{-# LANGUAGE LinearTypes #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ViewPatterns #-}
 module Main (main) where
 
-import Control.Applicative ((<|>))
-import Control.Monad (forM, guard, forM_)
+import Control.Monad (guard, forM_)
 import Data.ByteString (ByteString)
 import Data.ByteString qualified as BS
 import Data.ByteString.Char8 qualified as BS8
 import Data.ByteString.Lazy qualified as BSL
 import Data.Char (isDigit, ord)
 import Data.Function (on)
-import Data.HashMap.Strict qualified as HM
 import Data.List.NonEmpty (NonEmpty((:|)), groupBy)
-import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
 import Data.Text (Text)
 import Data.Text qualified as T
-import Data.Text.Builder.Linear.Buffer
 import Data.Text.Encoding qualified as TE
-import Data.Text.IO.Utf8 qualified as T
 import Data.Time (Day, toGregorian, fromGregorianValid)
+import System.Directory (listDirectory)
 import System.Environment
 import System.Exit (die)
 import System.FilePath ((</>))
-import Text.Mustache (Template, compileTemplate, substituteValue, (~>))
-import Text.Mustache qualified as M
-import Text.Mustache.Types (Value(..))
-import Text.Mustache.Types qualified as M
 import Text.Read (readMaybe)
 
 import Network.HTTP.Server.Mini
 import Network.HTTP.Server.Mini.Internal.Instrument (atomicPrintS)
 
--- import Debug.Trace
-
 import Calendar
 import Config
-import EscapeXML
 import Index
 import Pages
 import Util
 import ZNC
-import System.Directory (listDirectory)
-
 
-newtype Pages = Pages (Map String Template)
 
-getPage :: Pages -> String -> Template
-getPage (Pages mp) name =
-  case Map.lookup name mp of
-    Just tpl -> tpl
-    Nothing -> error $ "Not a page: " ++ name
+sendHtml200 :: ByteString -> IO Response
+sendHtml200 = return . responseBS status200 [("Content-Type", "text/html")]
 
-sendPage200 :: Pages -> String -> Value -> Response
-sendPage200 pages name sub =
-  responseBuilder
-    status200
-    [("Content-Type", "text/html")]
-    (TE.encodeUtf8Builder (substituteValue (getPage pages name) sub))
+sendText404 :: BSL.ByteString -> IO Response
+sendText404 message = return $ responseLBS
+  status404
+  [("Content-Type", "text/plain")]
+  message
 
 pageIndex :: Config -> IO Response
 pageIndex conf =
-  return $ responseBS
-    status200
-    [("Content-Type", "text/html")]
-    (renderPageIndex IndexData
+  sendHtml200 $
+    renderPageIndex IndexData
       { networks =
           [IndexNetworkData
             { name = nw
@@ -79,12 +56,12 @@ pageIndex conf =
                 | ch <- chs] }
           | (nw, chs) <-
               [(nw, ch : map chanChannel chs)
-              | Channel nw ch :| chs <- groupBy ((==) `on` chanNetwork) (econfChannels conf)]]})
+              | Channel nw ch :| chs <- groupBy ((==) `on` chanNetwork) (econfChannels conf)]]}
 
 pageLog :: Config -> Index -> Request -> Text -> IO Response
 pageLog conf index req alias =
   case econfAlias2Chan conf Map.!? alias of
-    Nothing -> page404 "Channel not found"
+    Nothing -> sendText404 "Channel not found"
     Just chan -> do
       numEvents <- indexNumEvents index chan
       let npages = (numEvents + numPerPage - 1) `div` numPerPage
@@ -97,16 +74,14 @@ pageLog conf index req alias =
                  Nothing -> return (Nothing, Nothing)
            | otherwise -> return (Just npages, Nothing)
       case mcurpage of
-        Nothing -> page404 "Event ID not found"
+        Nothing -> sendText404 "Event ID not found"
         Just curpage -> do
           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
-          return $ responseBS
-            status200
-            [("Content-Type", "text/html")]
-            (renderPageLog LogData
+          sendHtml200 $
+            renderPageLog LogData
               { network = chanNetwork chan
               , channel = chanChannel chan
               , alias = alias
@@ -139,37 +114,7 @@ pageLog conf index req alias =
                      , message = msg }
                   | ((time, eid, ev), dayidx) <- zip events [0..]
                   , let (classlist, (nickw1, nick, nickw2), msg) = renderEvent ev]
-              })
-          -- return $ sendPage200 pages "log" $ M.object
-          --   ["network" ~> chanNetwork chan
-          --   ,"channel" ~> chanChannel chan
-          --   ,"alias" ~> alias
-          --   ,"totalevents" ~> renderLargeNumber numEvents
-          --   ,"picker" ~> M.object
-          --     ["prevpage" ~> if curpage > 1 then Just (curpage - 1) else Nothing
-          --     ,"nextpage" ~> if curpage < npages then Just (curpage + 1) else Nothing
-          --     ,"firstpage" ~> (curpage > 6)
-          --     ,"leftdots" ~> (curpage > 7)
-          --     ,"rightdots" ~> (curpage < npages - 6)
-          --     ,"lastpage" ~> (curpage < npages - 5)
-          --     ,"leftnums" ~> [curpage - ntoleft .. curpage - 1]
-          --     ,"curnum" ~> curpage
-          --     ,"rightnums" ~> [curpage + 1 .. curpage + ntoright]
-          --     ,"npages" ~> npages]
-          --   ,"events" ~> [M.object
-          --                  ["classlist" ~> if mpagehighlight == Just dayidx
-          --                                    then Just (classlist `classListAdd` "highlight")
-          --                                    else classlist
-          --                  ,"datetime" ~> let YMDHMS (YMD y mo d) (HMS h mi s) = time
-          --                                 in pad '0' 4 y ++ '-' : pad '0' 2 mo ++ '-' : pad '0' 2 d ++ ' ' :
-          --                                    pad '0' 2 h ++ ':' : pad '0' 2 mi ++ ':' : pad '0' 2 s
-          --                  ,"linkid" ~> eid
-          --                  ,"nickwrap1" ~> nickw1
-          --                  ,"nick" ~> nick
-          --                  ,"nickwrap2" ~> nickw2
-          --                  ,"message" ~> msg]
-          --                | ((time, eid, ev), dayidx) <- zip events [0..]
-          --                , let (classlist, (nickw1, nick, nickw2), msg) = renderEvent ev]]
+              }
   where
     numPerPage = 100
 
@@ -179,119 +124,11 @@ pageLog conf index req alias =
       | n < 1000 = T.show n
       | otherwise = renderLargeNumber (n `div` 1000) <> "," <> T.pack (pad '0' 3 (n `mod` 1000))
 
--- rnfValue :: Value -> ()
--- rnfValue (Object o) = foldMap rnfValue o
--- rnfValue (Array a) = foldMap rnfValue a
--- rnfValue (Number !_) = ()
--- rnfValue (String !_) = ()
--- rnfValue Lambda{} = error "Lambda"
--- rnfValue (Bool !_) = ()
--- rnfValue Null = ()
-
--- {-# NOINLINE forceValue #-}
--- forceValue :: Value -> Value
--- forceValue v = rnfValue v `seq` v
-
-data SimpleNode
-  = STextBlock !Text
-  | SSection !Text ![SimpleNode]
-  | SVariable {-# UNPACK #-} !Bool !Text
-  deriving (Show)
-
-toSimple :: Template -> [SimpleNode]
-toSimple (M.Template _ nodes _) = map (go Nothing) nodes
-  where
-    go :: Maybe Text -> M.Node Text -> SimpleNode
-    go _ (M.TextBlock t) = STextBlock t
-    go _ (M.Variable esc (M.NamedData [name])) = SVariable esc name
-    go (Just ctx) (M.Variable esc M.Implicit) = SVariable esc ctx
-    go Nothing (M.Variable _ M.Implicit) = error "toSimple: {{.}} outside section"
-    go _ (M.Section (M.NamedData [name]) ns) = SSection name (map (go (Just name)) ns)
-    go _ node = error $ "toSimple: unsupported node: " ++ show node
-
-renderSimple :: [SimpleNode] -> Value -> ByteString
-renderSimple topnodes topvalue = runBufferBS (\b -> foldlIntoBuffer (go [topvalue]) b topnodes)
-  where
-    go :: [Value] -> Buffer %1 -> SimpleNode -> Buffer
-    go values buf node = case node of
-      STextBlock t -> buf |> t
-      SSection name nodes -> case searchName name values of
-        Just (M.Bool False) -> buf
-        Just (M.Array vec) ->
-          foldlIntoBuffer (\b v -> foldlIntoBuffer (go (v : values)) b nodes) buf (toList vec)
-        Just value -> foldlIntoBuffer (go (value : values)) buf nodes
-        Nothing -> case consumeBuffer buf of () -> error $ "renderSimple: name " ++ show name ++ " not found"
-      SVariable esc name -> case searchName name values of
-        Just (M.String t)
-          | esc -> buf |> escapeXML t
-          | otherwise -> buf |> t
-        Just M.Null -> buf
-        Just value -> case consumeBuffer buf of () -> error $ "renderSimple: unsupported value type " ++ show value
-        Nothing -> case consumeBuffer buf of () -> error $ "renderSimple: name " ++ show name ++ " not found"
-
-    searchName :: Text -> [Value] -> Maybe Value
-    searchName n (M.Object obj : vs) = HM.lookup n obj <|> searchName n vs
-    searchName _ [] = Nothing
-    searchName n (_ : vs) = searchName n vs
-
--- renderCalendarDayPage :: Template -> Channel -> Day -> Text -> Maybe Int -> [(HMS, EventID, Event)] -> ByteString
--- renderCalendarDayPage (M.Template _ nodes _) chan day alias mpagehighlight events =
---   runBufferBS (\b -> foldlIntoBuffer goTop b nodes)
---   where
---     date = T.pack (ymdToString (dayToYMD day))
-
---     goTop :: Buffer %1-> M.Node Text -> Buffer
---     goTop buf node = case node of
---       M.TextBlock t -> buf |> t
---       M.Variable _ (M.NamedData ["channel"]) -> buf |> chanChannel chan
---       M.Variable _ (M.NamedData ["network"]) -> buf |> chanNetwork chan
---       M.Variable _ (M.NamedData ["date"]) -> buf |> date
---       M.Variable _ (M.NamedData ["alias"]) -> buf |> alias
---       M.Section (M.NamedData ["events"]) ns ->
---         foldlIntoBuffer
---           (\b ((time, eid, event), dayidx) ->
---             let tup = renderEvent event
---             in foldlIntoBuffer (\b' n -> goEv b' time eid dayidx tup n) b ns)
---           buf (zip events [0..])
---       _ -> case consumeBuffer buf of
---              () -> error $ "renderCalendarDayPage: unexpected top node " ++ show node
-
---     goEv :: Buffer %1-> HMS -> EventID -> Int -> (Maybe Text, (Maybe Text, Text, Maybe Text), Text) -> M.Node Text -> Buffer
---     goEv buf time eid dayidx (classlist, (nickw1, nick, nickw2), msg) node = case node of
---       M.TextBlock t -> buf |> t
---       M.Variable _ (M.NamedData ["alias"]) -> buf |> alias
---       M.Variable _ (M.NamedData ["date"]) -> buf |> date
---       M.Variable _ (M.NamedData ["linkid"]) -> buf |> eid
---       M.Variable _ (M.NamedData ["time"]) ->
---         buf |> T.pack (let HMS h mi s = time
---                        in pad '0' 2 h ++ ':' : pad '0' 2 mi ++ ':' : pad '0' 2 s)
---       M.Variable _ (M.NamedData ["nickE"]) -> buf |> escapeXML nick
---       M.Variable _ (M.NamedData ["messageE"]) -> buf |> escapeXML msg
---       M.Section (M.NamedData ["classlist"]) ns ->
---         let classlist' | mpagehighlight == Just dayidx = Just (classlist `classListAdd` "highlight")
---                        | otherwise = classlist
---         in goMaybe buf goImplicit classlist' ns
---       M.Section (M.NamedData ["nickwrap1"]) ns -> goMaybe buf goImplicit nickw1 ns
---       M.Section (M.NamedData ["nickwrap2"]) ns -> goMaybe buf goImplicit nickw2 ns
---       _ -> case consumeBuffer buf of
---              () -> error $ "renderCalendarDayPage: unexpected node in event section: " ++ show node
-
---     goMaybe :: Buffer %1-> (Buffer %1-> a -> M.Node Text -> Buffer) -> Maybe a -> [M.Node Text] -> Buffer
---     goMaybe buf _ Nothing _ = buf
---     goMaybe buf f (Just x) ns = foldlIntoBuffer (\b n -> f b x n) buf ns
-
---     goImplicit :: Buffer %1-> Text -> M.Node Text -> Buffer
---     goImplicit buf cl node = case node of
---       M.TextBlock t -> buf |> t
---       M.Variable False M.Implicit -> buf |> cl
---       _ -> case consumeBuffer buf of
---              () -> error $ "renderCalendarDayPage: unexpected node in implicit section: " ++ show node
-
 pageCalendarDay :: Config -> Index -> Request -> Text -> Text -> IO Response
 pageCalendarDay conf index req alias datestr =
   case (econfAlias2Chan conf Map.!? alias, parseDatestr datestr) of
-    (Nothing, _) -> page404 "Channel not found"
-    (_, Nothing) -> page404 "Invalid date"
+    (Nothing, _) -> sendText404 "Channel not found"
+    (_, Nothing) -> sendText404 "Invalid date"
     (Just chan, Just day) -> do
       events <- indexGetEventsDay index chan day
       mpagehighlight <-
@@ -304,10 +141,8 @@ pageCalendarDay conf index req alias datestr =
                  _ -> return Nothing
            | otherwise -> return Nothing
 
-      return $ responseBS
-        status200
-        [("Content-Type", "text/html")]
-        (renderPageCalendarDay CalendarDayData
+      sendHtml200 $
+        renderPageCalendarDay CalendarDayData
           { network = chanNetwork chan
           , channel = chanChannel chan
           , alias = alias
@@ -326,12 +161,7 @@ pageCalendarDay conf index req alias datestr =
                 , nickwrap2 = nickw2
                 , message = msg }
               | ((time, eid, ev), dayidx) <- zip events [0..]
-              , let (classlist, (nickw1, nick, nickw2), msg) = renderEvent ev] })
-
-      -- return $ responseBS
-      --   status200
-      --   [("Content-Type", "text/html")]
-      --   (renderCalendarDayPage (getPage pages "calendar-day") chan day alias mpagehighlight events)
+              , let (classlist, (nickw1, nick, nickw2), msg) = renderEvent ev] }
   where
     parseDatestr :: Text -> Maybe Day
     parseDatestr t = do  -- YYYY-mm-dd
@@ -373,13 +203,11 @@ renderEvent = \case
 pageCalendar :: Config -> Index -> Text -> IO Response
 pageCalendar conf index alias =
   case econfAlias2Chan conf Map.!? alias of
-    Nothing -> page404 "Channel not found"
+    Nothing -> sendText404 "Channel not found"
     Just chan -> do
       ((startDay, endDay), counts) <- indexCalendar index chan
-      return $ responseBS
-        status200
-        [("Content-Type", "text/html")]
-        (renderPageCalendar CalendarData
+      sendHtml200 $
+        renderPageCalendar CalendarData
           { network = chanNetwork chan
           , channel = chanChannel chan
           , alias = alias
@@ -413,19 +241,13 @@ pageCalendar conf index alias =
                                           CalendarDayData'
                                             { date = Just d, date00 = T.pack (pad '0' 2 d) }}
                               , phantomweek = False }
-                            }}})
+                            }}}
   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")]
-  message
-
 prefilter :: Request -> Maybe Response
 prefilter req
   -- Facebook should stop crawling all the individual ?eid=... URLs
@@ -466,10 +288,10 @@ mainServe confpath = do
         [fname] | fname `elem` staticFiles ->
           return $ responseFile status200 [] ("pages/" ++ BS8.unpack fname)
         _ ->
-          page404 "URL not found"
+          sendText404 "URL not found"
 
 testParseLog :: FilePath -> IO ()
-testParseLog fname = print =<< parseLog <$> BS.readFile fname
+testParseLog fname = print . parseLog =<< BS.readFile fname
 
 testCount :: FilePath -> IO ()
 testCount confpath = do
diff --git a/src/Pages/TH.hs b/src/Pages/TH.hs
index 0cc93db..2061c9a 100644
--- a/src/Pages/TH.hs
+++ b/src/Pages/TH.hs
@@ -194,7 +194,7 @@ renderNodes dats buf (node : nodes) = do
         Just (VQInt, _) -> fail $ "Int value in inverted section scrutinee " ++ show named
         Just (VQUnit, _) -> fail $ "() value in inverted section scrutinee " ++ show named
         Nothing -> fail $ "Inverted section scrutinee not found: " ++ show named
-    M.Partial _ _ -> fail $ "TODO partials"
+    M.Partial _ _ -> fail "TODO partials"
 
   renderNodes dats (ExpensiveExp buf') nodes