From a61043552f6f42bfc8ae2922ad78d1a3f424900b Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Sat, 26 Jun 2021 08:51:58 +1200 Subject: [PATCH] Create pages describing elements & style Amphiarao. --- amphiarao.cabal | 10 +++++++--- src/Main.hs | 30 +++++++++++++++++------------- src/UI/Search.hs | 7 ++++--- src/UI/Templates.hs | 43 +++++++++++++++++++++++++++++++++++++------ 4 files changed, 65 insertions(+), 25 deletions(-) diff --git a/amphiarao.cabal b/amphiarao.cabal index 5e3c218..ad205f9 100644 --- a/amphiarao.cabal +++ b/amphiarao.cabal @@ -64,11 +64,15 @@ executable amphiarao -- Other library packages from which modules are imported. build-depends: base >=4.9 && <4.10, happstack-lite >=7.3.7 && <7.4, happstack-server, + -- For JSON/HTTP APIs aeson >= 1.5.0 && <1.6, text, bytestring, unordered-containers, vector, - containers >=0.5 && <0.7, uuid >=1.3 && <1.4, - blaze-html, xml-conduit >= 1.8 && < 1.9, html-conduit >= 1.3 && <1.4, + containers >=0.5 && <0.7, uuid >=1.3 && <1.4, file-embed >= 0.0.9 && < 0.1, + -- For HTML UIs + blaze-html, blaze-markup, + -- Network input hurl >= 2.1 && <3, network-uri, - css-syntax, array >=0.4 + -- Parse & query XML/HTML + xml-conduit >= 1.8 && < 1.9, html-conduit >= 1.3 && <1.4, css-syntax, array >=0.4 build-tools: happy diff --git a/src/Main.hs b/src/Main.hs index 120e0b7..e52f8e3 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,21 +1,24 @@ -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TemplateHaskell #-} module Main where import Happstack.Lite import Happstack.Server.RqData import Control.Concurrent.MVar import Data.HashMap.Strict as M +import Data.FileEmbed import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A -import Text.Blaze.Html (text, string) +import Text.Blaze.Html (text, string, contents) +import Text.Blaze.Renderer.Text (renderMarkup) import qualified Data.Text as Txt +import Data.Text.Lazy (toStrict) import Webdriver import Data.UUID as ID import qualified Text.XML.Cursor as XC -import qualified Text.XML as XML +import Data.Maybe import Messages import Happstack.Server.I18N @@ -33,6 +36,7 @@ main :: IO () main = do sessions <- initSessions serve Nothing $ msum [ + dir "assets" $ path $ ok . toResponse . fromMaybe "Not Found" . flip Prelude.lookup $(embedDir "assets"), dir "webdriver" $ dir "v1" $ serveWebdriver sessions, postHome sessions, serveHome, @@ -45,7 +49,7 @@ serveHome :: ServerPart Response serveHome = do nullDir method GET - Tpl.page ok ["Amphiarao"] $ \langs -> do + Tpl.page ok ["Amphiarao"] "" $ \langs -> do l langs AmphiaraoIntro Tpl.sessionForm langs @@ -71,7 +75,7 @@ deleteSession sessions uuid = do servePreviewPrompt = do nullDir method GET - Tpl.page ok ["?", "Amphiarao"] $ \langs -> H.p $ l langs PromptPreview + Tpl.page ok ["?", "Amphiarao"] "" $ \langs -> H.p $ l langs PromptPreview --- @@ -94,11 +98,11 @@ sessionHome session = do method GET session' <- liftIO $ readMVar session - Tpl.inspector ok "title" session' $ \langs -> - Tpl.xmlNode $ XML.NodeElement $ XML.documentRoot $ document session' + Tpl.inspector ok ":root" session' $ \langs -> + Tpl.elPage $ XC.fromDocument $ document session' session404 uuid = do - Tpl.page notFound ["404", "Amphiarao"] $ \langs -> do + Tpl.page notFound ["404", "Amphiarao"] "" $ \langs -> do H.h1 $ l langs SessionNotFound Tpl.sessionForm langs @@ -128,8 +132,7 @@ searchSession session = do forM results' $ \result -> H.dd $ result langs return () return () - H.section $ do - H.iframe H.! A.src "/preview-prompt" H.! A.name "preview" $ "" + H.iframe H.! A.src "/preview-prompt" H.! A.name "preview" $ "" where labelEmpty [] = [\langs -> l langs NoResults] labelEmpty x = x @@ -175,10 +178,11 @@ serveEl uuid session el = do serveEl' uuid session' el = do nullDir method GET - Tpl.inspector ok "Element" session' $ \langs -> Tpl.xmlNode $ XC.node el + let title = toStrict $ renderMarkup $ contents $ Tpl.xmlNode' $ XC.node el + Tpl.inspector ok title session' $ \langs -> Tpl.elPage el serveElPreview uuid el = do nullDir method GET - Tpl.page ok ["Element", Txt.pack $ ID.toString uuid, "Amphiarao"] $ \langs -> - Tpl.xmlNode $ XC.node el + let title = toStrict $ renderMarkup $ contents $ Tpl.xmlNode' $ XC.node el + Tpl.page ok [title, Txt.pack $ ID.toString uuid, "Amphiarao"] "fill" $ \langs -> Tpl.elPage el diff --git a/src/UI/Search.hs b/src/UI/Search.hs index 3087427..d46b34f 100644 --- a/src/UI/Search.hs +++ b/src/UI/Search.hs @@ -14,6 +14,7 @@ import Messages import Network.URI (parseAbsoluteURI) import qualified Internal.Elements as Els import qualified Text.XML.Cursor as XC +import qualified Text.XML as XML import Control.Monad (mapM) import qualified UI.Templates as Tpl @@ -33,10 +34,10 @@ disclosure = "⤷" --- offerToLoad q _ _ | Just _ <- parseAbsoluteURI q = return [\langs -> do - 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 + result q $ string q + button ! type_ "submit" ! A.title (l' langs DebugLink') $ disclosure ] | otherwise = return [] @@ -45,4 +46,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") $ Tpl.xmlNode $ 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 e6c80bd..dce8cd7 100644 --- a/src/UI/Templates.hs +++ b/src/UI/Templates.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} -module UI.Templates(page, inspector, sessionForm, xmlNode) where +module UI.Templates(page, inspector, sessionForm, + xmlNode, xmlNode', elSelector, elPage) where import Happstack.Lite import Text.Blaze.Html5 as H @@ -14,23 +15,25 @@ import Control.Concurrent.MVar import Data.UUID as ID import Text.XML (Element(..), Node(..), Instruction(..), Name(..)) +import Text.XML.Cursor as XC import qualified Data.Map as M import Messages import Happstack.Server.I18N -page :: (Response -> ServerPart Response) -> [Text] -> ([Text] -> Html) -> ServerPart Response -page return' title body' = do +page :: (Response -> ServerPart Response) -> [Text] -> AttributeValue -> ([Text] -> Html) -> ServerPart Response +page return' title class_ body' = do langs <- bestLanguage <$> acceptLanguage return' $ toResponse $ html $ do H.head $ do + link ! rel "stylesheet" ! href "/assets/pantheon.css" H.title $ text $ intercalate " — " title - body $ body' langs + body ! A.class_ class_ $ body' langs inspector :: (Response -> ServerPart Response) -> Text -> Session' -> ([Text] -> Html) -> ServerPart Response inspector return' title session' body' = do let timeout = H.stringValue $ show $ pageLoad $ timeouts session' - page return' [title, pack $ show $ currentURL $ session', "Amphiarao"] $ \langs -> do + page return' [title, pack $ show $ currentURL $ session', "Amphiarao"] "fill" $ \langs -> do header $ do unless (Prelude.null $ backStack session') $ postButton "/nav/back" (l' langs Back') "🡸" unless (Prelude.null $ nextStack session') $ postButton "/nav/next" (l' langs Next') "🡺" @@ -87,18 +90,46 @@ xmlNode (NodeInstruction (Instruction name value)) = do stringTok $ unpack value symbolTok True "?" symbolTok False ">" - xmlNode (NodeContent text) = stringTok $ show text xmlNode (NodeComment text) = do symbolTok False "" +xmlNode' (NodeElement el) = elSelector el +xmlNode' node = xmlNode node + +elSelector (Element (Name name _ ns) attrs _) = do + -- Yes, token classification isn't a great fit! + case ns of + Just ns' -> do + keywordTok ns' + symbolTok False "|" + Nothing -> return () + keywordTok name + qualifiers "id" "#" identTok + qualifiers "class" "." qualifyTok + return () + where + qualifiers attr symb tok + | Just val <- attr `M.lookup` attrs = forM (Txt.words val) $ \val' -> do + symbolTok True symb + tok val' + | otherwise = return [] + +elPage cursor = blockquote $ do + nav $ void $ forM (Prelude.reverse $ XC.ancestor cursor) $ \el -> do + xmlNode' $ XC.node el -- Should all be elements... + symbolTok False " > " + p $ xmlNode $ XC.node cursor + ol $ void $ forM (XC.child cursor) $ \el -> li $ xmlNode $ XC.node el +void act = act >> return () symbolTok False = token "symbol silent" symbolTok True = token "symbol" qualifyTok = token "qualify" +keywordTok = token "keyword" identTok = token "ident" stringTok = token "string" . pack commentTok = token "comment" -- 2.30.2