6 files changed, 68 insertions(+), 14 deletions(-)

M src/Internal.hs
M src/Internal/Load.hs
M src/Main.hs
M src/Messages.hs
M src/UI/Templates.hs
M src/Webdriver.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')

@@ 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)

@@ 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 ()

@@ 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

@@ 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"

@@ 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 ()