diff --git a/src/Web/Api/WebDriver/Endpoints.hs b/src/Web/Api/WebDriver/Endpoints.hs index bfe78fc..6b281e1 100644 --- a/src/Web/Api/WebDriver/Endpoints.hs +++ b/src/Web/Api/WebDriver/Endpoints.hs @@ -57,6 +57,8 @@ module Web.Api.WebDriver.Endpoints ( , switchToWindow -- ** Get Window Handles , getWindowHandles + -- ** New Window + , newWindow -- ** Switch To Frame , switchToFrame -- ** Switch To Parent Frame @@ -519,6 +521,24 @@ getWindowHandles = do >>= (return . map (ContextId . unpack)) +-- | See +newWindow + :: (Monad eff, Monad (t eff), MonadTrans t) + => ContextType -> WebDriverTT t eff (ContextId, ContextType) +newWindow ctxTypeReq = do + baseUrl <- theRemoteUrlWithSession + let !payload = encode $ object [ "type" .= ctxTypeReq ] + response <- httpPost (baseUrl ++ "/window/new") payload + >>= (return . _responseBody) + >>= parseJson + >>= lookupKeyJson "value" + ctxId <- lookupKeyJson "handle" response + >>= constructFromJson + ctxType <- lookupKeyJson "type" response + >>= constructFromJson + return (ctxId, ctxType) + + -- | See . switchToFrame :: (Monad eff, Monad (t eff), MonadTrans t) diff --git a/src/Web/Api/WebDriver/Types.hs b/src/Web/Api/WebDriver/Types.hs index 9f8ee2e..de621c0 100644 --- a/src/Web/Api/WebDriver/Types.hs +++ b/src/Web/Api/WebDriver/Types.hs @@ -18,6 +18,7 @@ module Web.Api.WebDriver.Types ( SessionId , ElementRef(..) , ContextId(..) + , ContextType(..) , Selector , AttributeName , PropertyName @@ -145,6 +146,39 @@ instance Show ContextId where instance IsString ContextId where fromString = ContextId +instance FromJSON ContextId where + parseJSON (String x) = return $ ContextId $ unpack x + parseJSON invalid = typeMismatch "ContextType" invalid + +instance ToJSON ContextId where + toJSON (ContextId x) = String $ pack x + +instance Arbitrary ContextId where + arbitrary = ContextId <$> arbitrary + +-- | Type of a /top level browsing context/; see . +data ContextType = WindowContext | TabContext + deriving (Eq, Enum, Bounded) + +instance Show ContextType where + show t = case t of + WindowContext -> "window" + TabContext -> "tab" + +instance FromJSON ContextType where + parseJSON (String x) = case x of + "window" -> return WindowContext + "tab" -> return TabContext + _ -> unrecognizedValue "ContextType" x + parseJSON invalid = typeMismatch "ContextType" invalid + +instance ToJSON ContextType where + toJSON WindowContext = String "window" + toJSON TabContext = String "tab" + +instance Arbitrary ContextType where + arbitrary = arbitraryBoundedEnum + -- | For use with a /Locator Strategy/. See . type Selector = String diff --git a/test/Web/Api/WebDriver/Monad/Test/Server.hs b/test/Web/Api/WebDriver/Monad/Test/Server.hs index 4d609d7..28cf646 100644 --- a/test/Web/Api/WebDriver/Monad/Test/Server.hs +++ b/test/Web/Api/WebDriver/Monad/Test/Server.hs @@ -159,6 +159,10 @@ defaultWebDriverServer = MockWorld [_,"session",session_id,"window"] -> post_session_id_window session_id payload + {- New Window -} + [_,"session",session_id,"window","new"] -> + post_session_id_window_new session_id payload + {- Switch To Frame -} [_,"session",session_id,"frame"] -> post_session_id_frame session_id payload @@ -453,6 +457,25 @@ post_session_id_window session_id payload = do return _success_with_empty_object +{- New Window -} + +post_session_id_window_new + :: String + -> LB.ByteString + -> MockNetwork WebDriverServerState HttpResponse +post_session_id_window_new session_id payload = do + verifyIsActiveSession session_id + st <- getMockServer + case _load_page "about:blank" st of -- not actually switching contexts here + Nothing -> errorMockNetwork _err_unknown_error + Just _st -> do + modifyMockServer (const _st) + return $ _success_with_value $ object + [ ( "handle", String "handle-id" ) + , ( "type", String "tab" ) + ] + + {- Get Window Handles -} get_session_id_window_handles diff --git a/test/Web/Api/WebDriver/Monad/Test/Server/Page.hs b/test/Web/Api/WebDriver/Monad/Test/Server/Page.hs index e27b306..b44b961 100644 --- a/test/Web/Api/WebDriver/Monad/Test/Server/Page.hs +++ b/test/Web/Api/WebDriver/Monad/Test/Server/Page.hs @@ -12,6 +12,7 @@ module Web.Api.WebDriver.Monad.Test.Server.Page ( , cssMatchDocument , parseCss , tagIsClearable + , pageAboutBlank ) where import Text.ParserCombinators.Parsec @@ -79,6 +80,12 @@ node tag attrs children = let elementId = "" in Document{..} +pageAboutBlank :: Page +pageAboutBlank = Page + { contents = Text "" + , url = "about:blank" + } + assignIds :: String -> Document -> Document assignIds _ h@(Text str) = Text str diff --git a/test/Web/Api/WebDriver/Monad/Test/Server/State.hs b/test/Web/Api/WebDriver/Monad/Test/Server/State.hs index f523c45..1d7cbb3 100644 --- a/test/Web/Api/WebDriver/Monad/Test/Server/State.hs +++ b/test/Web/Api/WebDriver/Monad/Test/Server/State.hs @@ -100,7 +100,9 @@ _load_page path st = do then return _success_page else if file == "invalidElementState.html" then return _invalidElementState_page - else requestPage path (_internets st) + else if file == "about:blank" + then return pageAboutBlank + else requestPage path (_internets st) return $ st { _current_page = p , _history = (_current_page st) : _history st diff --git a/test/Web/Api/WebDriver/Monad/Test/Session/Success.hs b/test/Web/Api/WebDriver/Monad/Test/Session/Success.hs index f0e839e..e0c1384 100644 --- a/test/Web/Api/WebDriver/Monad/Test/Session/Success.hs +++ b/test/Web/Api/WebDriver/Monad/Test/Session/Success.hs @@ -40,6 +40,7 @@ successfulExit buildTestCase dir = , buildTestCase "getWindowHandle" (_test_getWindowHandle_success) , buildTestCase "switchToWindow" (_test_switchToWindow_success) , buildTestCase "getWindowHandles" (_test_getWindowHandles_success path) + , buildTestCase "newWindow" (_test_newWindow_success path) , buildTestCase "switchToFrame" (_test_switchToFrame_success path) , buildTestCase "switchToParentFrame" (_test_switchToParentFrame_success path) , buildTestCase "getWindowRect" (_test_getWindowRect_success) @@ -272,6 +273,23 @@ _test_getWindowHandles_success page = +_test_newWindow_success + :: (Monad eff) => FilePath -> WebDriverT eff () +_test_newWindow_success page = + let + session = do + navigateTo page + (handle, _) <- newWindow TabContext + switchToWindow handle + url <- getCurrentUrl + assertEqual url "about:blank" "default url" + assertSuccess "yay" + return () + + in catchError session unexpectedError + + + _test_switchToFrame_success :: (Monad eff) => FilePath -> WebDriverT eff () _test_switchToFrame_success page = diff --git a/test/Web/Api/WebDriver/Types/Test.hs b/test/Web/Api/WebDriver/Types/Test.hs index d4fe04a..d1d9721 100644 --- a/test/Web/Api/WebDriver/Types/Test.hs +++ b/test/Web/Api/WebDriver/Types/Test.hs @@ -96,6 +96,12 @@ test_fromJson_toJson_id = testGroup "fromJSON . toJSON == id" , QC.testProperty "(ResponseErrorCode) fromJSON . toJSON == id" $ (prop_fromJson_toJson_id :: ResponseErrorCode -> Bool) + + , QC.testProperty "(ContextId) fromJSON . toJSON == id" $ + (prop_fromJson_toJson_id :: ContextId -> Bool) + + , QC.testProperty "(ContextType) fromJSON . toJSON == id" $ + (prop_fromJson_toJson_id :: ContextType -> Bool) ]