6 files changed, 51 insertions(+), 21 deletions(-)

M src/Internal.hs
M src/Main.hs
M src/Messages.hs
M src/UI/Search.hs
M src/UI/Templates.hs
M src/Webdriver.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,

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

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

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

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

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