path: root/src/Main.hs

{-# 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),  "<parse error>")
  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)"