Optimisations to log rendering with mustache

6 files changed, 109 insertions, 18 deletions

diff --git a/cbits/escapexml.c b/cbits/escapexml.c
new file mode 100644
index 0000000..6eb366d
--- /dev/null
+++ b/cbits/escapexml.c
@@ -0,0 +1,49 @@
+#include <string.h>
+#include <stdint.h>
+
+// https://hackage-content.haskell.org/package/mustache-2.4.3.1/src/src/Text/Mustache/Internal.hs
+//
+// escapeXML :: String -> String
+// escapeXML = concatMap $ \x -> IntMap.findWithDefault [x] (ord x) mp
+//     where mp = IntMap.fromList [(ord b, "&"++a++";") | (a,[b]) <- xmlEntities]
+//
+// xmlEntities :: [(String, String)]
+// xmlEntities =
+//   [ ("quot", "\"")
+//   , ("#39", "'")
+//   , ("amp" , "&")
+//   , ("lt"  , "<")
+//   , ("gt"  , ">")
+//   ]
+
+#define ENTITIES_XLIST \
+  X('"', 6, "&quot;") \
+  X('\'', 5, "&#39;") \
+  X('&', 5, "&amp;") \
+  X('<', 4, "&lt;") \
+  X('>', 4, "&gt;")
+
+size_t tirclogv_escapexml_len(const uint8_t *src, size_t src_off, size_t src_len) {
+  size_t reslen = 0;
+  for (size_t i = 0; i < src_len; i++) {
+    switch (src[src_off + i]) {
+#define X(ch, len, _str) case ch: reslen += len; break;
+      ENTITIES_XLIST
+#undef X
+      default: reslen += 1; break;
+    }
+  }
+  return reslen;
+}
+
+void tirclogv_escapexml(uint8_t *dst, const uint8_t *src, size_t src_off, size_t src_len) {
+  for (size_t i = 0, j = 0; i < src_len; i++) {
+    const uint8_t c = src[src_off + i];
+    switch (c) {
+#define X(ch, len, str) case ch: memcpy(&dst[j], str, len); j += len; break;
+      ENTITIES_XLIST
+#undef X
+      default: dst[j++] = c; break;
+    }
+  }
+}
diff --git a/pages/calendar-day.mustache b/pages/calendar-day.mustache
index f72f42a..3483d59 100644
--- a/pages/calendar-day.mustache
+++ b/pages/calendar-day.mustache
@@ -12,17 +12,17 @@
     <header>
       <a href="/" class="hdritem">Home</a>
       {{network}}/{{channel}}:
-      <a href="/log/{{alias}}" class="hdritem">Logs</a>
-      <a href="/cal/{{alias}}" class="hdritem">Calendar</a>
+      <a href="/log/{{&alias}}" class="hdritem">Logs</a>
+      <a href="/cal/{{&alias}}" class="hdritem">Calendar</a>
     </header>
     <main>
       <h1>Logs on {{date}} ({{network}}/{{channel}})</h1>
       <table id="events"><tbody>
         {{#events}}
-          <tr{{#classlist}} class="{{.}}"{{/classlist}}>
-            <td><a href="/cal/{{alias}}/{{date}}?eid={{linkid}}#ev-{{linkid}}" name="ev-{{linkid}}">{{time}}</a></td>
-            <td>{{#nickwrap1}}<span class="nickwrap">{{nickwrap1}}</span>{{/nickwrap1}}{{nick}}{{#nickwrap2}}<span class="nickwrap">{{nickwrap2}}</span>{{/nickwrap2}}</td>
-            <td>{{message}}</td>
+          <tr{{#classlist}} class="{{&.}}"{{/classlist}}>
+            <td><a href="/cal/{{&alias}}/{{&date}}?eid={{&linkid}}#ev-{{&linkid}}" name="ev-{{&linkid}}">{{&time}}</a></td>
+            <td>{{#nickwrap1}}<span class="nickwrap">{{&nickwrap1}}</span>{{/nickwrap1}}{{&nickE}}{{#nickwrap2}}<span class="nickwrap">{{&nickwrap2}}</span>{{/nickwrap2}}</td>
+            <td>{{&messageE}}</td>
           </tr>
         {{/events}}
       </tbody></table>
diff --git a/pages/log.mustache b/pages/log.mustache
index fc01310..c07eb20 100644
--- a/pages/log.mustache
+++ b/pages/log.mustache
@@ -12,8 +12,8 @@
     <header>
       <a href="/" class="hdritem">Home</a>
       {{network}}/{{channel}}:
-      <a href="/log/{{alias}}" class="hdritem">Logs</a>
-      <a href="/cal/{{alias}}" class="hdritem">Calendar</a>
+      <a href="/log/{{&alias}}" class="hdritem">Logs</a>
+      <a href="/cal/{{&alias}}" class="hdritem">Calendar</a>
     </header>
     <main>
       <h1>Logs: {{network}}/{{channel}}</h1>
@@ -49,10 +49,10 @@
       </div>
       <table id="events"><tbody>
         {{#events}}
-          <tr{{#classlist}} class="{{.}}"{{/classlist}}>
-            <td><a href="/log/{{alias}}?eid={{linkid}}#ev-{{linkid}}" name="ev-{{linkid}}">{{datetime}}</a></td>
-            <td>{{#nickwrap1}}<span class="nickwrap">{{nickwrap1}}</span>{{/nickwrap1}}{{nick}}{{#nickwrap2}}<span class="nickwrap">{{nickwrap2}}</span>{{/nickwrap2}}</td>
-            <td>{{message}}</td>
+          <tr{{#classlist}} class="{{&.}}"{{/classlist}}>
+            <td><a href="/log/{{&alias}}?eid={{&linkid}}#ev-{{&linkid}}" name="ev-{{&linkid}}">{{&datetime}}</a></td>
+            <td>{{#nickwrap1}}<span class="nickwrap">{{&nickwrap1}}</span>{{/nickwrap1}}{{&nickE}}{{#nickwrap2}}<span class="nickwrap">{{&nickwrap2}}</span>{{/nickwrap2}}</td>
+            <td>{{&messageE}}</td>
           </tr>
         {{/events}}
       </tbody></table>
diff --git a/src/EscapeXML.hs b/src/EscapeXML.hs
new file mode 100644
index 0000000..662d2ed
--- /dev/null
+++ b/src/EscapeXML.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+module EscapeXML (escapeXML) where
+
+import Data.Array.Byte
+import Data.Text.Internal
+import Foreign.C.Types
+import GHC.Exts
+import GHC.IO (IO(IO))
+import System.IO.Unsafe (unsafePerformIO)
+
+
+foreign import ccall unsafe "tirclogv_escapexml_len"
+  c_escapexml_len :: ByteArray# -> CSize -> CSize -> IO CSize
+
+foreign import ccall unsafe "tirclogv_escapexml"
+  c_escapexml :: MutableByteArray# RealWorld -> ByteArray# -> CSize -> CSize -> IO ()
+
+{-# NOINLINE escapeXML #-}
+escapeXML :: Text -> Text
+escapeXML (Text (ByteArray src#) off len) = unsafePerformIO $ do
+  let offCS = fromIntegral @Int @CSize off
+      lenCS = fromIntegral @Int @CSize len
+
+  reslen <- c_escapexml_len src# offCS lenCS
+  let !reslenI@(I# reslen#) = fromIntegral @CSize @Int reslen
+
+  MutableByteArray dst# <-
+    IO $ \s -> case newByteArray# reslen# s of
+                 (# s', mba# #) -> (# s', MutableByteArray mba# #)
+  c_escapexml dst# src# offCS lenCS
+  ba <- IO $ \s -> case unsafeFreezeByteArray# dst# s of
+                     (# s', ba# #) -> (# s', ByteArray ba# #)
+
+  return (Text ba 0 reslenI)
diff --git a/src/Main.hs b/src/Main.hs
index c49b02d..458ed9f 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ViewPatterns #-}
@@ -33,6 +34,7 @@ import Network.HTTP.Server.Mini.Internal.Instrument (atomicPrintS)
 
 import Calendar
 import Config
+import EscapeXML
 import Index
 import Util
 import ZNC
@@ -114,9 +116,9 @@ pageLog conf pages index req alias =
                                              pad '0' 2 h ++ ':' : pad '0' 2 mi ++ ':' : pad '0' 2 s
                            ,"linkid" ~> eid
                            ,"nickwrap1" ~> nickw1
-                           ,"nick" ~> nick
+                           ,"nickE" ~> escapeXML nick
                            ,"nickwrap2" ~> nickw2
-                           ,"message" ~> msg]
+                           ,"messageE" ~> escapeXML msg]
                          | ((time, eid, ev), dayidx) <- zip events [0..]
                          , let (classlist, (nickw1, nick, nickw2), msg) = renderEvent ev]]
   where
@@ -157,9 +159,9 @@ pageCalendarDay conf pages index req alias datestr =
                                   in pad '0' 2 h ++ ':' : pad '0' 2 mi ++ ':' : pad '0' 2 s
                        ,"linkid" ~> eid
                        ,"nickwrap1" ~> nickw1
-                       ,"nick" ~> nick
+                       ,"nickE" ~> escapeXML nick
                        ,"nickwrap2" ~> nickw2
-                       ,"message" ~> msg]
+                       ,"messageE" ~> escapeXML msg]
                      | ((time, eid, ev), dayidx) <- zip events [0..]
                      , let (classlist, (nickw1, nick, nickw2), msg) = renderEvent ev]]
   where
@@ -191,7 +193,7 @@ renderEvent = \case
   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)
+  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 <> ")")
diff --git a/tirclogv.cabal b/tirclogv.cabal
index ead88fb..f65130a 100644
--- a/tirclogv.cabal
+++ b/tirclogv.cabal
@@ -23,6 +23,7 @@ executable tirclogv
     Calendar
     Config
     Debounce
+    EscapeXML
     ImmutGrowVector
     Index
     Mmap
@@ -46,7 +47,9 @@ executable tirclogv
     unix,
     vector
   hs-source-dirs: src
-  c-sources: cbits/mmap.c
+  c-sources:
+    cbits/mmap.c
+    cbits/escapexml.c
   ghc-options: -Wall -threaded
 
 library mini-http-server