path: root/src/Main.hs

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

import Control.Monad (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.List.NonEmpty (NonEmpty((:|)), groupBy)
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.Time (Day, toGregorian, fromGregorianValid)
import System.Directory (listDirectory)
import System.Environment
import System.Exit (die)
import System.FilePath ((</>))
import Text.Read (readMaybe)

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

import Calendar
import Config
import Index
import Pages
import Util
import ZNC


sendHtml200 :: ByteString -> IO Response
sendHtml200 = return . responseBS status200 [("Content-Type", "text/html")]

sendText404 :: BSL.ByteString -> IO Response
sendText404 message = return $ responseLBS
  status404
  [("Content-Type", "text/plain")]
  message

pageIndex :: Config -> IO Response
pageIndex conf =
  sendHtml200 $
    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 -> sendText404 "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 -> sendText404 "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
          sendHtml200 $
            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]
              }
  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 -> Index -> Request -> Text -> Text -> IO Response
pageCalendarDay conf index req alias datestr =
  case (econfAlias2Chan conf Map.!? alias, parseDatestr datestr) of
    (Nothing, _) -> sendText404 "Channel not found"
    (_, Nothing) -> sendText404 "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

      sendHtml200 $
        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] }
  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 -> sendText404 "Channel not found"
    Just chan -> do
      ((startDay, endDay), counts) <- indexCalendar index chan
      sendHtml200 $
        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"]

prefilter :: Request -> Maybe Response
prefilter req
  -- Facebook should stop crawling all the individual ?eid=... URLs
  | case lookup "user-agent" (reqHeaders req) of
      Just ua | BS.take 18 ua == "meta-externalagent" -> True
      _ -> False
  , any ((== "eid") . fst) (reqQuery req)
  = Just $ responseBS (Status 303 "See Other")
                      [("Location", BS.takeWhile (/= fromIntegral (ord '?')) (reqURI req))]
                      BS.empty

  | otherwise
  = Nothing

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 prefilter req of
      Just res -> return res
      Nothing -> 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)
        _ ->
          sendText404 "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)"