From 7b26fe8f55dd630cde332fb7663e163ae441d70b Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Thu, 24 Jun 2021 19:27:08 +1200
Subject: [PATCH] Expose CSS selector search in UI FIXME: build the linked
 pages.

---
 src/Main.hs      |  4 +++-
 src/UI/Search.hs | 35 ++++++++++++++++++++++++++---------
 src/Webdriver.hs |  2 +-
 3 files changed, 30 insertions(+), 11 deletions(-)

diff --git a/src/Main.hs b/src/Main.hs
index a79024f..84584d6 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -111,7 +111,9 @@ searchSession session = do
     method GET
     q <- look "q"
     session' <- liftIO $ readMVar session
-    let results = [(header, labelEmpty $ engine q session') | (header, engine) <- Q.engines]
+    results <- forM Q.engines $ \(header, engine) -> do
+        results' <- liftIO $ engine q session session'
+        return (header, labelEmpty results')
     Tpl.inspector ok (Txt.pack ('🔎':q)) session' $ \langs -> H.main $ do
         H.aside $ do
             H.form $ do
diff --git a/src/UI/Search.hs b/src/UI/Search.hs
index d558916..4bdd32c 100644
--- a/src/UI/Search.hs
+++ b/src/UI/Search.hs
@@ -6,25 +6,42 @@ import Text.Blaze.Html5.Attributes as A
 import Text.Blaze.Html
 import Data.Text as Txt
 
+import Data.UUID as ID
+
 import Internal
 import Messages
 
 import Network.URI (parseAbsoluteURI)
+import qualified Internal.Elements as Els
+import qualified Text.XML.Cursor as XC
+
+import Control.Monad (mapM)
 
 engines :: [(
     [Text] -> Html,
-    String -> Session' -> [[Text] -> Html]
+    String -> Session -> Session' -> IO [[Text] -> Html]
   )]
 engines = [
-    (const "URL", offerToLoad)
-  ]
-
-offerToLoad q _ | Just _ <- parseAbsoluteURI q = [\langs -> do
-    result q 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
+    (const "URL", offerToLoad),
+    (const "CSS", queryEls "css selector")
   ]
 
 result href' label = a ! href (stringValue href') ! target "preview" $ string label
 disclosure = "⤷"
+
+---
+
+offerToLoad q _ _ | Just _ <- parseAbsoluteURI q = return [\langs -> do
+        result q 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
+      ]
+    | otherwise = return []
+
+queryEls method q session session'
+    | Right ret <- Els.find (Els.Find method q) $ XC.fromDocument $ document session' = do
+        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
diff --git a/src/Webdriver.hs b/src/Webdriver.hs
index bd5b6b4..2a9a458 100644
--- a/src/Webdriver.hs
+++ b/src/Webdriver.hs
@@ -56,7 +56,7 @@ serveSession sessions = WD.withSession fail (\uuid session -> msum [
             dir "fullscreen" $ unsupportedOp
         ],
         dir "frame" $ msum [noSuchFrame, dir "parent" $ ok $ toResponse ()], -- Noops
-        dir "element" $ findFromRoot session
+        dir "elements" $ findFromRoot session
     ]) sessions
   where
     fail uuid'| Just _ <- ID.fromString uuid' = errJSON 404 "invalid session ID" $ (
-- 
2.30.2