{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Main (main) where

import Control.Exception (mask_)
import Control.Monad (when)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as BS8
import Data.ByteString.Lazy.Char8 qualified as BSL8
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 qualified as T
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 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"
    Just chan -> do
      let npages = (indexNumEvents index chan + 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" ~> indexNumEvents index chan
        ,"picker" ~> M.object
          ["prevpage" ~> if curpage > 1 then Just (curpage - 1) else Nothing
          ,"leftnums" ~> [curpage - ntoleft .. curpage - 1]
          ,"curnum" ~> curpage
          ,"rightnums" ~> [curpage + 1 .. curpage + ntoright]
          ,"nextpage" ~> if curpage < npages then Just (curpage + 1) else Nothing
          ,"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

    renderEvent :: Event -> (Maybe Text, (Maybe Text, Text, Maybe Text), Text)
    renderEvent = \case
      Join n addr      -> (j "ev-meta",   (no, n, j " →"),   "Joins (" <> addr <> ")")
      Part n addr reas -> (j "ev-meta",   (no, n, j " ←"),   "Parts (" <> addr <> ") (" <> reas <> ")")
      Quit n addr reas -> (j "ev-meta",   (no, n, j " ×"),   "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

page404 :: String -> IO Response
page404 thing = return $ responseLBS
  status404
  [("Content-Type", "text/plain")]
  (BSL8.pack thing <> " not found")

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)

  pages <- Pages . Map.fromList <$> sequence
    [do src <- T.readFile ("pages/" ++ name ++ ".mustache")
        case compileTemplate name src of
          Right tpl -> return (name, tpl)
          Left err -> die (show err)
    | name <- ["index", "log"]]

  let staticFiles = ["style.css"]

  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))
        print (connectionLimit, count)
        when (count <= connectionLimit) $
          settingsFork defaultSettings k
        atomicModifyIORef' counter (\i -> (i - 1, ()))
      settings = defaultSettings & setFork checkedFork
                                 & setPort (confPort config)

  putStrLn $ "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
    [fname] | fname `elem` staticFiles ->
      respond $ responseFile status200 [] ("pages/" ++ T.unpack fname) Nothing
    _ ->
      respond =<< page404 "URL"

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)"