From 8a39949f3c175602bb54775513bdf599e58ba282 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Wed, 23 Jun 2021 15:11:28 +1200 Subject: [PATCH] Refactoring, allowing reading which URL was loaded. --- src/Internal.hs | 2 ++ src/Main.hs | 18 ++++++++++-------- src/Messages.hs | 20 +++++++++++++++++++- src/UI/Search.hs | 5 +++-- src/UI/Templates.hs | 17 ++++++++--------- src/Webdriver.hs | 10 +++++++++- 6 files changed, 51 insertions(+), 21 deletions(-) diff --git a/src/Internal.hs b/src/Internal.hs index b995048..7a42b90 100644 --- a/src/Internal.hs +++ b/src/Internal.hs @@ -20,6 +20,7 @@ import qualified Network.URI.Fetch as URI type Sessions = MVar (M.HashMap UUID Session) type Session = MVar Session' data Session' = Session { + uuid_ :: UUID, timeouts :: Timeouts, loader :: URI.Session, currentURL :: URI.URI @@ -33,6 +34,7 @@ createSession sessions caps = do uuid <- ID.nextRandom loader' <- URI.newSession let session = Session { + uuid_ = uuid, timeouts = case "timeouts" `M.lookup` caps of Just t | Success t' <- fromJSON t -> t' _ -> Timeouts Nothing Nothing Nothing, diff --git a/src/Main.hs b/src/Main.hs index 718ce4c..56cd529 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -71,20 +71,20 @@ servePreviewPrompt = do serveSession :: Sessions -> String -> ServerPart Response serveSession = withSession session404 $ \uuid session -> msum [ - sessionHome uuid session, + sessionHome session, dir "timeout" $ setTimeout uuid session, - dir "search" $ searchSession uuid session, + dir "search" $ searchSession session, dir "nav" $ msum [ dir "load" $ loadPage uuid session ] ] -sessionHome uuid session = do +sessionHome session = do nullDir method GET - let uuid' = ID.toString uuid - Tpl.inspector ok "UUID" session uuid $ \langs -> H.h1 $ string uuid' + session' <- liftIO $ readMVar session + Tpl.inspector ok "UUID" session' $ \langs -> H.h1 $ string $ show $ currentURL session' session404 uuid = do Tpl.page notFound ["404", "Amphiarao"] $ \langs -> do @@ -99,13 +99,13 @@ setTimeout uuid session = do liftIO $ modifyMVar_ session inner seeOther ('/':ID.toString uuid) $ toResponse () -searchSession uuid session = do +searchSession session = do nullDir method GET q <- look "q" session' <- liftIO $ readMVar session let results = [(header, labelEmpty $ engine q session') | (header, engine) <- Q.engines] - Tpl.inspector ok (Txt.pack ('🔎':q)) session uuid $ \langs -> H.main $ do + Tpl.inspector ok (Txt.pack ('🔎':q)) session' $ \langs -> H.main $ do H.aside $ do H.form $ do H.input H.! A.type_ "search" H.! A.name "q" H.! A.value (H.stringValue q) @@ -129,4 +129,6 @@ loadPage uuid session = do Just url -> do liftIO $ Load.load session url seeOther ('/':ID.toString uuid) $ toResponse () - Nothing -> Tpl.inspector ok "400" session uuid $ \langs -> l langs ErrURL + Nothing -> do + session' <- liftIO $ readMVar session + Tpl.inspector ok "400" session' $ \langs -> l langs ErrURL diff --git a/src/Messages.hs b/src/Messages.hs index 7f15117..6b4a457 100644 --- a/src/Messages.hs +++ b/src/Messages.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -module Messages(l, Message(..)) where +module Messages(l, Message(..), l', AttrMessage(..)) where import Text.Blaze.Html5 as H import Text.Blaze.Html5.Attributes as A @@ -41,3 +41,21 @@ l ("en":_) ErrURL = do ---- End localizations l (_:langs) msg = l langs msg l [] msg = string $ show msg + +data AttrMessage = + LoadTimeout' | + CreateSession' | + CloseSession' | + Search' | + DebugLink' deriving Show + +l' :: [Text] -> AttrMessage -> AttributeValue +---- Begin localization +l' ("en":_) LoadTimeout' = "Load Timeout" +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" +---- End localization +l' (_:langs) msg = l' langs msg +l' [] msg = stringValue $ show msg diff --git a/src/UI/Search.hs b/src/UI/Search.hs index 0c244a8..d558916 100644 --- a/src/UI/Search.hs +++ b/src/UI/Search.hs @@ -7,6 +7,7 @@ import Text.Blaze.Html import Data.Text as Txt import Internal +import Messages import Network.URI (parseAbsoluteURI) @@ -18,11 +19,11 @@ engines = [ (const "URL", offerToLoad) ] -offerToLoad q _ | Just _ <- parseAbsoluteURI q = [const $ do +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" $ disclosure + button ! type_ "submit" ! class_ "disclosure" ! A.title (l' langs DebugLink') $ disclosure ] result href' label = a ! href (stringValue href') ! target "preview" $ string label diff --git a/src/UI/Templates.hs b/src/UI/Templates.hs index e848e88..3280272 100644 --- a/src/UI/Templates.hs +++ b/src/UI/Templates.hs @@ -23,21 +23,20 @@ page return' title body' = do H.title $ text $ intercalate " — " title body $ body' langs -inspector :: (Response -> ServerPart Response) -> Text -> Session -> UUID -> ([Text] -> Html) -> ServerPart Response -inspector return' title session uuid body' = do - session' <- liftIO $ readMVar session - let uuid' = ID.toString uuid +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', "/search"] $ do - input ! type_ "search" ! name "q" ! placeholder "Search..." + H.form ! action' ["/", uuid', "/search"] ! alt (l' langs Search') $ do + input ! type_ "search" ! name "q" ! placeholder (l' langs Search') body' langs footer $ do - H.form ! action' ["/close/", uuid'] ! A.method "POST" $ do + H.form ! action' ["/close/", uuid'] ! A.method "POST" ! alt (l' langs CloseSession') $ do button ! type_ "submit" $ l langs CloseSession hr - H.form ! action' ["/", uuid', "/timeout"] ! A.method "POST" $ p $ do + H.form ! action' ["/", uuid', "/timeout"] ! A.method "POST" ! alt (l' langs LoadTimeout') $ p $ do H.label $ do l langs LoadTimeout input ! type_ "number" ! name "pageLoad" ! value timeout @@ -46,6 +45,6 @@ inspector return' title session uuid body' = do where action' = A.action . H.stringValue . Prelude.concat -sessionForm langs = H.form ! A.method "POST" ! action "/" $ do +sessionForm langs = H.form ! A.method "POST" ! action "/" ! alt (l' langs CreateSession') $ do input ! type_ "url" ! name "target" ! placeholder "URL to debug" button ! type_ "submit" $ l langs CreateSession diff --git a/src/Webdriver.hs b/src/Webdriver.hs index 1e0d3b7..4c22d32 100644 --- a/src/Webdriver.hs +++ b/src/Webdriver.hs @@ -35,7 +35,9 @@ serveSession :: WD.Sessions -> String -> ServerPart Response serveSession sessions = WD.withSession fail (\uuid session -> msum [ delSession sessions uuid, dir "timeouts" $ getTimeout session, - dir "timeouts" $ setTimeout session + dir "timeouts" $ setTimeout session, + dir "url" $ navigateTo session, + dir "url" $ getURL session ]) sessions where fail uuid'| Just _ <- ID.fromString uuid' = errJSON 404 "invalid session ID" $ ( @@ -94,3 +96,9 @@ navigateTo session = do ok $ toResponse () Just target -> errJSON 400 "invalid argument" (target ++ " is not an absolute URL") Nothing -> errJSON 400 "invalid argument" "Failed to parse JSON input" + +getURL session = do + method GET + nullDir + session' <- liftIO $ readMVar session + ok $ toResponse $ show $ WD.currentURL session' -- 2.30.2