Add newWindow endpoint

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 <https://w3c.github.io/webdriver/webdriver-spec.html#new-window>
+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 <https://w3c.github.io/webdriver/webdriver-spec.html#switch-to-frame>.
 switchToFrame
   :: (Monad eff, Monad (t eff), MonadTrans t)

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 <https://html.spec.whatwg.org/#top-level-browsing-context>.
+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 <https://w3c.github.io/webdriver/webdriver-spec.html#locator-strategies>.
 type Selector = String
 

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

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

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

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)
@@ -283,6 +284,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 =

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)
   ]