Initial

1 files changed, 188 insertions, 0 deletions

diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
index 0000000..75b9a96
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,188 @@
+{-# 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)"