path: root/src/Main.hs

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