From afb3d55d04613738265bc5b5e7f7ec2eff8904e7 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Wed, 23 Jun 2021 16:33:11 +1200 Subject: [PATCH] Allow navigating (tab) history. --- src/Internal.hs | 7 +++++-- src/Internal/Load.hs | 32 +++++++++++++++++++++++++++++--- src/Main.hs | 14 +++++++++++--- src/Messages.hs | 6 +++++- src/UI/Templates.hs | 11 ++++++++--- src/Webdriver.hs | 12 ++++++++++-- 6 files changed, 68 insertions(+), 14 deletions(-) diff --git a/src/Internal.hs b/src/Internal.hs index 7a42b90..a4f07a0 100644 --- a/src/Internal.hs +++ b/src/Internal.hs @@ -23,7 +23,9 @@ data Session' = Session { uuid_ :: UUID, timeouts :: Timeouts, loader :: URI.Session, - currentURL :: URI.URI + currentURL :: URI.URI, + backStack :: [URI.URI], + nextStack :: [URI.URI] } initSessions :: IO Sessions @@ -39,7 +41,8 @@ createSession sessions caps = do Just t | Success t' <- fromJSON t -> t' _ -> Timeouts Nothing Nothing Nothing, loader = loader', - currentURL = URI.nullURI + currentURL = URI.nullURI, + backStack = [], nextStack = [] } session' <- newMVar session modifyMVar_ sessions (return . M.insert uuid session') diff --git a/src/Internal/Load.hs b/src/Internal/Load.hs index ab8edf2..05c8ac4 100644 --- a/src/Internal/Load.hs +++ b/src/Internal/Load.hs @@ -1,4 +1,4 @@ -module Internal.Load(load, parseAbsoluteURI) where +module Internal.Load(load, load', back, next, parseAbsoluteURI) where import Internal @@ -17,8 +17,8 @@ import Network.URI.Fetch as URI mime = words "text/html text/xml application/xml application/xhtml+xml text/plain" -load :: Internal.Session -> URI -> IO () -load session uri = modifyMVar_ session $ \session' -> maybeTimeout session' uri $ do +load' :: Internal.Session -> URI -> IO () +load' session uri = modifyMVar_ session $ \session' -> maybeTimeout session' uri $ do (redirected, _, _) <- fetchURL' (loader session') mime uri return $ session' { currentURL = redirected} @@ -27,3 +27,29 @@ maybeTimeout session uri act | currentURL session /= uri, Just delay <- pageLoad -- WebDriver deals in terms of milliseconds, I think?, Haskell deals in terms of microseconds. fromMaybe session <$> timeout (delay * 1000) act maybeTimeout _ _ act = act + +--- + +load :: Internal.Session -> URI -> IO () +load session uri = do + modifyMVar_ session $ return . inner + load' session uri + where + inner session'@Session {backStack = backStack', currentURL = currentURL' } = + session' { backStack = currentURL' : backStack' } + +back :: Internal.Session -> IO () +back session = do + uri <- modifyMVar session $ return . inner + load' session uri + where + inner session'@Session { backStack = b:bs, currentURL = n, nextStack = ns } = + (session' { backStack = bs, nextStack = n:ns }, b) + +next :: Internal.Session -> IO () +next session = do + uri <- modifyMVar session $ return . inner + load' session uri + where + inner session'@Session { backStack = bs, currentURL = b, nextStack = n:ns } = + (session' { backStack = b:bs, nextStack = ns }, n) diff --git a/src/Main.hs b/src/Main.hs index 0cdb067..8a17aee 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -52,7 +52,7 @@ postHome sessions = do target <- looks "target" -- Not much point of a blank session, so allow loading here. case target of - (target':_) | Just url <- Load.parseAbsoluteURI target' -> liftIO $ Load.load session url + (target':_) | Just url <- Load.parseAbsoluteURI target' -> liftIO $ Load.load' session url _ -> return () seeOther ('/' : ID.toString uuid) $ toResponse () @@ -76,7 +76,9 @@ serveSession = withSession session404 $ \uuid session -> msum [ dir "search" $ searchSession session, dir "nav" $ msum [ dir "load" $ loadPage uuid session, - dir "reload" $ reloadPage uuid session + dir "reload" $ reloadPage uuid session, + dir "back" $ sessionAction' uuid session Load.back, + dir "next" $ sessionAction' uuid session Load.next ] ] @@ -138,5 +140,11 @@ reloadPage uuid session = do nullDir method POST session' <- liftIO $ readMVar session - liftIO $ Load.load session $ currentURL session' + liftIO $ Load.load' session $ currentURL session' + seeOther ('/':ID.toString uuid) $ toResponse () + +sessionAction' uuid session cb = do + nullDir + method POST + liftIO $ cb session seeOther ('/':ID.toString uuid) $ toResponse () diff --git a/src/Messages.hs b/src/Messages.hs index 3514ab0..61dcc64 100644 --- a/src/Messages.hs +++ b/src/Messages.hs @@ -48,7 +48,9 @@ data AttrMessage = CloseSession' | Search' | DebugLink' | - Reload' deriving Show + Reload' | + Back' | + Next' deriving Show l' :: [Text] -> AttrMessage -> AttributeValue ---- Begin localization @@ -58,6 +60,8 @@ l' ("en":_) CloseSession' = "Close Session" l' ("en":_) Search' = "Search…" l' ("en":_) DebugLink' = "Debug link in this test session" l' ("en":_) Reload' = "Reload inspected page" +l' ("en":_) Back' = "Previous inspected page" +l' ("en":_) Next' = "Next 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 5b81eea..37b1d7d 100644 --- a/src/UI/Templates.hs +++ b/src/UI/Templates.hs @@ -9,6 +9,7 @@ import Data.Text as Txt import Internal import Control.Monad.IO.Class (liftIO) +import Control.Monad (unless) import Control.Concurrent.MVar import Data.UUID as ID @@ -25,12 +26,13 @@ page return' title body' = do inspector :: (Response -> ServerPart Response) -> Text -> Session' -> ([Text] -> Html) -> ServerPart Response inspector return' title session' body' = do - let uuid' = ID.toString $ uuid_ session' 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') $ "↻" + unless (Prelude.null $ backStack session') $ postButton "/nav/back" (l' langs Back') "🡸" + unless (Prelude.null $ nextStack session') $ postButton "/nav/next" (l' langs Next') "🡺" + postButton "/nav/reload" (l' langs Reload') "↻" + hr H.form ! action' ["/", uuid', "/search"] ! alt (l' langs Search') $ do input ! type_ "search" ! name "q" ! placeholder (l' langs Search') body' langs @@ -45,7 +47,10 @@ inspector return' title session' body' = do text "ms" where + uuid' = ID.toString $ uuid_ session' action' = A.action . H.stringValue . Prelude.concat + postButton target title' label = H.form ! action' ["/", uuid', target] ! alt title' ! A.method "POST" $ do + button ! type_ "submit" ! A.title title' $ label sessionForm langs = H.form ! A.method "POST" ! action "/" ! alt (l' langs CreateSession') $ do input ! type_ "url" ! name "target" ! placeholder "URL to debug" diff --git a/src/Webdriver.hs b/src/Webdriver.hs index 7a5bdc5..5bc0df1 100644 --- a/src/Webdriver.hs +++ b/src/Webdriver.hs @@ -38,7 +38,9 @@ serveSession sessions = WD.withSession fail (\uuid session -> msum [ dir "timeouts" $ setTimeout session, dir "url" $ navigateTo session, dir "url" $ getURL session, - dir "refresh" $ reloadPage session + dir "refresh" $ reloadPage session, + dir "back" $ sessionAction WD.back session, + dir "forward" $ sessionAction WD.next session ]) sessions where fail uuid'| Just _ <- ID.fromString uuid' = errJSON 404 "invalid session ID" $ ( @@ -108,5 +110,11 @@ reloadPage session = do method POST nullDir session' <- liftIO $ readMVar session - liftIO $ WD.load session $ WD.currentURL session' + liftIO $ WD.load' session $ WD.currentURL session' + ok $ toResponse () + +sessionAction cb session = do + method POST + nullDir + liftIO $ cb session ok $ toResponse () -- 2.30.2