7 files changed, 145 insertions(+), 28 deletions(-)

M amphiarao.cabal
M src/Internal/Forms.hs
M src/Internal/Load.hs
M src/Main.hs
M src/Messages.hs
M src/UI/Templates.hs
M src/Webdriver.hs

@@ 64,16 64,16 @@ executable amphiarao
   -- other-extensions:    
   
   -- Other library packages from which modules are imported.
-  build-depends:       base >=4.9 && <4.10, happstack-lite >=7.3.7 && <7.4, happstack-server,
+  build-depends:       base >=4.9 && <4.10, happstack-lite >=7.3.7, happstack-server,
         -- For JSON/HTTP APIs
-        aeson >= 1.5.0 && <1.6, text, bytestring, unordered-containers, vector,
-        containers >=0.5 && <0.7, uuid >=1.3 && <1.4, file-embed >= 0.0.9 && < 0.1,
+        aeson >= 1.5.0, text, bytestring, unordered-containers, vector,
+        containers >=0.5, uuid >=1.3, file-embed >= 0.0.9,
         -- For HTML UIs
         blaze-html, blaze-markup,
         -- Network input
         hurl >= 2.1.1 && <3, network-uri, http-client,
         -- Parse & query XML/HTML
-        xml-conduit >= 1.8 && < 1.9, html-conduit >= 1.3 && <1.4, css-syntax, array >=0.4,
+        xml-conduit >= 1.8, html-conduit >= 1.3, css-syntax, array >=0.4,
         attoparsec, time
 
   build-tools: happy

@@ 1,5 1,6 @@
 {-# LANGUAGE OverloadedStrings, DeriveGeneric #-}
-module Internal.Forms(findForm, prefillForm, modifyForm, formAction, clearForm, sendText, typable) where
+module Internal.Forms(findForm, prefillForm, modifyForm, formAction, clearForm,
+    readInput, readInput', sendText, SendText(..), isTypableEl) where
 
 import Text.XML
 import Text.XML.Cursor


@@ 113,6 114,21 @@ clearForm session el = modifyMVar_ session $ \session' -> do
             session' { forms = M.delete form $ forms session' }
         _ -> session'
 
+readInput session el = withMVar session $ \session' -> do
+    let form = findForm el $ id2els session'
+    return $ case (form, node el) of
+        (Element (Name "form" _ _) _ _, NodeElement (Element _ attrs _))
+                | Just name <- "name" `M.lookup` M.mapKeys nameLocalName attrs,
+                Just form <- form `M.lookup` forms session' ->
+            name `HM.lookup` form
+        _ -> Nothing
+
+readInput' session el = do
+    res <- readInput session el
+    return $ case res of
+        Just (ret:_) -> ret
+        _ -> ""
+
 data SendText = SendText { text :: Txt.Text } deriving Generic
 instance FromJSON SendText
 instance ToJSON SendText


@@ 150,4 166,6 @@ sendText' input (Element (Name "textarea" _ _) attrs _) cursor session
     | otherwise = return ()
   where attrs' = M.mapKeys nameLocalName attrs
 
-typable (Element (Name n _ _) _ _) = n `elem` ["input", "select", "textarea"]
+isTypableEl cursor | NodeElement el' <- node cursor = isTypableEl' el'
+    | otherwise = False
+isTypableEl' (Element (Name n _ _) _ _) = n `elem` ["input", "select", "textarea"]

@@ 33,8 33,11 @@ mime = words "text/html text/xml application/xml application/xhtml+xml text/plai
 
 load' :: Internal.Session -> URI -> IO ()
 load' session uri = modifyMVar_ session $ \session' -> maybeTimeout session' uri $ do
-    resp@(redirected, _, _) <- fetchURL' (loader session') mime uri
+    putStrLn "a"
+    resp@(redirected, _, _) <- URI.fetchURL' (loader session') mime uri
+    putStrLn "b"
     let doc = parseDocument resp
+    putStrLn "c"
     return $ session' { currentURL = redirected, document = doc,
         knownEls = HM.empty, id2els = HM.fromList $ indexedIDs doc }
 


@@ 46,9 49,9 @@ submit' session (uri, query, method) = modifyMVar_ session $ \session' -> maybeT
         knownEls = HM.empty, id2els = HM.fromList $ indexedIDs doc }
 
 maybeTimeout :: Session' -> URI -> IO Session' -> IO Session'
-maybeTimeout session uri act | currentURL session /= uri, Just delay <- pageLoad $ timeouts session =
-    -- WebDriver deals in terms of milliseconds, I think?, Haskell deals in terms of microseconds.
-    fromMaybe session <$> timeout (delay * 1000) act
+---maybeTimeout session uri act | currentURL session /= uri, Just delay <- pageLoad $ timeouts session =
+---    -- WebDriver deals in terms of milliseconds, I think?, Haskell deals in terms of microseconds.
+---    fromMaybe session <$> timeout (delay * 1000) act
 maybeTimeout _ _ act = act
 
 ---

@@ 3,6 3,8 @@ module Main where
 
 import Happstack.Lite
 import Happstack.Server.RqData
+import Happstack.Server.Monads (askRq)
+import Happstack.Server.Types (rqUri)
 import Control.Concurrent.MVar
 import Data.HashMap.Strict as M
 import Data.FileEmbed


@@ 26,6 28,7 @@ import Happstack.Server.I18N
 import Internal
 import Internal.Load as Load
 import Internal.Elements as El
+import Internal.Forms as Forms
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad (forM)
 


@@ 35,15 38,19 @@ import qualified UI.Search as Q
 main :: IO ()
 main = do
   sessions <- initSessions
-  serve Nothing $ msum [
-      dir "assets" $ path $ ok . toResponse . fromMaybe "Not Found" . flip Prelude.lookup $(embedDir "assets"),
-      dir "webdriver" $ dir "v1" $ serveWebdriver sessions,
-      postHome sessions,
-      serveHome,
-      dir "preview-prompt" servePreviewPrompt,
-      dir "close" $ path $ deleteSession sessions,
-      path $ serveSession sessions
-    ]
+  putStrLn "Serving http://localhost:8000/"
+  serve Nothing $ do
+    req <- askRq
+    liftIO $ putStrLn $ rqUri req
+    msum [
+        dir "assets" $ path $ ok . toResponse . fromMaybe "Not Found" . flip Prelude.lookup $(embedDir "assets"),
+        dir "webdriver" $ dir "v1" $ serveWebdriver sessions,
+        postHome sessions,
+        serveHome,
+        dir "preview-prompt" servePreviewPrompt,
+        dir "close" $ path $ deleteSession sessions,
+        path $ serveSession sessions
+      ]
 
 serveHome :: ServerPart Response
 serveHome = do


@@ 56,12 63,15 @@ serveHome = do
 postHome sessions = do
     nullDir
     method POST
+    liftIO $ putStrLn "Creating new session!"
     (uuid, session) <- liftIO $ createSession sessions M.empty
     target <- looks "target"
     -- Not much point of a blank session, so allow loading here.
+    liftIO $ putStrLn "Allocated new session!"
     case target of
         (target':_) | Just url <- Load.parseAbsoluteURI target' -> liftIO $ Load.load' session url
         _ -> return ()
+    liftIO $ putStrLn "Created new session!"
     seeOther ('/' : ID.toString uuid) $ toResponse ()
 
 deleteSession sessions uuid = do


@@ 91,7 101,8 @@ serveSession = withSession session404 $ \uuid session -> msum [
             dir "next" $ sessionAction' uuid session Load.next
         ],
         dir "el" $ path $ serveEl uuid session,
-        dir "click" $ clickElement uuid session
+        dir "click" $ clickElement uuid session,
+        dir "type" $ typeElement uuid session
     ]
 
 sessionHome uuid session = do


@@ 101,7 112,7 @@ sessionHome uuid session = do
     session' <- liftIO $ readMVar session
     let el = XC.fromDocument $ document session'
     related <- liftIO $ getRelatedEls session el
-    Tpl.inspector ok ":root" session' $ Tpl.elPage uuid el related
+    Tpl.inspector ok ":root" session' $ Tpl.elPage uuid el related ""
 
 session404 uuid = do
     Tpl.page notFound ["404", "Amphiarao"] "" $ \langs -> do


@@ 192,14 203,17 @@ serveEl' uuid session session' el = do
     method GET
     let title = toStrict $ renderMarkup $ contents $ Tpl.xmlNode' $ XC.node el
     related <- liftIO $ getRelatedEls session el
-    Tpl.inspector ok title session' $ Tpl.elPage uuid el related
+    elValue <- liftIO $ Forms.readInput' session el
+    Tpl.inspector ok title session' $ Tpl.elPage uuid el related elValue
 
 serveElPreview uuid session el = do
     nullDir
     method GET
     let title = toStrict $ renderMarkup $ contents $ Tpl.xmlNode' $ XC.node el
     related <- liftIO $ getRelatedEls session el
-    Tpl.page ok [title, Txt.pack $ ID.toString uuid, "Amphiarao"] "fill" $ Tpl.elPage uuid el related
+    elValue <- liftIO $ Forms.readInput' session el
+    Tpl.page ok [title, Txt.pack $ ID.toString uuid, "Amphiarao"] "fill" $
+        Tpl.elPage uuid el related elValue
 
 clickElement uuid session = do
     nullDir


@@ 212,3 226,20 @@ clickElement uuid session = do
             seeOther ('/':ID.toString uuid) $ toResponse ()
         Nothing -> Tpl.inspector notFound "404" session' $ \langs ->
             H.h1 $ l langs ElementNotFound
+
+typeElement uuid session = do
+    nullDir
+    method POST
+    elUUID <- look "el"
+    newValue <- lookText' "text"
+    isReset <- looks "reset"
+    session' <- liftIO $ readMVar session
+    case getEl session' =<< ID.fromString elUUID of
+        Just el | Prelude.null isReset -> do
+            liftIO $ Forms.sendText (Forms.SendText newValue) el session
+            seeOther ('/':ID.toString uuid) $ toResponse ()
+        Just el -> do
+            liftIO $ Forms.clearForm session el
+            seeOther ('/':ID.toString uuid) $ toResponse ()
+        Nothing -> Tpl.inspector notFound "404" session' $ \langs ->
+            H.h1 $ l langs ElementNotFound

@@ 17,7 17,7 @@ data Message =
     PromptPreview |
     ErrURL |
     LinkSearchExact | LinkSearch |
-    Click
+    Click | SetValue | ResetValue
     deriving Show
 
 l :: [Text] -> Message -> Html


@@ 46,6 46,8 @@ l ("en":_) ErrURL = do
 l ("en":_) LinkSearchExact = "Links (Exact)"
 l ("en":_) LinkSearch = "Links"
 l ("en":_) Click = "Click"
+l ("en":_) SetValue = "Set"
+l ("en":_) ResetValue = "Reset"
 ---- End localizations
 l (_:langs) msg = l langs msg
 l [] msg = string $ show msg


@@ 60,7 62,7 @@ data AttrMessage =
     Back' |
     Next' |
     SearchChildren' |
-    Click' deriving Show
+    Click' | EnterValue' deriving Show
 
 l' :: [Text] -> AttrMessage -> AttributeValue
 ---- Begin localization


@@ 74,6 76,7 @@ l' ("en":_) Back' = "Previous inspected page"
 l' ("en":_) Next' = "Next inspected page"
 l' ("en":_) SearchChildren' = "Search Children…"
 l' ("en":_) Click' = "Click"
+l' ("en":_) EnterValue' = "Enter input value"
 ---- End localization
 l' (_:langs) msg = l' langs msg
 l' [] msg = stringValue $ show msg

@@ 10,6 10,7 @@ import Data.Text as Txt
 
 import Internal
 import Internal.Load (isClickableEl)
+import Internal.Forms (isTypableEl, readInput')
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad (unless, when, forM)
 import Control.Concurrent.MVar


@@ 121,7 122,7 @@ elSelector (Element (Name name _ ns) attrs _) = do
             tok val'
         | otherwise = return []
 
-elPage uuid cursor links langs = blockquote $ do
+elPage uuid cursor links elValue langs = blockquote $ do
     nav $ do
         forM (Prelude.reverse $ XC.ancestor cursor) $ \el -> do
             link el $ xmlNode' $ XC.node el -- Should all be elements...


@@ 138,6 139,13 @@ elPage uuid cursor links langs = blockquote $ do
             button $ l langs Click
     link cursor $ p $ xmlNode $ XC.node cursor
     ol $ void $ forM (XC.child cursor) $ \el -> li $ link el $ xmlNode $ XC.node el
+    when (isTypableEl cursor) $ H.form ! target "_top" ! alt (l' langs EnterValue') !
+            action (stringValue ('/':ID.toString uuid ++ "/type")) ! A.method "POST" $ do
+        input ! type_ "hidden" ! name "el" !
+            value (stringValue $ fromMaybe "" $ ID.toString <$> Prelude.lookup (XC.node cursor) links)
+        input ! type_ "text" ! name "text" ! placeholder (l' langs EnterValue') ! value (textValue elValue)
+        button $ l langs SetValue
+        button ! name "reset" $ l langs ResetValue
   where
     link el | Just uuid' <- Prelude.lookup (XC.node el) links =
             a ! target "_top" ! href (stringValue $ href' uuid')

@@ 64,7 64,19 @@ serveSession sessions = WD.withSession fail (\uuid session -> msum [
         dir "element" $ findFromRoot session,
         dir "element" $ dir "active" noSuchEl,
         dir "element" $ path $ serveElement session,
-        dir "elements" $ findAllFromRoot session
+        dir "elements" $ findAllFromRoot session,
+        dir "source" $ viewSource session,
+        dir "execute" $ dir "sync" unsupportedOp,
+        dir "execute" $ dir "async" unsupportedOp,
+        dir "cookie" $ msum [getCookies, addCookie, deleteCookies],
+        dir "cookie" $ path $ \cookie -> msum [getCookie cookie, deleteCookie cookie],
+        dir "actions" unsupportedOp, -- I avoid dealing in terms of mouse/keyboard/touchscreen.
+        dir "alert" $ msum [
+            dir "dismiss" $ handleAlert,
+            dir "accept" $ handleAlert,
+            dir "text" $ alertText
+        ],
+        dir "screenshot" $ unsupportedOp -- Will implement for Haphaestus.
     ]) sessions
   where
     fail uuid'| Just _ <- ID.fromString uuid' = errJSON 404 "invalid session ID" $ (


@@ 223,7 235,8 @@ serveElement session elUUID = do
             dir "rect" $ unsupportedOp, -- Will be meaningful for Haphaestus!
             dir "click" $ actionClickEl session el,
             dir "reset" $ actionResetEl session el,
-            dir "value" $ actionTypeEl session el
+            dir "value" $ actionTypeEl session el,
+            dir "screenshot" unsupportedOp -- Will be meaningful for Haphaestus!
           ]
         Nothing | Nothing <- ID.fromString elUUID ->
             errJSON 404 "no such element" "Invalid UUID"


@@ 302,3 315,44 @@ actionTypeEl session el = do
             liftIO $ WDF.sendText req' el session
             ok $ toResponse ()
         Nothing -> errJSON 400 "invalid argument" "Failed to parse JSON"
+
+viewSource session = do
+    method GET
+    nullDir
+    WD.Session { WD.document = doc } <- liftIO $ readMVar session
+    ok $ toResponse $ X.renderLBS X.def doc
+
+-- TODO Expose cookies from HURL, until then emulate Rhapsodes existing behaviour of not supporting cookies.
+getCookies = do
+    method GET
+    nullDir
+    let res :: [Value] = []
+    okJSON res
+getCookie :: String -> ServerPart Response
+getCookie cookie = do
+    method GET
+    nullDir
+    errJSON 404 "no such cookie" "Cookie access is as yet unsupported"
+addCookie = do
+    method POST
+    nullDir
+    ok $ toResponse ()
+deleteCookie :: String -> ServerPart Response
+deleteCookie cookie = do
+    method DELETE
+    nullDir
+    ok $ toResponse ()
+deleteCookies = do
+    method DELETE
+    nullDir
+    ok $ toResponse ()
+
+-- I don't ever open alerts, they're terrible UX!
+handleAlert = do
+    method POST
+    nullDir
+    errJSON 404 "no such alert" "Rhapsode doesn't open alerts."
+alertText = do
+    method [GET, POST]
+    nullDir
+    errJSON 404 "no such alert" "Rhapsode doesn't open alerts."