diff options
Diffstat (limited to 'src/Main.hs')
| -rw-r--r-- | src/Main.hs | 107 |
1 files changed, 60 insertions, 47 deletions
diff --git a/src/Main.hs b/src/Main.hs index 433f6c6..77dfa29 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -63,18 +63,23 @@ sendPage200 pages name sub = [("Content-Type", "text/html")] (TE.encodeUtf8Builder (substituteValue (getPage pages name) sub)) -pageIndex :: Config -> Pages -> IO Response -pageIndex conf pages = - return $ sendPage200 pages "index" $ M.object - ["networks" ~> - [M.object - ["name" ~> nw - ,"channels" ~> - [M.object ["name" ~> ch, "alias" ~> econfChan2Alias conf Map.! Channel nw ch] - | ch <- chs]] - | (nw, chs) <- - [(nw, ch : map chanChannel chs) - | Channel nw ch :| chs <- groupBy ((==) `on` chanNetwork) (econfChannels conf)]]] +pageIndex :: Config -> IO Response +pageIndex conf = + return $ responseBS + status200 + [("Content-Type", "text/html")] + (renderPageIndex IndexData + { networks = + [IndexNetworkData + { name = nw + , channels = + [IndexChannelData + { name = ch + , alias = econfChan2Alias conf Map.! Channel nw ch } + | ch <- chs] } + | (nw, chs) <- + [(nw, ch : map chanChannel chs) + | Channel nw ch :| chs <- groupBy ((==) `on` chanNetwork) (econfChannels conf)]]}) pageLog :: Config -> Index -> Request -> Text -> IO Response pageLog conf index req alias = @@ -365,35 +370,50 @@ renderEvent = \case 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 = +pageCalendar :: Config -> Index -> Text -> IO Response +pageCalendar conf index alias = case econfAlias2Chan conf Map.!? alias of Nothing -> page404 "Channel not found" Just chan -> do ((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)])])])] + return $ responseBS + status200 + [("Content-Type", "text/html")] + (renderPageCalendar CalendarData + { network = chanNetwork chan + , channel = chanChannel chan + , alias = alias + , years = flip map (reverse (calendarLayout startDay endDay counts)) $ \(year, monrows) -> + CalendarYearData + { year = fromIntegral @Integer @Int year + , monrows = flip map monrows $ \monrow -> + CalendarMonthRowData + { months = flip map monrow $ \case + Nothing -> + CalendarMonthData + { display = False + , month = 0 + , month00 = "" + , monthname = "" + , weeks = [] + , phantomweek = False } + Just (month, weeks) -> + CalendarMonthData + { display = True + , month = month + , month00 = T.pack (pad '0' 2 month) + , monthname = monthNames !! (month - 1) + , weeks = flip map weeks $ \week -> + CalendarWeekData + { days = flip map week $ \case + Nothing -> + CalendarDayData' + { date = Nothing, date00 = "" } + Just (d, _count) -> + CalendarDayData' + { date = Just d, date00 = T.pack (pad '0' 2 d) }} + , phantomweek = False } + }}}) where monthNames :: [Text] monthNames = ["January", "February", "March", "April" @@ -412,25 +432,18 @@ mainServe confpath = do index <- initIndex (confLogsDir config) (econfChannels config) - let templateFiles = ["index", "log", "calendar", "calendar-day"] - staticFiles = ["style.css", "robots.txt", "favicon.png"] - - 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) + let staticFiles = ["style.css", "robots.txt", "favicon.png"] let settings = defaultSettings { setPort = confPort config } atomicPrintS $ "Listening on port " ++ show (confPort config) run settings $ \req -> case reqPath req of [] -> - pageIndex config pages + pageIndex config ["log", TE.decodeUtf8' -> Right alias] -> pageLog config index req alias ["cal", TE.decodeUtf8' -> Right alias] -> - pageCalendar config pages index alias + pageCalendar config index alias ["cal", TE.decodeUtf8' -> Right alias, TE.decodeUtf8' -> Right date] -> pageCalendarDay config index req alias date [fname] | fname `elem` staticFiles -> |