408 lines
13 KiB
Factor
408 lines
13 KiB
Factor
USING: kernel accessors urls parser effects.parser words arrays sequences quotations json formatting assocs namespaces present hashtables words.symbol combinators lexer calendar prettyprint.backend base64 images.png destructors math.parser threads continuations ;
|
|
USING: http http.client http.server ;
|
|
USING: libc classes ;
|
|
USING: io io.sockets io.streams.byte-array io.pathnames io.encodings.binary io.encodings.string io.encodings.utf8 io.launcher ;
|
|
|
|
USING: prettyprint ;
|
|
|
|
IN: web-driver
|
|
|
|
! https://www.w3.org/TR/webdriver/#elements
|
|
CONSTANT: web-element-identifier "element-6066-11e4-a52e-4f735466cecf"
|
|
|
|
CONSTANT: css-location-strategy "css selector"
|
|
CONSTANT: link-text-location-strategy "link text"
|
|
CONSTANT: partial-link-text-location-strategy "partial link text"
|
|
CONSTANT: tag-name-location-strategy "tag name"
|
|
CONSTANT: xpath-location-strategy "xpath"
|
|
|
|
SYMBOLS: current-web-driver current-web-driver-session ;
|
|
|
|
TUPLE: web-driver process remote-url ;
|
|
TUPLE: web-driver-session session-id capabilities ;
|
|
TUPLE: session-status message ready? ;
|
|
|
|
: current-web-driver-session> ( -- session )
|
|
current-web-driver-session get ;
|
|
: current-session-id> ( -- session-id )
|
|
current-web-driver-session> session-id>> ;
|
|
: current-session-relative-url ( -- url )
|
|
"session" current-session-id> append-path >url ;
|
|
: current-remote-url ( -- url )
|
|
current-web-driver get remote-url>> ;
|
|
: current-session-url ( -- url )
|
|
current-remote-url current-session-relative-url derive-url ;
|
|
: <web-driver-url> ( path -- url )
|
|
[ current-remote-url ] dip >url derive-url ;
|
|
|
|
: <web-driver-session-url> ( path -- url )
|
|
[ current-session-url present ] dip append-path >url ;
|
|
|
|
: <web-driver-element-url> ( path id -- url )
|
|
swap append-path
|
|
[ "element" <web-driver-session-url> present ] dip append-path >url ;
|
|
|
|
: <web-driver-post-data> ( hashtable -- post-data )
|
|
"application/json" <post-data> swap
|
|
[ >json utf8 encode ] [ B{ 123 125 } ] if* >>data ;
|
|
|
|
: <web-driver-get-request> ( path -- request )
|
|
<web-driver-url> <get-request> ;
|
|
|
|
: <web-driver-post-request> ( data path -- request )
|
|
[ <web-driver-post-data> ] dip <web-driver-url> <post-request> ;
|
|
|
|
: <web-driver-delete-request> ( path -- request )
|
|
<web-driver-url> <delete-request> ;
|
|
|
|
: <session-post-request> ( data path -- request )
|
|
[ <web-driver-post-data> ] dip <web-driver-session-url> <post-request> ;
|
|
|
|
: <session-get-request> ( path -- request )
|
|
<web-driver-session-url> <get-request> ;
|
|
|
|
: <session-delete-request> ( path -- request )
|
|
<web-driver-session-url> <delete-request> ;
|
|
|
|
: <element-get-request> ( element path -- request )
|
|
swap id>> <web-driver-element-url> <get-request> ;
|
|
|
|
: <element-post-request> ( element data path -- request )
|
|
swap [ swap id>> <web-driver-element-url> ] dip <web-driver-post-data> swap <post-request> ;
|
|
|
|
: http-web-driver-request ( request -- data )
|
|
http-request nip json> "value" of ;
|
|
|
|
! Capabilities
|
|
! https://www.w3.org/webdriver/#capabilities
|
|
TUPLE: capabilities { always-match hashtable } { first-match sequence } ;
|
|
|
|
: <capabilities> ( always-match first-match -- capabilities )
|
|
[ [ H{ } ] unless* ]
|
|
[ [ { } ] unless* ] bi*
|
|
capabilities boa ;
|
|
|
|
: <no-capabilities> ( -- capabilities )
|
|
f f <capabilities> ;
|
|
|
|
: capabilities>json ( capabilities -- string )
|
|
[ always-match>> ] [ first-match>> ] bi
|
|
'H{ { "alwaysMatch" _ } { "firstMatch" _ } } 'H{ { "capabilities" _ } } ;
|
|
|
|
: <headless-firefox-capabilities> ( -- hash )
|
|
H{
|
|
{ "moz:firefoxOptions" H{ { "args" { "-headless" } } } }
|
|
} f <capabilities> capabilities>json ;
|
|
|
|
! Timeouts
|
|
! https://www.w3.org/TR/webdriver/#timeouts
|
|
|
|
TUPLE: timeouts
|
|
{ script initial: 30000 }
|
|
{ page-load initial: 300000 }
|
|
{ implicit initial: 0 } ;
|
|
|
|
: get-timeouts ( -- timeouts )
|
|
"timeouts" <session-get-request> http-web-driver-request
|
|
[ "script" of ] [ "pageload" of ] [ "implicit" of ] tri
|
|
timeouts boa ;
|
|
|
|
: set-timeouts ( timeouts -- )
|
|
[ script>> ] [ page-load>> ] [ implicit>> ] tri
|
|
'H{ { "script" _ } { "pageLoad" _ } { "implicit" _ } }
|
|
"timeouts" <session-post-request> http-web-driver-request drop ;
|
|
|
|
! Navigation
|
|
! https://www.w3.org/TR/webdriver/#navigation
|
|
|
|
: get-current-url ( -- url )
|
|
"url" <session-get-request> http-web-driver-request >url ;
|
|
|
|
: navigate-to ( url -- )
|
|
present 'H{ { "url" _ } } "url" <session-post-request> http-web-driver-request drop ;
|
|
|
|
: back ( -- )
|
|
f "back" <session-post-request> http-web-driver-request drop ;
|
|
|
|
: refresh ( -- )
|
|
f "refresh" <session-post-request> http-web-driver-request drop ;
|
|
|
|
: title ( -- title )
|
|
"title" <session-get-request> http-web-driver-request ;
|
|
|
|
! elements
|
|
|
|
TUPLE: web-element id ;
|
|
C: <web-element> web-element
|
|
|
|
: <locator> ( using value -- hashtable )
|
|
'H{ { "value" _ } { "using" _ } } ;
|
|
|
|
: <css-locator> ( value -- hashtable )
|
|
css-location-strategy <locator> ;
|
|
|
|
: <link-text-locator> ( value -- hashtable )
|
|
link-text-location-strategy <locator> ;
|
|
|
|
: <partial-link-text-locator> ( value -- hashtable )
|
|
partial-link-text-location-strategy <locator> ;
|
|
|
|
: <tag-name-locator> ( value -- hashtable )
|
|
tag-name-location-strategy <locator> ;
|
|
|
|
: <xpath-locator> ( value -- hashtable )
|
|
xpath-location-strategy <locator> ;
|
|
|
|
: find-element ( locator -- element )
|
|
"element" <session-post-request> http-web-driver-request
|
|
web-element-identifier of <web-element> ;
|
|
|
|
: find-elements ( locator -- element )
|
|
"elements" <session-post-request> http-web-driver-request
|
|
[ web-element-identifier of <web-element> ] map ;
|
|
|
|
|
|
! TODO: finish the element by definitions
|
|
! clean up a little
|
|
<<
|
|
SYNTAX: DEFINE-LOCATORS:
|
|
scan-token
|
|
{
|
|
[
|
|
[ "find-element" prepend-path create-word-in ]
|
|
[ "-locator" append "<" ">" surround parse-word 1quotation [ find-element ] compose ( value -- element ) ] bi
|
|
define-declared
|
|
]
|
|
[
|
|
[ "find-elements" prepend-path create-word-in ]
|
|
[ "-locator" append "<" ">" surround parse-word 1quotation [ find-elements ] compose ( value -- seq ) ] bi
|
|
define-declared
|
|
]
|
|
} cleave ;
|
|
>>
|
|
|
|
DEFINE-LOCATORS: css
|
|
DEFINE-LOCATORS: link-text
|
|
DEFINE-LOCATORS: partial-link-text
|
|
DEFINE-LOCATORS: tag-name
|
|
DEFINE-LOCATORS: xpath
|
|
|
|
! some helper css locators
|
|
|
|
: maybe-prepend ( string char -- string' )
|
|
2dup [ first ] bi@ = [ drop ] [ prepend ] if ;
|
|
|
|
: find-element-by-id ( id -- element )
|
|
"#" maybe-prepend find-element/css ;
|
|
|
|
: find-elements-by-id ( id -- element )
|
|
"#" maybe-prepend find-elements/css ;
|
|
|
|
: find-element-by-class-name ( name -- element )
|
|
"." maybe-prepend find-element/css ;
|
|
|
|
: find-elements-by-class-name ( name -- element )
|
|
"." maybe-prepend find-elements/css ;
|
|
|
|
: active-element ( -- element )
|
|
"element/active" <session-get-request> http-web-driver-request ;
|
|
|
|
! element state
|
|
|
|
: is-element-selected? ( element -- ? )
|
|
"selected" <element-get-request> http-web-driver-request ;
|
|
|
|
: get-element-attribute ( element name -- attribute )
|
|
"attribute" prepend-path <element-get-request> http-web-driver-request ;
|
|
|
|
: get-element-property ( element name -- property )
|
|
"property" prepend-path <element-get-request> http-web-driver-request ;
|
|
|
|
: get-element-css-value ( element property-name -- css-value )
|
|
"css" prepend-path <element-get-request> http-web-driver-request ;
|
|
|
|
: get-element-text ( element -- text )
|
|
"text" <element-get-request> http-web-driver-request ;
|
|
|
|
: is-element-enabled? ( element -- ? )
|
|
"enabled" <element-get-request> http-web-driver-request ;
|
|
|
|
TUPLE: rect x y width height ;
|
|
|
|
: get-element-rect ( element -- rect )
|
|
"rect" <element-get-request> http-web-driver-request
|
|
{ [ "x" of ] [ "y" of ] [ "width" of ] [ "height" of ] } cleave rect boa ;
|
|
|
|
! element interaction
|
|
|
|
: element-click ( element -- )
|
|
f "click" <element-post-request> http-web-driver-request drop ;
|
|
|
|
: element-clear ( element -- )
|
|
f "clear" <element-post-request> http-web-driver-request drop ;
|
|
|
|
: element-send-keys ( element value -- )
|
|
'H{ { "text" _ } } "value" <element-post-request> http-web-driver-request drop ;
|
|
|
|
! document handling
|
|
|
|
: get-page-source ( -- source )
|
|
"source" <session-get-request> http-web-driver-request ;
|
|
|
|
: execute-script ( script arguments -- return )
|
|
'H{ { "script" _ } { "args" _ } } "execute/sync" <session-post-request> http-web-driver-request ;
|
|
|
|
: execute-async-script ( script arguments -- return )
|
|
'H{ { "script" _ } { "args" _ } } "execute/async" <session-post-request> http-web-driver-request ;
|
|
|
|
! cookies
|
|
|
|
TUPLE: cookie name value path domain secure? http-only? expiry same-site ;
|
|
|
|
: parse-cookie ( hashtable -- cookie )
|
|
{
|
|
[ "name" of ]
|
|
[ "value" of ]
|
|
[ "path" of [ "/" ] unless* ]
|
|
[ "domain" of ]
|
|
[ "secure" of ]
|
|
[ "httpOnly" of ]
|
|
[ "expiry" of [ unix-time>timestamp ] [ f ] if* ]
|
|
[ "sameSite" of ]
|
|
} cleave cookie boa ;
|
|
|
|
: cookie>web-driver-cookie ( cookie -- hashtable )
|
|
tuple>assoc >hashtable [
|
|
{
|
|
[ "secure" "secure?" rot rename-at ]
|
|
[ "httpOnly" "http-only?" rot rename-at ]
|
|
[ "sameSite" "same-site" rot rename-at ]
|
|
} cleave
|
|
] keep 'H{ { "cookie" _ } } ;
|
|
|
|
: get-all-cookies ( -- cookies )
|
|
"cookie" <session-get-request> http-web-driver-request
|
|
[ parse-cookie ] map ;
|
|
|
|
: get-named-cookie ( name -- value )
|
|
"cookie" prepend-path <session-get-request> http-web-driver-request parse-cookie ;
|
|
|
|
: add-cookie ( cookie -- )
|
|
cookie>web-driver-cookie "cookie" <session-post-request> http-web-driver-request drop ;
|
|
|
|
: add-cookies ( seq -- )
|
|
[ add-cookie ] each ;
|
|
|
|
: delete-cookie ( name -- )
|
|
"cookie" prepend-path <session-delete-request> http-web-driver-request drop ;
|
|
|
|
: delete-all-cookies ( -- )
|
|
"cookie" <session-delete-request> http-web-driver-request drop ;
|
|
|
|
! User prompts
|
|
! https://www.w3.org/TR/webdriver/#user-prompts
|
|
|
|
: dismiss-alert ( -- )
|
|
f "alert/dismiss" <session-post-request> http-web-driver-request drop ;
|
|
|
|
: accept-alert ( -- )
|
|
f "alert/accept" <session-post-request> http-web-driver-request drop ;
|
|
|
|
: get-alert-text ( -- text )
|
|
"alert/text" <session-get-request> http-web-driver-request ;
|
|
|
|
: send-alert-text ( text -- )
|
|
'H{ { "text" _ } } "alert/text" <session-post-request> http-web-driver-request drop ;
|
|
|
|
! Screen capture
|
|
! https://www.w3.org/TR/webdriver/#screen-capture
|
|
|
|
: take-screenshot ( -- loading-png )
|
|
"screenshot" <session-get-request> http-web-driver-request
|
|
base64> binary <byte-reader> load-png ;
|
|
|
|
: take-element-screenshot ( element -- loading-png )
|
|
"screenshot" <element-get-request> http-web-driver-request base64> binary <byte-reader> load-png ;
|
|
|
|
! TODO: Actions
|
|
|
|
! Sessions
|
|
! https://www.w3.org/TR/webdriver/#sessions
|
|
|
|
: status ( -- session-status )
|
|
! [
|
|
"status" <web-driver-get-request> http-web-driver-request
|
|
[ "message" of dup "" = [ drop f ] when ] [ "ready" of ] bi session-status boa ;
|
|
! ]
|
|
! [ \ libc-error instance? ] ignore-error/f "SUP" session-status boa ;
|
|
|
|
: <web-driver-session> ( capabilities -- json )
|
|
dup .
|
|
"session" <web-driver-post-request> http-web-driver-request
|
|
[ "sessionId" of ] [ "capabilities" of ] bi web-driver-session boa ;
|
|
|
|
: delete-session ( -- )
|
|
current-session-url <web-driver-delete-request> http-web-driver-request drop ;
|
|
|
|
: get-free-listen-port ( -- port )
|
|
<any-port-local-inet4> utf8 <server>
|
|
[ addr>> port>> ] [ dispose ] bi number>string ;
|
|
|
|
: build-url ( host port -- url )
|
|
":" prepend append "http://" prepend "/" append >url ;
|
|
|
|
! TODO: handle missing binary
|
|
|
|
: <gecko-driver-command-desc> ( -- desc )
|
|
{ "geckodriver" "--log" "fatal" } ;
|
|
|
|
: <chrome-driver-command-desc> ( -- desc )
|
|
{ "chromedriver" "--silent" } ;
|
|
|
|
: <web-driver-process> ( desc host port -- process )
|
|
"--port=" prepend
|
|
'{ "--host" _ _ } append utf8 <process-reader> ;
|
|
|
|
: <web-driver> ( command host port -- process )
|
|
[ <web-driver-process> ] 2keep build-url web-driver boa ;
|
|
|
|
: default-host/port ( -- host port )
|
|
"localhost" get-free-listen-port ;
|
|
|
|
: <gecko-driver> ( host port -- web-driver )
|
|
[ <gecko-driver-command-desc> ] 2dip <web-driver> ;
|
|
|
|
: <default-gecko-driver> ( -- web-driver )
|
|
default-host/port <gecko-driver> ;
|
|
|
|
: <chrome-driver> ( host port -- web-driver )
|
|
[ <chrome-driver-command-desc> ] 2dip <web-driver> ;
|
|
|
|
: <default-chrome-driver> ( -- web-driver )
|
|
default-host/port <chrome-driver> ;
|
|
|
|
: with-web-driver ( driver quote -- )
|
|
current-web-driver swap with-variable ; inline
|
|
|
|
: with-default-gecko-driver ( quote -- )
|
|
<default-gecko-driver> swap with-web-driver ; inline
|
|
|
|
: with-default-chrome-driver ( quote -- )
|
|
<default-chrome-driver> swap with-web-driver ; inline
|
|
|
|
: with-web-driver-session ( capabilities driver quote -- )
|
|
[
|
|
dup current-web-driver [
|
|
[ ready?>> ] [ 1 seconds sleep status ] do until
|
|
swap <web-driver-session>
|
|
'H{ { current-web-driver _ } { current-web-driver-session _ } }
|
|
] with-variable
|
|
] dip
|
|
with-variables ; inline
|
|
|
|
: with-default-gecko-driver-session ( capabilities quote -- )
|
|
<default-gecko-driver> swap with-web-driver-session ; inline
|
|
|
|
: with-default-chrome-driver-session ( capabilities quote -- )
|
|
<default-chrome-driver> swap with-web-driver-session ; inline
|