{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-} module Main (main) where import Control.Exception (mask_) import Control.Monad (when, forM, guard) import Data.Bits (xor, shiftR, (.&.)) 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, chr, 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, toGregorian, fromGregorianValid) import Data.Word import Graphics.Color.Space import Graphics.Color.Space.OKLAB.LCH 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 (mcurpage, mpagehighlight) <- if | Just (readMaybe . BS8.unpack -> Just pg) <- query req "page" -> return (Just (min npages (max 1 pg)), Nothing) | Just (TE.decodeASCII' -> Just eventID) <- query req "eid" -> do mevidx <- findEventIDLinear index chan eventID case mevidx of Just (_, evidx, _) -> return (Just (evidx `div` numPerPage + 1), Just (evidx `mod` numPerPage)) Nothing -> return (Nothing, Nothing) | otherwise -> return (Just npages, Nothing) case mcurpage of Nothing -> page404 "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 $ 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 ,"nickcolor" ~> nickColor nick ,"message" ~> msg] | ((time, eid, ev), dayidx) <- zip events [0..] , let (classlist, (nickw1, nick, nickw2), msg) = renderEvent ev]] where numPerPage = 100 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 -> Request -> Text -> Text -> IO Response pageCalendarDay conf pages index req 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 mpagehighlight <- if | Just (TE.decodeASCII' -> Just eventID) <- query req "eid" -> do mevidx <- findEventIDLinear index chan eventID case mevidx of Just (YMDHMS ymd _, _, evdayidx) | ymd == ymdFromGregorian (toGregorian day) -> return (Just evdayidx) _ -> return Nothing | otherwise -> return Nothing return $ sendPage200 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 ,"nick" ~> nick ,"nickwrap2" ~> nickw2 ,"nickcolor" ~> nickColor nick ,"message" ~> 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 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 classListAdd :: Maybe Text -> Text -> Text classListAdd Nothing t = t classListAdd (Just l) t = l <> " " <> t query :: Request -> ByteString -> Maybe ByteString query req key = case lookup key (queryString req) of Nothing -> Nothing Just Nothing -> Nothing -- given but empty; treat as not given Just (Just value) -> Just value -- 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 -- | Returns a CSS color string, including the @#@ nickColor :: Text -> Text nickColor nick = let -- mix (just some random odd constants) n1 = T.foldl' (\n c -> 0x678731a3 * (fromIntegral (ord c) `xor` n) + 0xbc3c0a93) 0xbb115003 nick :: Word32 -- scramble (two steps from splitmix32) n2 = let z1 = (n1 `xor` (n1 `shiftR` 16)) * 0x85ebca6b in (z1 `xor` (z1 `shiftR` 13)) * 0xc2b2ae35 in T.pack $ "hsl(" ++ show (floor @Double @Int (fromIntegral n2 / 2**32 * 360)) ++ " 60% 70%)" -- -- construct the OKLCH color -- clr1 = ColorOKLCH @Double 0.8256 0.0859 (fromIntegral n2 / 2**32 * 360) -- -- convert to sRGB -- ColorRGB r g b = convertColor @(SRGB NonLinear) clr1 -- -- render as css color -- toHex val = let byte = floor (max 0 (min 1 val) * 255.99) -- toHexDig v | v < 10 = chr (ord '0' + v) -- | otherwise = chr (ord 'a' + v - 10) -- in [toHexDig (byte `shiftR` 4), toHexDig (byte .&. 15)] -- in T.pack $ '#' : toHex r ++ toHex g ++ toHex b 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 req 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)"