From 7a6334be0be533bcd94be41d2542483c81a08bc1 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Wed, 23 Jun 2021 15:45:30 +1200
Subject: [PATCH] Allow testing reloading of webpages.

---
 src/Main.hs         | 10 +++++++++-
 src/Messages.hs     |  4 +++-
 src/UI/Templates.hs |  2 ++
 src/Webdriver.hs    | 10 +++++++++-
 4 files changed, 23 insertions(+), 3 deletions(-)

diff --git a/src/Main.hs b/src/Main.hs
index 56cd529..0cdb067 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -75,7 +75,8 @@ serveSession = withSession session404 $ \uuid session -> msum [
         dir "timeout" $ setTimeout uuid session,
         dir "search" $ searchSession session,
         dir "nav" $ msum [
-            dir "load" $ loadPage uuid session
+            dir "load" $ loadPage uuid session,
+            dir "reload" $ reloadPage uuid session
         ]
     ]
 
@@ -132,3 +133,10 @@ loadPage uuid session = do
         Nothing -> do
             session' <- liftIO $ readMVar session
             Tpl.inspector ok "400" session' $ \langs -> l langs ErrURL
+
+reloadPage uuid session = do
+    nullDir
+    method POST
+    session' <- liftIO $ readMVar session
+    liftIO $ Load.load session $ currentURL session'
+    seeOther ('/':ID.toString uuid) $ toResponse ()
diff --git a/src/Messages.hs b/src/Messages.hs
index 6b4a457..3514ab0 100644
--- a/src/Messages.hs
+++ b/src/Messages.hs
@@ -47,7 +47,8 @@ data AttrMessage =
     CreateSession' |
     CloseSession' |
     Search' |
-    DebugLink' deriving Show
+    DebugLink' |
+    Reload' deriving Show
 
 l' :: [Text] -> AttrMessage -> AttributeValue
 ---- Begin localization
@@ -56,6 +57,7 @@ l' ("en":_) CreateSession' = "Open new test session"
 l' ("en":_) CloseSession' = "Close Session"
 l' ("en":_) Search' = "Search…"
 l' ("en":_) DebugLink' = "Debug link in this test session"
+l' ("en":_) Reload' = "Reload inspected page"
 ---- End localization
 l' (_:langs) msg = l' langs msg
 l' [] msg = stringValue $ show msg
diff --git a/src/UI/Templates.hs b/src/UI/Templates.hs
index 3280272..5b81eea 100644
--- a/src/UI/Templates.hs
+++ b/src/UI/Templates.hs
@@ -29,6 +29,8 @@ inspector return' title session' body' = do
     let timeout = H.stringValue $ show $ pageLoad $ timeouts session'
     page return' [title, pack $ show $ currentURL $ session', "Amphiarao"] $ \langs -> do
         header $ do
+            H.form ! action' ["/", uuid', "/nav/reload"] ! alt (l' langs Reload') ! A.method "POST" $ do
+                button ! type_ "submit" ! A.title (l' langs Reload') $ "↻"
             H.form ! action' ["/", uuid', "/search"] ! alt (l' langs Search') $ do
                 input ! type_ "search" ! name "q" ! placeholder (l' langs Search')
         body' langs
diff --git a/src/Webdriver.hs b/src/Webdriver.hs
index 4c22d32..7a5bdc5 100644
--- a/src/Webdriver.hs
+++ b/src/Webdriver.hs
@@ -37,7 +37,8 @@ serveSession sessions = WD.withSession fail (\uuid session -> msum [
         dir "timeouts" $ getTimeout session,
         dir "timeouts" $ setTimeout session,
         dir "url" $ navigateTo session,
-        dir "url" $ getURL session
+        dir "url" $ getURL session,
+        dir "refresh" $ reloadPage session
     ]) sessions
   where
     fail uuid'| Just _ <- ID.fromString uuid' = errJSON 404 "invalid session ID" $ (
@@ -102,3 +103,10 @@ getURL session = do
     nullDir
     session' <- liftIO $ readMVar session
     ok $ toResponse $ show $ WD.currentURL session'
+
+reloadPage session = do
+    method POST
+    nullDir
+    session' <- liftIO $ readMVar session
+    liftIO $ WD.load session $ WD.currentURL session'
+    ok $ toResponse ()
-- 
2.30.2