1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
|
{-# 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
,"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
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
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)"
|
