{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} module Main (main) where import Control.Exception (mask_) 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 qualified as BSL import Data.Char (isDigit, ord) import Data.Function (on, (&)) import Data.IORef 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.Encoding qualified as TE import Data.Text.IO.Utf8 qualified as T import Data.Time (Day, fromGregorianValid) import Network.Wai import Network.HTTP.Types import Network.Wai.Handler.Warp (runSettings, defaultSettings, setFork, setPort) import Network.Wai.Handler.Warp.Internal (Settings(..)) import System.Environment import System.Exit (die) import System.Posix.Resource import Text.Mustache (Template, compileTemplate, substituteValue, (~>)) import Text.Mustache qualified as M import Text.Mustache.Types (Value(..)) import Text.Read (readMaybe) -- import Debug.Trace import AtomicPrint import Calendar import Config import Index import Util import ZNC 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 sendPage200 :: Pages -> String -> Value -> Response sendPage200 pages name sub = responseBuilder status200 [("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)]]] pageLog :: Config -> Pages -> Index -> Request -> Text -> IO Response pageLog conf pages index req alias = case econfAlias2Chan conf Map.!? alias of Nothing -> page404 "Channel not found" Just chan -> do numEvents <- indexNumEvents index chan let npages = (numEvents + numPerPage - 1) `div` numPerPage curpage | Just (readMaybe . BS8.unpack -> Just pg) <- query "page" = min npages (max 1 pg) | otherwise = npages 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 $ 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" ~> 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 ,"nickwrap1" ~> nickw1 ,"nick" ~> nick ,"nickwrap2" ~> nickw2 ,"message" ~> msg] | (time, ev) <- events , let (classlist, (nickw1, nick, nickw2), msg) = renderEvent ev]] where numPerPage = 100 query :: ByteString -> Maybe ByteString query key = case lookup key (queryString req) of Nothing -> Nothing Just Nothing -> Nothing -- given but empty; treat as not given Just (Just value) -> Just value 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)) 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), "") 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 ((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")] message getUlimitFiles :: IO Int getUlimitFiles = do limits <- getResourceLimit ResourceOpenFiles let infer ResourceLimitInfinity = maxBound infer ResourceLimitUnknown = maxBound infer (ResourceLimit n) = fromIntegral n return (infer (softLimit limits) `min` infer (hardLimit limits)) mainServe :: FilePath -> IO () mainServe confpath = do config <- enrichConfig <$> readConfig confpath index <- initIndex (confLogsDir config) (econfChannels config) let templateFiles = ["index", "log", "calendar", "calendar-day"] 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)) when (count <= connectionLimit) $ settingsFork defaultSettings k atomicModifyIORef' counter (\i -> (i - 1, ())) settings = defaultSettings & setFork checkedFork & setPort (confPort config) atomicPrintS $ "Listening on port " ++ show (confPort config) runSettings settings $ \req respond -> case pathInfo req of [] -> 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 not found" testParseLog :: FilePath -> IO () testParseLog fname = print =<< parseLog <$> BS.readFile fname main :: IO () main = getArgs >>= \case ["test", "parselog", fname] -> testParseLog fname ["serve", fname] -> mainServe fname _ -> die "Expected command-line argument (see Main.hs)"