{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-deriving-typeable #-}

{-# OPTIONS_HADDOCK not-home #-}
-- | Internal functions used to implement the functions exported by
-- "Test.WebDriver.Commands". These may be useful for implementing non-standard
-- webdriver commands.
module Test.WebDriver.Util.Commands (
  -- * Low-level webdriver functions
  doCommand
  -- ** Commands with :sessionId URL parameter
  , doSessCommand
  , SessionId(..)
  -- ** Commands with element :id URL parameters
  , doElemCommand
  , Element(..)
  -- ** Commands with :windowHandle URL parameters
  , WindowHandle(..)

  -- * Helpers
  , urlEncode
  ) where

import Control.Applicative
import Control.Monad.IO.Class
import Data.Aeson
import Data.Aeson.TH
import Data.Aeson.Types
import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Lazy.Char8 (ByteString)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding as TE
import GHC.Stack
import Network.HTTP.Client (Response(..))
import Network.HTTP.Types.Header
import Network.HTTP.Types.Status (Status(..))
import qualified Network.HTTP.Types.URI as HTTP
import Prelude -- hides some "unused import" warnings
import Test.WebDriver.Capabilities.Aeson
import Test.WebDriver.Exceptions
import Test.WebDriver.JSON
import Test.WebDriver.Types
import Test.WebDriver.Util.Aeson
import UnliftIO.Exception


data SuccessResponse a = SuccessResponse {
  forall a. SuccessResponse a -> a
successValue :: a
  }
deriveFromJSON toCamel1 ''SuccessResponse

-- | An opaque identifier for a web page element
newtype Element = Element Text
  deriving (Element -> Element -> Bool
(Element -> Element -> Bool)
-> (Element -> Element -> Bool) -> Eq Element
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Element -> Element -> Bool
== :: Element -> Element -> Bool
$c/= :: Element -> Element -> Bool
/= :: Element -> Element -> Bool
Eq, Eq Element
Eq Element =>
(Element -> Element -> Ordering)
-> (Element -> Element -> Bool)
-> (Element -> Element -> Bool)
-> (Element -> Element -> Bool)
-> (Element -> Element -> Bool)
-> (Element -> Element -> Element)
-> (Element -> Element -> Element)
-> Ord Element
Element -> Element -> Bool
Element -> Element -> Ordering
Element -> Element -> Element
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Element -> Element -> Ordering
compare :: Element -> Element -> Ordering
$c< :: Element -> Element -> Bool
< :: Element -> Element -> Bool
$c<= :: Element -> Element -> Bool
<= :: Element -> Element -> Bool
$c> :: Element -> Element -> Bool
> :: Element -> Element -> Bool
$c>= :: Element -> Element -> Bool
>= :: Element -> Element -> Bool
$cmax :: Element -> Element -> Element
max :: Element -> Element -> Element
$cmin :: Element -> Element -> Element
min :: Element -> Element -> Element
Ord, Int -> Element -> ShowS
[Element] -> ShowS
Element -> String
(Int -> Element -> ShowS)
-> (Element -> String) -> ([Element] -> ShowS) -> Show Element
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Element -> ShowS
showsPrec :: Int -> Element -> ShowS
$cshow :: Element -> String
show :: Element -> String
$cshowList :: [Element] -> ShowS
showList :: [Element] -> ShowS
Show, ReadPrec [Element]
ReadPrec Element
Int -> ReadS Element
ReadS [Element]
(Int -> ReadS Element)
-> ReadS [Element]
-> ReadPrec Element
-> ReadPrec [Element]
-> Read Element
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Element
readsPrec :: Int -> ReadS Element
$creadList :: ReadS [Element]
readList :: ReadS [Element]
$creadPrec :: ReadPrec Element
readPrec :: ReadPrec Element
$creadListPrec :: ReadPrec [Element]
readListPrec :: ReadPrec [Element]
Read)

instance FromJSON Element where
  parseJSON :: Value -> Parser Element
parseJSON (Object Object
o) = case ((Key, Value) -> Value) -> [(Key, Value)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key, Value) -> Value
forall a b. (a, b) -> b
snd (Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
aesonToList Object
o) of
    (String Text
id' : [Value]
_) -> Element -> Parser Element
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Element -> Parser Element) -> Element -> Parser Element
forall a b. (a -> b) -> a -> b
$ Text -> Element
Element Text
id'
    [Value]
_ -> String -> Parser Element
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"No elements returned"
  parseJSON Value
v = String -> Value -> Parser Element
forall a. String -> Value -> Parser a
typeMismatch String
"Element" Value
v

instance ToJSON Element where
  toJSON :: Element -> Value
toJSON (Element Text
e) = [(Key, Value)] -> Value
object [Key
"element-6066-11e4-a52e-4f735466cecf" Key -> Text -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
e]


-- | An opaque identifier for a browser window
newtype WindowHandle = WindowHandle Text
  deriving (WindowHandle -> WindowHandle -> Bool
(WindowHandle -> WindowHandle -> Bool)
-> (WindowHandle -> WindowHandle -> Bool) -> Eq WindowHandle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WindowHandle -> WindowHandle -> Bool
== :: WindowHandle -> WindowHandle -> Bool
$c/= :: WindowHandle -> WindowHandle -> Bool
/= :: WindowHandle -> WindowHandle -> Bool
Eq, Eq WindowHandle
Eq WindowHandle =>
(WindowHandle -> WindowHandle -> Ordering)
-> (WindowHandle -> WindowHandle -> Bool)
-> (WindowHandle -> WindowHandle -> Bool)
-> (WindowHandle -> WindowHandle -> Bool)
-> (WindowHandle -> WindowHandle -> Bool)
-> (WindowHandle -> WindowHandle -> WindowHandle)
-> (WindowHandle -> WindowHandle -> WindowHandle)
-> Ord WindowHandle
WindowHandle -> WindowHandle -> Bool
WindowHandle -> WindowHandle -> Ordering
WindowHandle -> WindowHandle -> WindowHandle
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: WindowHandle -> WindowHandle -> Ordering
compare :: WindowHandle -> WindowHandle -> Ordering
$c< :: WindowHandle -> WindowHandle -> Bool
< :: WindowHandle -> WindowHandle -> Bool
$c<= :: WindowHandle -> WindowHandle -> Bool
<= :: WindowHandle -> WindowHandle -> Bool
$c> :: WindowHandle -> WindowHandle -> Bool
> :: WindowHandle -> WindowHandle -> Bool
$c>= :: WindowHandle -> WindowHandle -> Bool
>= :: WindowHandle -> WindowHandle -> Bool
$cmax :: WindowHandle -> WindowHandle -> WindowHandle
max :: WindowHandle -> WindowHandle -> WindowHandle
$cmin :: WindowHandle -> WindowHandle -> WindowHandle
min :: WindowHandle -> WindowHandle -> WindowHandle
Ord, Int -> WindowHandle -> ShowS
[WindowHandle] -> ShowS
WindowHandle -> String
(Int -> WindowHandle -> ShowS)
-> (WindowHandle -> String)
-> ([WindowHandle] -> ShowS)
-> Show WindowHandle
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WindowHandle -> ShowS
showsPrec :: Int -> WindowHandle -> ShowS
$cshow :: WindowHandle -> String
show :: WindowHandle -> String
$cshowList :: [WindowHandle] -> ShowS
showList :: [WindowHandle] -> ShowS
Show, ReadPrec [WindowHandle]
ReadPrec WindowHandle
Int -> ReadS WindowHandle
ReadS [WindowHandle]
(Int -> ReadS WindowHandle)
-> ReadS [WindowHandle]
-> ReadPrec WindowHandle
-> ReadPrec [WindowHandle]
-> Read WindowHandle
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS WindowHandle
readsPrec :: Int -> ReadS WindowHandle
$creadList :: ReadS [WindowHandle]
readList :: ReadS [WindowHandle]
$creadPrec :: ReadPrec WindowHandle
readPrec :: ReadPrec WindowHandle
$creadListPrec :: ReadPrec [WindowHandle]
readListPrec :: ReadPrec [WindowHandle]
Read, Maybe WindowHandle
Value -> Parser [WindowHandle]
Value -> Parser WindowHandle
(Value -> Parser WindowHandle)
-> (Value -> Parser [WindowHandle])
-> Maybe WindowHandle
-> FromJSON WindowHandle
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser WindowHandle
parseJSON :: Value -> Parser WindowHandle
$cparseJSONList :: Value -> Parser [WindowHandle]
parseJSONList :: Value -> Parser [WindowHandle]
$comittedField :: Maybe WindowHandle
omittedField :: Maybe WindowHandle
FromJSON, [WindowHandle] -> Value
[WindowHandle] -> Encoding
WindowHandle -> Bool
WindowHandle -> Value
WindowHandle -> Encoding
(WindowHandle -> Value)
-> (WindowHandle -> Encoding)
-> ([WindowHandle] -> Value)
-> ([WindowHandle] -> Encoding)
-> (WindowHandle -> Bool)
-> ToJSON WindowHandle
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: WindowHandle -> Value
toJSON :: WindowHandle -> Value
$ctoEncoding :: WindowHandle -> Encoding
toEncoding :: WindowHandle -> Encoding
$ctoJSONList :: [WindowHandle] -> Value
toJSONList :: [WindowHandle] -> Value
$ctoEncodingList :: [WindowHandle] -> Encoding
toEncodingList :: [WindowHandle] -> Encoding
$comitField :: WindowHandle -> Bool
omitField :: WindowHandle -> Bool
ToJSON)

-- | This a convenient wrapper around 'doCommand' that automatically prepends
-- the session URL parameter to the wire command URL. For example, passing
-- a URL of \"/refresh\" will expand to \"/session/:sessionId/refresh\", where
-- :sessionId is a URL parameter as described in
-- <https://github.com/SeleniumHQ/selenium/wiki/JsonWireProtocol>
doSessCommand :: (
  HasCallStack, WebDriver wd, ToJSON a, FromJSON b
  ) => Method -> Text -> a -> wd b
doSessCommand :: forall (wd :: * -> *) a b.
(HasCallStack, WebDriver wd, ToJSON a, FromJSON b) =>
Method -> Text -> a -> wd b
doSessCommand Method
method Text
path a
args = do
  Session { sessionId :: Session -> SessionId
sessionId = SessionId Text
sId } <- wd Session
forall (m :: * -> *). SessionState m => m Session
getSession
  -- Catch BadJSON exceptions here, since most commands go through this function.
  -- Then, re-throw them with "error", which automatically appends a callstack
  -- to the message in modern GHCs.
  -- This callstack makes it easy to see which command caused the BadJSON exception,
  -- without exposing too many internals.
  wd b -> (BadJSON -> wd b) -> wd b
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
    (Method -> Text -> a -> wd b
forall (wd :: * -> *) a b.
(HasCallStack, WebDriver wd, ToJSON a, FromJSON b) =>
Method -> Text -> a -> wd b
doCommand Method
method ([Text] -> Text
T.concat [Text
"/session/", Text -> Text
urlEncode Text
sId, Text
path]) a
args)
    (\(BadJSON
e :: BadJSON) -> String -> wd b
forall a. HasCallStack => String -> a
error (String -> wd b) -> String -> wd b
forall a b. (a -> b) -> a -> b
$ BadJSON -> String
forall a. Show a => a -> String
show BadJSON
e)

-- | A wrapper around 'doSessCommand' to create element URLs.
-- For example, passing a URL of "/active" will expand to
-- \"/session/:sessionId/element/:id/active\", where :sessionId and :id are URL
-- parameters as described in the wire protocol.
doElemCommand :: (
  HasCallStack, WebDriver wd, ToJSON a, FromJSON b
  ) => Method -> Element -> Text -> a -> wd b
doElemCommand :: forall (wd :: * -> *) a b.
(HasCallStack, WebDriver wd, ToJSON a, FromJSON b) =>
Method -> Element -> Text -> a -> wd b
doElemCommand Method
m (Element Text
e) Text
path a
a =
  Method -> Text -> a -> wd b
forall (wd :: * -> *) a b.
(HasCallStack, WebDriver wd, ToJSON a, FromJSON b) =>
Method -> Text -> a -> wd b
doSessCommand Method
m ([Text] -> Text
T.concat [Text
"/element/", Text -> Text
urlEncode Text
e, Text
path]) a
a

urlEncode :: Text -> Text
urlEncode :: Text -> Text
urlEncode = Method -> Text
TE.decodeUtf8 (Method -> Text) -> (Text -> Method) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Method -> Method
HTTP.urlEncode Bool
False (Method -> Method) -> (Text -> Method) -> Text -> Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Method
TE.encodeUtf8

-- | Parse a 'FailedCommand' object from a given HTTP response.
getJSONResult :: (MonadIO m, FromJSON a) => Response ByteString -> m (Either SomeException a)
getJSONResult :: forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Response ByteString -> m (Either SomeException a)
getJSONResult Response ByteString
r
  | Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
400 Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
600 =
      case HeaderName -> [(HeaderName, Method)] -> Maybe Method
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType [(HeaderName, Method)]
headers of
        Just Method
ct
          | Method
"application/json" Method -> Method -> Bool
`BS.isInfixOf` Method
ct -> do
              SuccessResponse {FailedCommand
successValue :: forall a. SuccessResponse a -> a
successValue :: FailedCommand
..} :: SuccessResponse FailedCommand <- ByteString -> m (SuccessResponse FailedCommand)
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
ByteString -> m a
parseJSON' ByteString
body
              FailedCommand -> m (Either SomeException a)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO FailedCommand
successValue
          | Bool
otherwise ->
              Either SomeException a -> m (Either SomeException a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException a -> m (Either SomeException a))
-> Either SomeException a -> m (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ SomeException -> Either SomeException a
forall a b. a -> Either a b
Left (SomeException -> Either SomeException a)
-> SomeException -> Either SomeException a
forall a b. (a -> b) -> a -> b
$ ServerError -> SomeException
forall e. Exception e => e -> SomeException
toException (ServerError -> SomeException) -> ServerError -> SomeException
forall a b. (a -> b) -> a -> b
$ String -> ServerError
ServerError String
reason
        Maybe Method
Nothing ->
          Either SomeException a -> m (Either SomeException a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException a -> m (Either SomeException a))
-> Either SomeException a -> m (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ SomeException -> Either SomeException a
forall a b. a -> Either a b
Left (SomeException -> Either SomeException a)
-> SomeException -> Either SomeException a
forall a b. (a -> b) -> a -> b
$ ServerError -> SomeException
forall e. Exception e => e -> SomeException
toException (ServerError -> SomeException) -> ServerError -> SomeException
forall a b. (a -> b) -> a -> b
$ String -> ServerError
ServerError (String
"HTTP response missing content type. Server reason was: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
reason)
  | Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
200 Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
300 = do
      SuccessResponse {a
successValue :: forall a. SuccessResponse a -> a
successValue :: a
successValue} <- ByteString -> m (SuccessResponse a)
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
ByteString -> m a
parseJSON' ByteString
body
      Either SomeException a -> m (Either SomeException a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException a -> m (Either SomeException a))
-> Either SomeException a -> m (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ a -> Either SomeException a
forall a b. b -> Either a b
Right a
successValue
  | Bool
otherwise = Either SomeException a -> m (Either SomeException a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException a -> m (Either SomeException a))
-> Either SomeException a -> m (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ SomeException -> Either SomeException a
forall a b. a -> Either a b
Left (SomeException -> Either SomeException a)
-> SomeException -> Either SomeException a
forall a b. (a -> b) -> a -> b
$ HTTPStatusUnknown -> SomeException
forall e. Exception e => e -> SomeException
toException (HTTPStatusUnknown -> SomeException)
-> HTTPStatusUnknown -> SomeException
forall a b. (a -> b) -> a -> b
$ (Int -> String -> HTTPStatusUnknown
HTTPStatusUnknown Int
code) String
reason
  where
    code :: Int
code = Status -> Int
statusCode Status
status
    reason :: String
reason = Method -> String
BS.unpack (Method -> String) -> Method -> String
forall a b. (a -> b) -> a -> b
$ Status -> Method
statusMessage Status
status
    status :: Status
status = Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
r
    body :: ByteString
body = Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
r
    headers :: [(HeaderName, Method)]
headers = Response ByteString -> [(HeaderName, Method)]
forall body. Response body -> [(HeaderName, Method)]
responseHeaders Response ByteString
r


doCommand :: (
  HasCallStack, WebDriver m, ToJSON a, FromJSON b
  )
  -- | HTTP request method
  => Method
  -- | URL of request
  -> Text
  -- | JSON parameters passed in the body of the request. Note that, as a
  -- special case, anything that converts to Data.Aeson.Null will result in an
  -- empty request body.
  -> a
  -- | The JSON result of the HTTP request.
  -> m b
doCommand :: forall (wd :: * -> *) a b.
(HasCallStack, WebDriver wd, ToJSON a, FromJSON b) =>
Method -> Text -> a -> wd b
doCommand Method
method Text
url a
params = do
  Session {Driver
sessionDriver :: Driver
sessionDriver :: Session -> Driver
sessionDriver} <- m Session
forall (m :: * -> *). SessionState m => m Session
getSession
  Driver -> Method -> Text -> a -> m (Response ByteString)
forall a.
(HasCallStack, ToJSON a) =>
Driver -> Method -> Text -> a -> m (Response ByteString)
forall (m :: * -> *) a.
(WebDriverBase m, HasCallStack, ToJSON a) =>
Driver -> Method -> Text -> a -> m (Response ByteString)
doCommandBase Driver
sessionDriver Method
method Text
url a
params
    m (Response ByteString)
-> (Response ByteString -> m (Either SomeException b))
-> m (Either SomeException b)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response ByteString -> m (Either SomeException b)
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Response ByteString -> m (Either SomeException a)
getJSONResult
    m (Either SomeException b)
-> (Either SomeException b -> m b) -> m b
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> m b)
-> (b -> m b) -> Either SomeException b -> m b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> m b
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO b -> m b
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return