From 58648b6294944eec4be73156d0f4c4cc99f593d8 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Tue, 13 Jul 2021 18:36:10 +1200
Subject: [PATCH] Allow searching for a descendant of a given element.

---
 src/Main.hs         | 14 +++++++++++++-
 src/UI/Search.hs    |  6 +++---
 src/UI/Templates.hs | 13 ++++++++++---
 src/Webdriver.hs    | 36 ++++++++++++++++++++++++++++++++++++
 4 files changed, 62 insertions(+), 7 deletions(-)

diff --git a/src/Main.hs b/src/Main.hs
index 4f48ced..85ec6ff 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -120,11 +120,23 @@ searchSession session = do
     method GET
     q <- look "q"
     session' <- liftIO $ readMVar session
+    el <- looks "el"
+    let (root, ancestors) = case el of {
+        (el':_) | Just root <- ID.fromString el' >>= getEl session' ->
+            (root, Prelude.reverse $ (XC.orSelf XC.ancestor) root);
+        _ -> (XC.fromDocument $ document session', [])
+    }
+
     results <- forM Q.engines $ \(header, engine) -> do
-        results' <- liftIO $ engine q session session'
+        results' <- liftIO $ engine q session root
         return (header, labelEmpty results')
     Tpl.inspector' q ok (Txt.pack ('🔎':q)) session' $ \langs -> H.main $ do
         H.aside $ do
+            H.p $ do
+                forM ancestors $ \el -> do
+                    Tpl.xmlNode' $ XC.node el -- Should all be elements...
+                    H.text " > "
+                return ()
             H.dl $ do
                 forM results $ \(header, results') -> do
                     H.dt $ header langs
diff --git a/src/UI/Search.hs b/src/UI/Search.hs
index ab73f84..e4b748f 100644
--- a/src/UI/Search.hs
+++ b/src/UI/Search.hs
@@ -21,7 +21,7 @@ import qualified UI.Templates as Tpl
 
 engines :: [(
     [Text] -> Html,
-    String -> Session -> Session' -> IO [[Text] -> Html]
+    String -> Session -> XC.Cursor -> IO [[Text] -> Html]
   )]
 engines = [
     (const "URL", offerToLoad),
@@ -44,8 +44,8 @@ offerToLoad q _ _ | Just _ <- parseAbsoluteURI q = return [\langs -> do
       ]
     | otherwise = return []
 
-queryEls method q session session'
-    | Right ret <- Els.find (Els.Find method q) $ XC.fromDocument $ document session' = do
+queryEls method q session root
+    | Right ret <- Els.find (Els.Find method q) root = do
         Prelude.map formatEl <$> mapM (\el -> (,) el <$> registerEl session el) ret
     | otherwise = return []
 
diff --git a/src/UI/Templates.hs b/src/UI/Templates.hs
index 00d0519..3de5be9 100644
--- a/src/UI/Templates.hs
+++ b/src/UI/Templates.hs
@@ -17,6 +17,7 @@ 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 Data.Maybe (fromMaybe)
 
 import Messages
 import Happstack.Server.I18N
@@ -120,9 +121,15 @@ elSelector (Element (Name name _ ns) attrs _) = do
         | otherwise = return []
 
 elPage uuid cursor links = blockquote $ do
-    nav $ void $ forM (Prelude.reverse $ XC.ancestor cursor) $ \el -> do
-        link el $ xmlNode' $ XC.node el -- Should all be elements...
-        symbolTok False " > "
+    nav $ do
+        forM (Prelude.reverse $ XC.ancestor cursor) $ \el -> do
+            link el $ xmlNode' $ XC.node el -- Should all be elements...
+            symbolTok False " > "
+        H.form ! class_ "disclosure" ! target "_top" !
+                action (stringValue ('/':ID.toString uuid ++ "/search")) ! A.method "GET" $ do
+            input ! type_ "hidden" ! name "el" !
+                value (stringValue $ fromMaybe "" $ ID.toString <$> Prelude.lookup (XC.node cursor) links)
+            input ! type_ "search" ! name "q"
     link cursor $ p $ xmlNode $ XC.node cursor
     ol $ void $ forM (XC.child cursor) $ \el -> li $ link el $ xmlNode $ XC.node el
   where
diff --git a/src/Webdriver.hs b/src/Webdriver.hs
index 654a42e..8eaf7be 100644
--- a/src/Webdriver.hs
+++ b/src/Webdriver.hs
@@ -57,6 +57,7 @@ serveSession sessions = WD.withSession fail (\uuid session -> msum [
         ],
         dir "frame" $ msum [noSuchFrame, dir "parent" $ ok $ toResponse ()], -- Noops
         dir "element" $ findFromRoot session,
+        dir "element" $ path $ serveElement session,
         dir "elements" $ findAllFromRoot session
     ]) sessions
   where
@@ -201,3 +202,38 @@ findFromRoot session = do
             Left (True, msg) -> errJSON 400 "invalid selector" msg
             Left (False, msg) -> errJSON 400 "invalid argument" msg
         Nothing -> errJSON 400 "invalid argument" "Failed to parse JSON"
+
+serveElement session elUUID = do
+    session' <- liftIO $ readMVar session
+    case WD.getEl session' =<< ID.fromString elUUID of
+        Just el -> msum [
+            dir "element" $ findFromEl session el,
+            dir "elements" $ findAllFromEl session el
+          ]
+        Nothing | Nothing <- ID.fromString elUUID ->
+            errJSON 404 "no such element" "Invalid UUID"
+        Nothing -> errJSON 404 "no such element" "Unknown UUID."
+
+findFromEl session el = do
+    method POST
+    nullDir
+    req <- getJSON
+    case req of
+        Just req' -> case WDE.find req' el of
+            Right (res:_) -> okJSON =<< liftIO (WD.serializeEl session res)
+            Right [] | WDE.Find using query <- req' -> errJSON 404 "No such element" (
+                "No child elements match " ++ unpack using ++ " query: " ++ query)
+            Left (True, msg) -> errJSON 400 "invalid selector" msg
+            Left (False, msg) -> errJSON 400 "invalid argument" msg
+        Nothing -> errJSON 400 "invalid argument" "Failed to parse JSON"
+
+findAllFromEl session el = do
+    method POST
+    nullDir
+    req <- getJSON
+    case req of
+        Just req' -> case WDE.find req' el of
+            Right res -> okJSON =<< mapM (liftIO . WD.serializeEl session) res
+            Left (True, msg) -> errJSON 400 "invalid selector" msg
+            Left (False, msg) -> errJSON 400 "invalid argument" msg
+        Nothing -> errJSON 400 "invalid argument" "Failed to parse JSON"
-- 
2.30.2