From 70de37cee9613aaeceedea91f0ac89cfd83bd8aa Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Fri, 25 Jun 2021 14:43:49 +1200 Subject: [PATCH] Show syntax-highlighted start tags for elements in HTML UI. --- src/Internal.hs | 5 ++++- src/Main.hs | 38 +++++++++++++++++++++++++++----- src/Messages.hs | 2 ++ src/UI/Search.hs | 7 +++--- src/UI/Templates.hs | 53 +++++++++++++++++++++++++++++++++++++++++++-- 5 files changed, 94 insertions(+), 11 deletions(-) diff --git a/src/Internal.hs b/src/Internal.hs index 0397ea6..243db62 100644 --- a/src/Internal.hs +++ b/src/Internal.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveGeneric #-} module Internal(Session(..), Session'(..), Sessions(..), initSessions, createSession, delSession, getSession, withSession, - Timeouts(..), registerEl, serializeEl) where + Timeouts(..), registerEl, serializeEl, getEl) where import qualified Data.HashMap.Strict as M import Data.UUID as ID @@ -100,3 +100,6 @@ serializeEl session el = do return $ M.fromList [ ("element-6066-11e4-a52e-4f735466cecf", String $ pack $ ID.toString uuid) ] + +getEl :: Session' -> UUID -> Maybe XML.Cursor +getEl session uuid = M.lookup uuid $ knownEls session diff --git a/src/Main.hs b/src/Main.hs index 84584d6..120e0b7 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -14,6 +14,9 @@ import qualified Data.Text as Txt import Webdriver import Data.UUID as ID +import qualified Text.XML.Cursor as XC +import qualified Text.XML as XML + import Messages import Happstack.Server.I18N @@ -70,6 +73,8 @@ servePreviewPrompt = do method GET Tpl.page ok ["?", "Amphiarao"] $ \langs -> H.p $ l langs PromptPreview +--- + serveSession :: Sessions -> String -> ServerPart Response serveSession = withSession session404 $ \uuid session -> msum [ sessionHome session, @@ -80,7 +85,8 @@ serveSession = withSession session404 $ \uuid session -> msum [ dir "reload" $ reloadPage uuid session, dir "back" $ sessionAction' uuid session Load.back, dir "next" $ sessionAction' uuid session Load.next - ] + ], + dir "el" $ path $ serveEl uuid session ] sessionHome session = do @@ -88,10 +94,8 @@ sessionHome session = do method GET session' <- liftIO $ readMVar session - title <- liftIO $ El.getTitle session - Tpl.inspector ok "title" session' $ \langs -> do - H.h1 $ text title - H.p $ string $ show $ currentURL session' + Tpl.inspector ok "title" session' $ \langs -> + Tpl.xmlNode $ XML.NodeElement $ XML.documentRoot $ document session' session404 uuid = do Tpl.page notFound ["404", "Amphiarao"] $ \langs -> do @@ -154,3 +158,27 @@ sessionAction' uuid session cb = do method POST liftIO $ cb session seeOther ('/':ID.toString uuid) $ toResponse () + +--- + +serveEl :: UUID -> Session -> String -> ServerPart Response +serveEl uuid session el = do + session' <- liftIO $ readMVar session + case getEl session' =<< ID.fromString el of + Just el' -> msum [ + dir "preview" $ serveElPreview uuid el', + serveEl' uuid session' el' + ] + Nothing -> Tpl.inspector notFound "404" session' $ \langs -> + H.h1 $ l langs ElementNotFound + +serveEl' uuid session' el = do + nullDir + method GET + Tpl.inspector ok "Element" session' $ \langs -> Tpl.xmlNode $ XC.node el + +serveElPreview uuid el = do + nullDir + method GET + Tpl.page ok ["Element", Txt.pack $ ID.toString uuid, "Amphiarao"] $ \langs -> + Tpl.xmlNode $ XC.node el diff --git a/src/Messages.hs b/src/Messages.hs index 61dcc64..ca37c18 100644 --- a/src/Messages.hs +++ b/src/Messages.hs @@ -12,6 +12,7 @@ data Message = CloseSession | LoadTimeout | SessionNotFound | + ElementNotFound | NoResults | PromptPreview | ErrURL deriving Show @@ -33,6 +34,7 @@ l ("en":_) CreateSession = "Open new test session" l ("en":_) LoadTimeout = "Load Timeout" l ("en":_) CloseSession = "Close Session" l ("en":_) SessionNotFound = "Session Not Found" +l ("en":_) ElementNotFound = "Element Not Found" l ("en":_) NoResults = em "No Results" l ("en":_) PromptPreview = em "Click a search result to preview it here" l ("en":_) ErrURL = do diff --git a/src/UI/Search.hs b/src/UI/Search.hs index 4bdd32c..3087427 100644 --- a/src/UI/Search.hs +++ b/src/UI/Search.hs @@ -16,6 +16,7 @@ import qualified Internal.Elements as Els import qualified Text.XML.Cursor as XC import Control.Monad (mapM) +import qualified UI.Templates as Tpl engines :: [( [Text] -> Html, @@ -26,13 +27,13 @@ engines = [ (const "CSS", queryEls "css selector") ] -result href' label = a ! href (stringValue href') ! target "preview" $ string label +result href' = a ! href (stringValue href') ! target "preview" disclosure = "⤷" --- offerToLoad q _ _ | Just _ <- parseAbsoluteURI q = return [\langs -> do - result q q + result q $ string q H.form ! action "nav/load" ! method "POST" $ do input ! type_ "hidden" ! name "url" ! value (stringValue q) button ! type_ "submit" ! class_ "disclosure" ! A.title (l' langs DebugLink') $ disclosure @@ -44,4 +45,4 @@ queryEls method q session session' Prelude.map formatEl <$> mapM (\el -> (,) el <$> registerEl session el) ret | otherwise = return [] -formatEl (el, uuid) langs = result ("el/" ++ ID.toString uuid ++ "/preview") $ show $ XC.node el +formatEl (el, uuid) langs = result ("el/" ++ ID.toString uuid ++ "/preview") $ Tpl.xmlNode $ XC.node el diff --git a/src/UI/Templates.hs b/src/UI/Templates.hs index 37b1d7d..e6c80bd 100644 --- a/src/UI/Templates.hs +++ b/src/UI/Templates.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} -module UI.Templates(page, inspector, sessionForm) where +module UI.Templates(page, inspector, sessionForm, xmlNode) where import Happstack.Lite import Text.Blaze.Html5 as H @@ -9,10 +9,13 @@ import Data.Text as Txt import Internal import Control.Monad.IO.Class (liftIO) -import Control.Monad (unless) +import Control.Monad (unless, when, forM) import Control.Concurrent.MVar import Data.UUID as ID +import Text.XML (Element(..), Node(..), Instruction(..), Name(..)) +import qualified Data.Map as M + import Messages import Happstack.Server.I18N @@ -55,3 +58,49 @@ inspector return' title session' body' = do sessionForm langs = H.form ! A.method "POST" ! action "/" ! alt (l' langs CreateSession') $ do input ! type_ "url" ! name "target" ! placeholder "URL to debug" button ! type_ "submit" $ l langs CreateSession + +--- XML formatting + +xmlNode (NodeElement (Element name attrs childs)) = do + symbolTok False "<" + ident'Tok name + forM (M.toList attrs) $ \(name, value) -> do + text " " + ident'Tok name + symbolTok True "=" + stringTok $ show value -- quote it! + when (Prelude.null childs) $ symbolTok True "/" + symbolTok False ">" + where + ident'Tok (Name tag _ ns) = do + case ns of + Just ns' -> do + qualifyTok ns' + symbolTok False ":" + Nothing -> return () + identTok tag +xmlNode (NodeInstruction (Instruction name value)) = do + symbolTok False "<" + symbolTok True "?" + identTok name + text " " + stringTok $ unpack value + symbolTok True "?" + symbolTok False ">" + +xmlNode (NodeContent text) = stringTok $ show text +xmlNode (NodeComment text) = do + symbolTok False "" + + + +symbolTok False = token "symbol silent" +symbolTok True = token "symbol" +qualifyTok = token "qualify" +identTok = token "ident" +stringTok = token "string" . pack +commentTok = token "comment" + +token type_ txt = H.span ! class_ (stringValue ("tok-" ++ type_)) $ text txt -- 2.30.2