diff options
Diffstat (limited to 'src/Main.hs')
| -rw-r--r-- | src/Main.hs | 156 |
1 files changed, 99 insertions, 57 deletions
diff --git a/src/Main.hs b/src/Main.hs index 5c73fce..433f6c6 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE LinearTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -41,6 +42,7 @@ import Calendar import Config import EscapeXML import Index +import Pages import Util import ZNC import System.Directory (listDirectory) @@ -74,8 +76,8 @@ pageIndex conf pages = [(nw, ch : map chanChannel chs) | Channel nw ch :| chs <- groupBy ((==) `on` chanNetwork) (econfChannels conf)]]] -pageLog :: Config -> Pages -> Index -> Request -> Text -> IO Response -pageLog conf pages index req alias = +pageLog :: Config -> Index -> Request -> Text -> IO Response +pageLog conf index req alias = case econfAlias2Chan conf Map.!? alias of Nothing -> page404 "Channel not found" Just chan -> do @@ -96,36 +98,73 @@ pageLog conf pages index req alias = ntoright = min 5 (npages - curpage) -- traceShowM (indexNumEvents index chan, npages, curpage, ntoleft, ntoright) events <- indexGetEventsLinear index chan ((curpage - 1) * numPerPage) numPerPage - 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 - ,"nickE" ~> escapeXML nick - ,"nickwrap2" ~> nickw2 - ,"messageE" ~> escapeXML msg] - | ((time, eid, ev), dayidx) <- zip events [0..] - , let (classlist, (nickw1, nick, nickw2), msg) = renderEvent ev]] + return $ responseBS + status200 + [("Content-Type", "text/html")] + (renderPageLog LogData + { network = chanNetwork chan + , channel = chanChannel chan + , alias = alias + , totalevents = renderLargeNumber numEvents + , picker = PickerData + { 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 = + [EventData + { classlist = if mpagehighlight == Just dayidx + then Just (classlist `classListAdd` "highlight") + else classlist + , time = () + , datetime = let YMDHMS (YMD y mo d) (HMS h mi s) = time + in T.pack + (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] + }) + -- 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 @@ -243,8 +282,8 @@ renderSimple topnodes topvalue = runBufferBS (\b -> foldlIntoBuffer (go [topvalu -- _ -> case consumeBuffer buf of -- () -> error $ "renderCalendarDayPage: unexpected node in implicit section: " ++ show node -pageCalendarDay :: Config -> Pages -> Index -> Request -> Text -> Text -> IO Response -pageCalendarDay conf pages index req alias datestr = +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" @@ -260,31 +299,34 @@ pageCalendarDay conf pages index req alias datestr = _ -> return Nothing | otherwise -> return Nothing + return $ responseBS + status200 + [("Content-Type", "text/html")] + (renderPageCalendarDay CalendarDayData + { network = chanNetwork chan + , channel = chanChannel chan + , alias = alias + , date = T.pack (ymdToString (dayToYMD day)) + , events = + [EventData + { classlist = if mpagehighlight == Just dayidx + then Just (classlist `classListAdd` "highlight") + else classlist + , time = let HMS h mi s = time + in T.pack (pad '0' 2 h ++ ':' : pad '0' 2 mi ++ ':' : pad '0' 2 s) + , datetime = () + , 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] }) + -- return $ responseBS -- status200 -- [("Content-Type", "text/html")] -- (renderCalendarDayPage (getPage pages "calendar-day") chan day alias mpagehighlight events) - - -- -- return $ sendPage200 pages "calendar-day" $! forceValue $ M.object - -- return $ sendPage200 pages "calendar-day" $ M.object - return $ responseBS status200 [("Content-Type", "text/html")] $ renderSimple (toSimple (getPage pages "calendar-day")) $ M.object - ["network" ~> chanNetwork chan - ,"channel" ~> chanChannel chan - ,"alias" ~> alias - ,"date" ~> ymdToString (dayToYMD day) - ,"events" ~> [M.object - ["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 - ,"nickE" ~> escapeXML nick - ,"nickwrap2" ~> nickw2 - ,"messageE" ~> escapeXML msg] - | ((time, eid, ev), dayidx) <- zip events [0..] - , let (classlist, (nickw1, nick, nickw2), msg) = renderEvent ev]] where parseDatestr :: Text -> Maybe Day parseDatestr t = do -- YYYY-mm-dd @@ -386,11 +428,11 @@ mainServe confpath = do [] -> pageIndex config pages ["log", TE.decodeUtf8' -> Right alias] -> - pageLog config pages index req alias + pageLog config index req alias ["cal", TE.decodeUtf8' -> Right alias] -> pageCalendar config pages index alias ["cal", TE.decodeUtf8' -> Right alias, TE.decodeUtf8' -> Right date] -> - pageCalendarDay config pages index req alias date + pageCalendarDay config index req alias date [fname] | fname `elem` staticFiles -> return $ responseFile status200 [] ("pages/" ++ BS8.unpack fname) _ -> |