diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/EscapeXML.hs | 37 | ||||
| -rw-r--r-- | src/Index.hs | 1 | ||||
| -rw-r--r-- | src/Main.hs | 156 | ||||
| -rw-r--r-- | src/Pages.hs | 71 | ||||
| -rw-r--r-- | src/Pages/TH.hs | 218 |
5 files changed, 388 insertions, 95 deletions
diff --git a/src/EscapeXML.hs b/src/EscapeXML.hs deleted file mode 100644 index 662d2ed..0000000 --- a/src/EscapeXML.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# 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/Index.hs b/src/Index.hs index 5ac59be..3e40cac 100644 --- a/src/Index.hs +++ b/src/Index.hs @@ -35,7 +35,6 @@ import Data.Text (Text) import Data.Time import Data.Vector.Storable qualified as VS import Data.Word -import Numeric (showIntAtBase) import System.Clock qualified as Clock import System.Directory import System.FilePath diff --git a/src/Main.hs b/src/Main.hs index 5c73fce..433f6c6 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE LinearTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -41,6 +42,7 @@ import Calendar import Config import EscapeXML import Index +import Pages import Util import ZNC import System.Directory (listDirectory) @@ -74,8 +76,8 @@ pageIndex conf pages = [(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 = +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 @@ -96,36 +98,73 @@ pageLog conf pages index req alias = 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" ~> 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 - ,"nickE" ~> escapeXML nick - ,"nickwrap2" ~> nickw2 - ,"messageE" ~> escapeXML msg] - | ((time, eid, ev), dayidx) <- zip events [0..] - , let (classlist, (nickw1, nick, nickw2), msg) = renderEvent ev]] + 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 @@ -243,8 +282,8 @@ renderSimple topnodes topvalue = runBufferBS (\b -> foldlIntoBuffer (go [topvalu -- _ -> case consumeBuffer buf of -- () -> error $ "renderCalendarDayPage: unexpected node in implicit section: " ++ show node -pageCalendarDay :: Config -> Pages -> Index -> Request -> Text -> Text -> IO Response -pageCalendarDay conf pages index req alias datestr = +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" @@ -260,31 +299,34 @@ pageCalendarDay conf pages index req alias datestr = _ -> 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) - - -- -- return $ sendPage200 pages "calendar-day" $! forceValue $ M.object - -- return $ sendPage200 pages "calendar-day" $ M.object - return $ responseBS status200 [("Content-Type", "text/html")] $ renderSimple (toSimple (getPage pages "calendar-day")) $ M.object - ["network" ~> chanNetwork chan - ,"channel" ~> chanChannel chan - ,"alias" ~> alias - ,"date" ~> ymdToString (dayToYMD day) - ,"events" ~> [M.object - ["classlist" ~> if mpagehighlight == Just dayidx - then Just (classlist `classListAdd` "highlight") - else classlist - ,"time" ~> let HMS h mi s = time - in pad '0' 2 h ++ ':' : pad '0' 2 mi ++ ':' : pad '0' 2 s - ,"linkid" ~> eid - ,"nickwrap1" ~> nickw1 - ,"nickE" ~> escapeXML nick - ,"nickwrap2" ~> nickw2 - ,"messageE" ~> escapeXML 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 @@ -386,11 +428,11 @@ mainServe confpath = do [] -> pageIndex config pages ["log", TE.decodeUtf8' -> Right alias] -> - pageLog config pages index req alias + pageLog config index req alias ["cal", TE.decodeUtf8' -> Right alias] -> pageCalendar config pages index alias ["cal", TE.decodeUtf8' -> Right alias, TE.decodeUtf8' -> Right date] -> - pageCalendarDay config pages index req alias date + pageCalendarDay config index req alias date [fname] | fname `elem` staticFiles -> return $ responseFile status200 [] ("pages/" ++ BS8.unpack fname) _ -> diff --git a/src/Pages.hs b/src/Pages.hs new file mode 100644 index 0000000..4efd8fe --- /dev/null +++ b/src/Pages.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +module Pages ( + renderPageLog, LogData(..), + renderPageCalendarDay, CalendarDayData(..), + PickerData(..), EventData(..), +) where + +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import Data.Text.IO qualified as T +import Language.Haskell.TH.Syntax (addDependentFile) +import System.Directory (makeAbsolute) +import Text.Mustache.Compile qualified as M + +import Pages.TH + + +data LogData = LogData + { network :: Text + , channel :: Text + , alias :: Text + , totalevents :: Text + , picker :: PickerData + , events :: [EventData () Text] + } + +data CalendarDayData = CalendarDayData + { network :: Text + , channel :: Text + , alias :: Text + , date :: Text + , events :: [EventData Text ()] + } + +data PickerData = PickerData + { prevpage :: Maybe Int + , nextpage :: Maybe Int + , firstpage :: Bool + , leftdots :: Bool + , rightdots :: Bool + , lastpage :: Bool + , leftnums :: [Int] + , curnum :: Int + , rightnums :: [Int] + , npages :: Int + } + +data EventData tm dttm = EventData + { classlist :: Maybe Text + , time :: tm + , datetime :: dttm + , linkid :: Text + , nickwrap1 :: Maybe Text + , nick :: Text + , nickwrap2 :: Maybe Text + , message :: Text + } + +$(do let readTemplate name = do + path <- liftIO $ makeAbsolute ("pages/" ++ name ++ ".mustache") + tplSrc <- liftIO $ T.readFile path + addDependentFile path + case M.compileTemplate name tplSrc of + Right tpl -> return tpl + Left err -> fail $ "Reading " ++ path ++ ": " ++ show err + concat <$> mapM (\(name, ty) -> (`makeRender` ty) =<< readTemplate name) + [("log", ''LogData) + ,("calendar-day", ''CalendarDayData)]) diff --git a/src/Pages/TH.hs b/src/Pages/TH.hs new file mode 100644 index 0000000..0cc93db --- /dev/null +++ b/src/Pages/TH.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +module Pages.TH where + +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.Char (toUpper) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.List.NonEmpty qualified as NE +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.Builder.Linear.Buffer +import Language.Haskell.TH +import Text.Mustache qualified as M +import Text.Mustache.Types qualified as M + +import EscapeXML + + +data DataMap + = VQInt + | VQBool + | VQText + | VQUnit -- () + | VQList DataMap -- ^ embedded map is of a list element + | VQMaybe DataMap + | VQObject [(Text, (Exp -> Exp, DataMap))] -- ^ field name, projection function, submap + + +makeDataMap :: Name -> Q DataMap +makeDataMap name = makeDataMapTy (ConT name) + +makeDataMapTy :: Type -> Q DataMap +makeDataMapTy (ConT tyname) + | tyname == ''Int = return VQInt + | tyname == ''Bool = return VQBool + | tyname == ''Text = return VQText +makeDataMapTy (TupleT 0) = return VQUnit +makeDataMapTy (AppT ListT ty) = VQList <$> makeDataMapTy ty +makeDataMapTy (AppT (ConT name) ty) | name == ''Maybe = VQMaybe <$> makeDataMapTy ty + +makeDataMapTy topty = do + case splitApps topty [] of + (ConT tyname, tyargs) -> + reify tyname >>= \case + TyConI (DataD [] _ tyvars _ [RecC conname fields] _) -> + let n = length fields + in VQObject <$> sequence + [do dm <- makeDataMapTy (subst (Map.fromList (zip (map tyvarName tyvars) tyargs)) fieldty) + f <- projectField conname i n + return (T.pack (nameBase name), (f, dm)) + | ((name, _bang, fieldty), i) <- zip fields [0..]] + _ -> fail $ "Not a suitable data type: " ++ show tyname + _ -> fail $ "Not a straightforward type: " ++ show topty + where + projectField :: Name -> Int -> Int -> Q (Exp -> Exp) + projectField conname i n = do + varname <- newName ('x' : show (i + 1)) + let pats = replicate i WildP ++ [VarP varname] ++ replicate (n-i-1) WildP + return $ \e -> + CaseE e [Match (ConP conname [] pats) (NormalB (VarE varname)) []] + + splitApps :: Type -> [Type] -> (Type, [Type]) + splitApps (AppT t1 t2) args = splitApps t1 (t2 : args) + splitApps t args = (t, args) + + tyvarName :: TyVarBndr flag -> Name + tyvarName (PlainTV n _) = n + tyvarName (KindedTV n _ _) = n + + subst :: Map Name Type -> Type -> Type + subst _ t@ConT{} = t + subst _ t@ListT = t + subst _ t@TupleT{} = t + subst mp (VarT n) | Just t <- Map.lookup n mp = t + subst mp (AppT t1 t2) = AppT (subst mp t1) (subst mp t2) + subst _ t = error $ "Unsupported type: " ++ show t + +makeRender :: M.Template -> Name -> Q [Dec] +makeRender (M.Template tplname nodes _) dataname = do + dm <- makeDataMap dataname + let funname = mkName ("renderPage" ++ toPascalCase tplname) + argname <- newName "dat" + bufname <- newName "buf" + body <- renderNodes ((dm, VarE argname) :| []) (DuplicableExp (VarE bufname)) nodes + let body' = VarE 'runBufferBS `AppE` LamE [VarP bufname] body + return + [SigD funname (ArrowT `AppT` ConT dataname `AppT` ConT ''ByteString) + ,FunD funname + [Clause [BangP (VarP argname)] (NormalB body') []]] + +data ExpensiveExp + = ExpensiveExp Exp + | DuplicableExp Exp + +expensive :: ExpensiveExp -> Exp +expensive (ExpensiveExp e) = e +expensive (DuplicableExp e) = e + +makeDuplicable :: ExpensiveExp -> (Exp -> Q Exp) -> Q Exp +makeDuplicable (ExpensiveExp e) k = do + varname <- newName "a" + caseE (pure e) + [match (varP varname) (normalB (k (VarE varname))) []] +makeDuplicable (DuplicableExp e) k = k e + +-- | This is just '(|>)', but with a @NOINLINE@ pragma. This is because GHC +-- eagerly inlines '(|>)', and that function contains some conditionals, and as +-- a result the generated Core for the render function contains a whole forest +-- of join points. By avoiding inlining this function, the Core becomes a +-- straight line of @case@s that contains join points only when there is +-- genuinely control flow going on, i.e. when substituting a @Maybe@ or when +-- looping over a list. +{-# NOINLINE noinlineAppText #-} +noinlineAppText :: Buffer %1-> Text -> Buffer +noinlineAppText = (|>) + +-- | All input expressions must be duplicable. +renderNodes :: NonEmpty (DataMap, Exp) -> ExpensiveExp -> [M.Node Text] -> Q (Exp {- Buffer -}) +renderNodes _ buf [] = return (expensive buf) +renderNodes dats buf (node : nodes) = do + let app buf' name e = InfixE (Just buf') (VarE name) (Just e) + + buf' <- case node of + M.TextBlock t -> + let bytes = BS.unpack (TE.encodeUtf8 t) + in return $ app (expensive buf) '(|>#) (LitE (StringPrimL bytes)) + M.Variable esc named -> + case search named dats of + Just (VQInt, e) -> return $ app (expensive buf) '(|>$) e + Just (VQText, e) -> + return $ app (expensive buf) 'noinlineAppText (if esc then VarE 'escapeXML `AppE` e else e) + Just (_, _) -> fail $ "Strange value in variable reference " ++ show named + Nothing -> fail $ "Variable not found: " ++ show named + M.Section named nodes' -> + case search named dats of + Just (VQBool, e) -> + makeDuplicable buf $ \buf' -> + condE (pure e) + (renderNodes ((VQBool, e) NE.<| dats) (DuplicableExp buf') nodes') + (pure buf') + Just (VQText, e) -> + makeDuplicable buf $ \buf' -> + condE [| T.null $(pure e) |] + (pure buf') + (renderNodes ((VQText, e) NE.<| dats) (DuplicableExp buf') nodes') + Just (VQList dm, e) -> do + bvar <- newName "b" + vvar <- newName "v" + varE 'foldlIntoBuffer + `appE` lamE [varP bvar, varP vvar] + (renderNodes ((dm, VarE vvar) NE.<| dats) (DuplicableExp (VarE bvar)) nodes') + `appE` pure (expensive buf) + `appE` pure e + Just (VQMaybe dm, e) -> do + xvar <- newName "x" + makeDuplicable buf $ \buf' -> + caseE (pure e) + [match (conP 'Nothing []) (normalB (pure buf')) [] + ,match (conP 'Just [varP xvar]) + (normalB (renderNodes ((dm, VarE xvar) NE.<| dats) (DuplicableExp buf') nodes')) + []] + Just pair@(VQObject _, _) -> do + renderNodes (pair NE.<| dats) buf nodes' + Just (VQInt, _) -> fail $ "Int value in section scrutinee " ++ show named + Just (VQUnit, _) -> fail $ "() value in section scrutinee " ++ show named + Nothing -> fail $ "Section scrutinee not found: " ++ show named + M.InvertedSection named nodes' -> + case search named dats of + Just (VQBool, e) -> + makeDuplicable buf $ \buf' -> + condE (pure e) + (pure buf') + (renderNodes dats (DuplicableExp buf') nodes') + Just (VQText, e) -> + makeDuplicable buf $ \buf' -> + condE [| T.null $(pure e) |] + (renderNodes dats (DuplicableExp buf') nodes') + (pure buf') + Just (VQMaybe _, e) -> + makeDuplicable buf $ \buf' -> + caseE (pure e) + [match (conP 'Nothing []) (normalB (renderNodes dats (DuplicableExp buf') nodes')) [] + ,match (conP 'Just [wildP]) (normalB (pure buf')) []] + Just (VQList _, e) -> + makeDuplicable buf $ \buf' -> + caseE (pure e) + [match (listP []) (normalB (renderNodes dats (DuplicableExp buf') nodes')) [] + ,match wildP (normalB (pure buf')) []] + Just (VQObject _, _) -> fail $ "Object value in inverted section scrutinee " ++ show named + Just (VQInt, _) -> fail $ "Int value in inverted section scrutinee " ++ show named + Just (VQUnit, _) -> fail $ "() value in inverted section scrutinee " ++ show named + Nothing -> fail $ "Inverted section scrutinee not found: " ++ show named + M.Partial _ _ -> fail $ "TODO partials" + + renderNodes dats (ExpensiveExp buf') nodes + +search :: M.DataIdentifier -> NonEmpty (DataMap, Exp) -> Maybe (DataMap, Exp) +search M.Implicit (value :| _) = Just value +search (M.NamedData []) (value :| _) = Just value +search (M.NamedData (key : keys)) ((dm, e) :| dats) = + case dm of + VQObject fields -> + case lookup key fields of + Just (proj, dm') -> search (M.NamedData keys) ((dm', proj e) :| []) + Nothing -> search (M.NamedData (key : keys)) =<< NE.nonEmpty dats + _ -> + search (M.NamedData (key : keys)) =<< NE.nonEmpty dats + +toPascalCase :: String -> String +toPascalCase "" = "" +toPascalCase (c:cs) = toUpper c : go cs + where go ('-':cs') = toPascalCase cs' + go (c':cs') = c' : go cs' + go "" = "" |