5 files changed, 104 insertions(+), 9 deletions(-)

M amphiarao.cabal
M src/Internal.hs
M src/Internal/Forms.hs
M src/Internal/Load.hs
M src/Webdriver.hs

@@ 71,7 71,7 @@ executable amphiarao
         -- For HTML UIs
         blaze-html, blaze-markup,
         -- Network input
-        hurl >= 2.1 && <3, network-uri,
+        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,
         attoparsec, time

@@ 20,6 20,7 @@ import qualified Network.URI.Fetch as URI
 import qualified Text.XML as XML
 import qualified Text.XML.Cursor as XML
 import qualified Data.Map as M'
+import qualified Network.HTTP.Client.MultipartFormData as HTTP
 
 type Sessions = MVar (M.HashMap UUID Session)
 type Session = MVar Session'


@@ 33,6 34,7 @@ data Session' = Session {
     document :: XML.Document,
     knownEls :: M.HashMap UUID XML.Cursor,
     forms :: M'.Map XML.Element (M.HashMap Text [Text]),
+    multipartForms :: M'.Map XML.Element [HTTP.Part],
     id2els :: M.HashMap Text XML.Cursor
   }
 


@@ 61,7 63,7 @@ createSession sessions caps = do
             XML.documentEpilogue = []
         },
         knownEls = M.empty,
-        forms = M'.empty,
+        forms = M'.empty, multipartForms = M'.empty,
         id2els = M.empty
       }
     session' <- newMVar session

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


@@ 7,12 7,17 @@ import qualified Data.Map as M
 import qualified Data.HashMap.Strict as HM
 import qualified Data.Text as Txt
 
-import Internal (Session, Session'(..))
 import Network.URI (URI(..), parseURIReference, relativeTo, nullURI)
+import qualified Network.HTTP.Client.MultipartFormData as HTTP
 
-import Data.Maybe
+import Internal (Session, Session'(..))
+import Data.Aeson
+import GHC.Generics
 import Control.Concurrent.MVar
 
+import Data.Maybe
+import Data.List
+
 findForm :: Cursor -> HM.HashMap Txt.Text Cursor -> Element
 findForm cursor id2els
     | NodeElement el@(Element (Name "form" _ _) _ _) <- node cursor = el


@@ 98,4 103,51 @@ formAction el session = withMVar session $ \session' -> do
         (_, Just method) -> method;
         (_, _) -> "GET"
     }
+
     return (fromMaybe nullURI action `relativeTo` currentURL session', query, method)
+
+clearForm session el = modifyMVar_ session $ \session' -> do
+    let form = findForm el $ id2els session'
+    return $ case form of
+        Element (Name "form" _ _) _ _ ->
+            session' { forms = M.delete form $ forms session' }
+        _ -> session'
+
+data SendText = SendText { text :: Txt.Text } deriving Generic
+instance FromJSON SendText
+instance ToJSON SendText
+
+sendText input cursor session
+    | NodeElement el <- node cursor = sendText' input el cursor session
+    | otherwise = return ()
+sendText' input (Element (Name "input" _ _) attrs _) cursor session
+--    | Just "file" <- "type" `M.lookup` attrs' = return ()-- TODO define a place in HURL to store files to be uploaded...
+    | Just "radio" <- "type" `M.lookup` attrs', Just value <- "value" `M.lookup` attrs',
+        Just name <- "name" `M.lookup` attrs' = modifyForm (const [value]) name cursor session
+    | Just "checkbox" <- "type" `M.lookup` attrs', Just value <- "value" `M.lookup` attrs',
+        Just name <- "name" `M.lookup` attrs' = modifyForm (toggleOption value) name cursor session
+    | Just name <- "name" `M.lookup` attrs' = modifyForm (const [text input]) name cursor session
+    | otherwise = return ()
+  where
+    attrs' = M.mapKeys nameLocalName attrs
+    toggleOption value old | value `elem` old = delete value old
+        | otherwise = value:old
+sendText' input (Element (Name "select" _ _) attrs childs) cursor session
+    | Just name <- "name" `M.lookup` attrs', "multiple" `M.member` attrs' =
+        let value = mapMaybe findOption $ Txt.lines $ text input
+        in modifyForm (const value) name cursor session
+    | Just name <- "name" `M.lookup` attrs', Just value <- findOption $ text input =
+        modifyForm (const [value]) name cursor session
+    | otherwise = return ()
+  where
+    attrs' = M.mapKeys nameLocalName attrs
+    findOption prefix = (M.lookup "value" . M.mapKeys nameLocalName . elementAttributes) =<<
+        find (Txt.isPrefixOf prefix . innerText) [
+            el | NodeElement el@(Element (Name "option" _ _) _ _) <- childs]
+    innerText (Element _ _ childs) = Txt.concat [txt | NodeContent txt <- childs]
+sendText' input (Element (Name "textarea" _ _) attrs _) cursor session
+    | Just name <- "name" `M.lookup` attrs' = modifyForm (const [text input]) name cursor session
+    | otherwise = return ()
+  where attrs' = M.mapKeys nameLocalName attrs
+
+typable (Element (Name n _ _) _ _) = n `elem` ["input", "select", "textarea"]

@@ 38,6 38,13 @@ load' session uri = modifyMVar_ session $ \session' -> maybeTimeout session' uri
     return $ session' { currentURL = redirected, document = doc,
         knownEls = HM.empty, id2els = HM.fromList $ indexedIDs doc }
 
+submit' :: Internal.Session -> (URI, Txt.Text, Txt.Text) -> IO ()
+submit' session (uri, query, method) = modifyMVar_ session $ \session' -> maybeTimeout session' uri $ do
+    resp@(redirected, _, _) <- submitURL (loader session') mime uri method $ Txt.unpack query
+    let doc = parseDocument resp
+    return $ session' { currentURL = redirected, document = doc,
+        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.


@@ 54,6 61,14 @@ load session uri = do
     inner session'@Session {backStack = backStack', currentURL = currentURL' } =
         session' { backStack = currentURL' : backStack' }
 
+submit :: Internal.Session -> (URI, Txt.Text, Txt.Text) -> IO ()
+submit session form = do
+    modifyMVar_ session $ return . inner
+    submit' session form
+  where
+    inner session'@Session {backStack = backStack', currentURL = currentURL' } =
+        session' { backStack = currentURL' : backStack' }
+
 back :: Internal.Session -> IO ()
 back session = do
     uri <- modifyMVar session $ return . inner


@@ 179,8 194,8 @@ clickEl' session (XML.Element (XML.Name name _ _) attrs _) cursor
         case ("name" `M.lookup` attrs', "value" `M.lookup` attrs') of
             (Just name, Just value) -> modifyForm ((:) value) name cursor session
             _ -> return ()
-        (uri, query, method) <- formAction cursor session
-        load session uri { uriQuery = '?':Txt.unpack query }
+        form <- formAction cursor session
+        submit session form
     | name `elem` ["button", "input"], Just "reset" <- "type" `M.lookup` attrs' =
       modifyMVar_ session $ \session' -> do
         let form = findForm cursor $ id2els session'

@@ 29,6 29,7 @@ import JSON
 import qualified Internal as WD
 import qualified Internal.Load as WD
 import qualified Internal.Elements as WDE
+import qualified Internal.Forms as WDF
 
 serveWebdriver :: WD.Sessions -> ServerPart Response
 serveWebdriver sessions = do


@@ 219,7 220,10 @@ serveElement session elUUID = do
             -- TODO integrate CSS
             dir "text" $ getElText el,
             dir "name" $ getElName el,
-            dir "rect" $ unsupportedOp -- Will be meaningful for Haphaestus!
+            dir "rect" $ unsupportedOp, -- Will be meaningful for Haphaestus!
+            dir "click" $ actionClickEl session el,
+            dir "reset" $ actionResetEl session el,
+            dir "value" $ actionTypeEl session el
           ]
         Nothing | Nothing <- ID.fromString elUUID ->
             errJSON 404 "no such element" "Invalid UUID"


@@ 276,3 280,25 @@ getElName el = do
 
 name2text (X.Name name _ (Just prefix)) = Txt.concat [prefix, ":", name]
 name2text (X.Name name _ Nothing) = name
+
+actionClickEl session el = do
+    method POST
+    nullDir
+    liftIO $ WD.clickEl session el
+    ok $ toResponse ()
+
+actionResetEl session el = do
+    method POST
+    nullDir
+    liftIO $ WDF.clearForm session el
+    ok $ toResponse ()
+
+actionTypeEl session el = do
+    method POST
+    nullDir
+    req <- getJSON
+    case req of
+        Just req' -> do
+            liftIO $ WDF.sendText req' el session
+            ok $ toResponse ()
+        Nothing -> errJSON 400 "invalid argument" "Failed to parse JSON"