path: root/src/Main.hs

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

import Control.Applicative ((<|>))
import Control.Monad (forM, guard, forM_)
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.HashMap.Strict qualified as HM
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.Builder.Linear.Buffer
import Data.Text.Encoding qualified as TE
import Data.Text.IO.Utf8 qualified as T
import Data.Time (Day, toGregorian, fromGregorianValid)
import System.Environment
import System.Exit (die)
import System.FilePath ((</>))
import Text.Mustache (Template, compileTemplate, substituteValue, (~>))
import Text.Mustache qualified as M
import Text.Mustache.Types (Value(..))
import Text.Mustache.Types qualified as M
import Text.Read (readMaybe)

import Network.HTTP.Server.Mini
import Network.HTTP.Server.Mini.Internal.Instrument (atomicPrintS)

-- import Debug.Trace

import Calendar
import Config
import EscapeXML
import Index
import Pages
import Util
import ZNC
import System.Directory (listDirectory)


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 -> IO Response
pageIndex conf =
  return $ responseBS
    status200
    [("Content-Type", "text/html")]
    (renderPageIndex IndexData
      { networks =
          [IndexNetworkData
            { name = nw
            , channels =
                [IndexChannelData
                  { 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 -> Index -> Request -> Text -> IO Response
pageLog conf 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 $ responseBS
            status200
            [("Content-Type", "text/html")]
            (renderPageLog LogData
              { network = chanNetwork chan
              , channel = chanChannel chan
              , alias = alias
              , totalevents = renderLargeNumber numEvents
              , picker = PickerData
                  { 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 =
                  [EventData
                     { classlist = if mpagehighlight == Just dayidx
                                     then Just (classlist `classListAdd` "highlight")
                                     else classlist
                     , time = ()
                     , datetime = let YMDHMS (YMD y mo d) (HMS h mi s) = time
                                  in T.pack
                                       (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
                     , message = msg }
                  | ((time, eid, ev), dayidx) <- zip events [0..]
                  , let (classlist, (nickw1, nick, nickw2), msg) = renderEvent ev]
              })
          -- 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
          --                  ,"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))

-- rnfValue :: Value -> ()
-- rnfValue (Object o) = foldMap rnfValue o
-- rnfValue (Array a) = foldMap rnfValue a
-- rnfValue (Number !_) = ()
-- rnfValue (String !_) = ()
-- rnfValue Lambda{} = error "Lambda"
-- rnfValue (Bool !_) = ()
-- rnfValue Null = ()

-- {-# NOINLINE forceValue #-}
-- forceValue :: Value -> Value
-- forceValue v = rnfValue v `seq` v

data SimpleNode
  = STextBlock !Text
  | SSection !Text ![SimpleNode]
  | SVariable {-# UNPACK #-} !Bool !Text
  deriving (Show)

toSimple :: Template -> [SimpleNode]
toSimple (M.Template _ nodes _) = map (go Nothing) nodes
  where
    go :: Maybe Text -> M.Node Text -> SimpleNode
    go _ (M.TextBlock t) = STextBlock t
    go _ (M.Variable esc (M.NamedData [name])) = SVariable esc name
    go (Just ctx) (M.Variable esc M.Implicit) = SVariable esc ctx
    go Nothing (M.Variable _ M.Implicit) = error "toSimple: {{.}} outside section"
    go _ (M.Section (M.NamedData [name]) ns) = SSection name (map (go (Just name)) ns)
    go _ node = error $ "toSimple: unsupported node: " ++ show node

renderSimple :: [SimpleNode] -> Value -> ByteString
renderSimple topnodes topvalue = runBufferBS (\b -> foldlIntoBuffer (go [topvalue]) b topnodes)
  where
    go :: [Value] -> Buffer %1 -> SimpleNode -> Buffer
    go values buf node = case node of
      STextBlock t -> buf |> t
      SSection name nodes -> case searchName name values of
        Just (M.Bool False) -> buf
        Just (M.Array vec) ->
          foldlIntoBuffer (\b v -> foldlIntoBuffer (go (v : values)) b nodes) buf (toList vec)
        Just value -> foldlIntoBuffer (go (value : values)) buf nodes
        Nothing -> case consumeBuffer buf of () -> error $ "renderSimple: name " ++ show name ++ " not found"
      SVariable esc name -> case searchName name values of
        Just (M.String t)
          | esc -> buf |> escapeXML t
          | otherwise -> buf |> t
        Just M.Null -> buf
        Just value -> case consumeBuffer buf of () -> error $ "renderSimple: unsupported value type " ++ show value
        Nothing -> case consumeBuffer buf of () -> error $ "renderSimple: name " ++ show name ++ " not found"

    searchName :: Text -> [Value] -> Maybe Value
    searchName n (M.Object obj : vs) = HM.lookup n obj <|> searchName n vs
    searchName _ [] = Nothing
    searchName n (_ : vs) = searchName n vs

-- renderCalendarDayPage :: Template -> Channel -> Day -> Text -> Maybe Int -> [(HMS, EventID, Event)] -> ByteString
-- renderCalendarDayPage (M.Template _ nodes _) chan day alias mpagehighlight events =
--   runBufferBS (\b -> foldlIntoBuffer goTop b nodes)
--   where
--     date = T.pack (ymdToString (dayToYMD day))

--     goTop :: Buffer %1-> M.Node Text -> Buffer
--     goTop buf node = case node of
--       M.TextBlock t -> buf |> t
--       M.Variable _ (M.NamedData ["channel"]) -> buf |> chanChannel chan
--       M.Variable _ (M.NamedData ["network"]) -> buf |> chanNetwork chan
--       M.Variable _ (M.NamedData ["date"]) -> buf |> date
--       M.Variable _ (M.NamedData ["alias"]) -> buf |> alias
--       M.Section (M.NamedData ["events"]) ns ->
--         foldlIntoBuffer
--           (\b ((time, eid, event), dayidx) ->
--             let tup = renderEvent event
--             in foldlIntoBuffer (\b' n -> goEv b' time eid dayidx tup n) b ns)
--           buf (zip events [0..])
--       _ -> case consumeBuffer buf of
--              () -> error $ "renderCalendarDayPage: unexpected top node " ++ show node

--     goEv :: Buffer %1-> HMS -> EventID -> Int -> (Maybe Text, (Maybe Text, Text, Maybe Text), Text) -> M.Node Text -> Buffer
--     goEv buf time eid dayidx (classlist, (nickw1, nick, nickw2), msg) node = case node of
--       M.TextBlock t -> buf |> t
--       M.Variable _ (M.NamedData ["alias"]) -> buf |> alias
--       M.Variable _ (M.NamedData ["date"]) -> buf |> date
--       M.Variable _ (M.NamedData ["linkid"]) -> buf |> eid
--       M.Variable _ (M.NamedData ["time"]) ->
--         buf |> T.pack (let HMS h mi s = time
--                        in pad '0' 2 h ++ ':' : pad '0' 2 mi ++ ':' : pad '0' 2 s)
--       M.Variable _ (M.NamedData ["nickE"]) -> buf |> escapeXML nick
--       M.Variable _ (M.NamedData ["messageE"]) -> buf |> escapeXML msg
--       M.Section (M.NamedData ["classlist"]) ns ->
--         let classlist' | mpagehighlight == Just dayidx = Just (classlist `classListAdd` "highlight")
--                        | otherwise = classlist
--         in goMaybe buf goImplicit classlist' ns
--       M.Section (M.NamedData ["nickwrap1"]) ns -> goMaybe buf goImplicit nickw1 ns
--       M.Section (M.NamedData ["nickwrap2"]) ns -> goMaybe buf goImplicit nickw2 ns
--       _ -> case consumeBuffer buf of
--              () -> error $ "renderCalendarDayPage: unexpected node in event section: " ++ show node

--     goMaybe :: Buffer %1-> (Buffer %1-> a -> M.Node Text -> Buffer) -> Maybe a -> [M.Node Text] -> Buffer
--     goMaybe buf _ Nothing _ = buf
--     goMaybe buf f (Just x) ns = foldlIntoBuffer (\b n -> f b x n) buf ns

--     goImplicit :: Buffer %1-> Text -> M.Node Text -> Buffer
--     goImplicit buf cl node = case node of
--       M.TextBlock t -> buf |> t
--       M.Variable False M.Implicit -> buf |> cl
--       _ -> case consumeBuffer buf of
--              () -> error $ "renderCalendarDayPage: unexpected node in implicit section: " ++ show node

pageCalendarDay :: Config -> Index -> Request -> Text -> Text -> IO Response
pageCalendarDay conf 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 $ responseBS
        status200
        [("Content-Type", "text/html")]
        (renderPageCalendarDay CalendarDayData
          { network = chanNetwork chan
          , channel = chanChannel chan
          , alias = alias
          , date = T.pack (ymdToString (dayToYMD day))
          , events =
              [EventData
                { classlist = if mpagehighlight == Just dayidx
                                then Just (classlist `classListAdd` "highlight")
                                else classlist
                , time = let HMS h mi s = time
                         in T.pack (pad '0' 2 h ++ ':' : pad '0' 2 mi ++ ':' : pad '0' 2 s)
                , datetime = ()
                , linkid = eid
                , nickwrap1 = nickw1
                , nick = nick
                , nickwrap2 = nickw2
                , message = msg }
              | ((time, eid, ev), dayidx) <- zip events [0..]
              , let (classlist, (nickw1, nick, nickw2), msg) = renderEvent ev] })

      -- return $ responseBS
      --   status200
      --   [("Content-Type", "text/html")]
      --   (renderCalendarDayPage (getPage pages "calendar-day") chan day alias mpagehighlight events)
  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 = lookup key (reqQuery req)

-- 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 "&lt;", n, j "&gt;"), 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 -> Index -> Text -> IO Response
pageCalendar conf index alias =
  case econfAlias2Chan conf Map.!? alias of
    Nothing -> page404 "Channel not found"
    Just chan -> do
      ((startDay, endDay), counts) <- indexCalendar index chan
      return $ responseBS
        status200
        [("Content-Type", "text/html")]
        (renderPageCalendar CalendarData
          { network = chanNetwork chan
          , channel = chanChannel chan
          , alias = alias
          , years = flip map (reverse (calendarLayout startDay endDay counts)) $ \(year, monrows) ->
              CalendarYearData
                { year = fromIntegral @Integer @Int year
                , monrows = flip map monrows $ \monrow ->
                    CalendarMonthRowData
                      { months = flip map monrow $ \case
                          Nothing ->
                            CalendarMonthData
                              { display = False
                              , month = 0
                              , month00 = ""
                              , monthname = ""
                              , weeks = []
                              , phantomweek = False }
                          Just (month, weeks) ->
                            CalendarMonthData
                              { display = True
                              , month = month
                              , month00 = T.pack (pad '0' 2 month)
                              , monthname = monthNames !! (month - 1)
                              , weeks = flip map weeks $ \week ->
                                  CalendarWeekData
                                    { days = flip map week $ \case
                                        Nothing ->
                                          CalendarDayData'
                                            { date = Nothing, date00 = "" }
                                        Just (d, _count) ->
                                          CalendarDayData'
                                            { date = Just d, date00 = T.pack (pad '0' 2 d) }}
                              , phantomweek = False }
                            }}})
  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

mainServe :: FilePath -> IO ()
mainServe confpath = do
  config <- enrichConfig <$> readConfig confpath

  index <- initIndex (confLogsDir config) (econfChannels config)

  let staticFiles = ["style.css", "robots.txt", "favicon.png"]

  let settings = defaultSettings { setPort = confPort config }

  atomicPrintS $ "Listening on port " ++ show (confPort config)
  run settings $ \req -> case reqPath req of
    [] ->
      pageIndex config
    ["log", TE.decodeUtf8' -> Right alias] ->
      pageLog config index req alias
    ["cal", TE.decodeUtf8' -> Right alias] ->
      pageCalendar config index alias
    ["cal", TE.decodeUtf8' -> Right alias, TE.decodeUtf8' -> Right date] ->
      pageCalendarDay config index req alias date
    [fname] | fname `elem` staticFiles ->
      return $ responseFile status200 [] ("pages/" ++ BS8.unpack fname)
    _ ->
      page404 "URL not found"

testParseLog :: FilePath -> IO ()
testParseLog fname = print =<< parseLog <$> BS.readFile fname

testCount :: FilePath -> IO ()
testCount confpath = do
  config <- enrichConfig <$> readConfig confpath
  forM_ (econfChannels config) $ \(Channel nw ch) -> do
  -- forM_ [Channel "liberachat" "#haskell"] $ \(Channel nw ch) -> do
    let dir = confLogsDir config </> T.unpack nw </> T.unpack ch
    files <- listDirectory dir
    forM_ files $ \file -> do
      evs <- parseLog <$> BS.readFile (dir </> file)
      forM_ evs $ \case
        (_, Talk _ _msg) -> return ()
        (_, Notice n msg) -> error (show (n, msg))
        (_, Act _ _msg) -> return ()
        _ -> return ()

main :: IO ()
main = getArgs >>= \case
  ["test", "parselog", fname] -> testParseLog fname
  ["test", "count", fname] -> testCount fname
  ["serve", fname] -> mainServe fname
  _ -> die "Expected command-line argument (see Main.hs)"