factor-work/web-driver/web-driver.factor

USING: kernel http http.client http.server io.sockets io.streams.byte-array io.pathnames io.encodings.binary io.encodings.string io.encodings.utf8 io.launcher accessors urls parser effects.parser words arrays sequences quotations json.reader json.writer formatting assocs namespaces present hashtables words.symbol combinators lexer calendar prettyprint.backend base64 images.png destructors math.parser threads continuations ;
USING: libc classes ;

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 remote-url process ;
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 hashtable } ;

: <capabilities> ( always-match first-match -- capabilities )
    [ [ H{ } ] unless* ] bi@ capabilities boa ;

: capabilities>json ( capabilities -- string )
    [ always-match>> ] [ first-match>> ] bi
    'H{ { "alwaysMatch" _ } { "firstMatch" _ } } 'H{ { "capabilities" _ } } ;

: <headless-firefox-capabilities> ( -- hash )
    H{
        { "browserName" "firefox" }
        { "moz:firefoxOptions" { "args" { "-headless" } } }
    } ;

! 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 ;

! cooHkies

! TODO: samesite?

: web-driver-cookie>cookie ( hashtable -- cookie )
    {
        [ "name" of ] [ "value" of f f ]  [ "path" of ] [ "domain" of ]
        [ "expiry" of f swap unix-time>timestamp ] [ "httpOnly" of ] [ "secure" of ]
    } cleave cookie boa ;

: cookie>web-driver-cookie ( cookie -- hashtable )
    tuple>assoc >hashtable [
        [ "httpOnly" "http-only" rot rename-at ]
        [ "expiry" "max-age" rot rename-at ] bi
    ] keep ;

: get-all-cookies ( -- cookies )
    "cookie" <session-get-request> http-web-driver-request 
    [ web-driver-cookie>cookie ] map ;

: get-named-cookie ( name -- value )
    "cookie" prepend-path <session-get-request> http-web-driver-request web-driver-cookie>cookie ;

: add-cookie ( cookie -- )
    cookie>web-driver-cookie "cookie" <session-post-request> http-web-driver-request drop ;

: 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

! TODO: handle driver processes better

! 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 f session-status boa ;

: <web-driver-session> ( capabilities -- json )
    "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 ;

: <web-driver-process> ( host port command -- process )
    -rot '{ _ "--host" _ "--port" _ } utf8 <process-reader> ;

: <gecko-driver> ( host port -- gecko-driver )
    [ ":" prepend append "http://" prepend "/" append >url ]
    [ "geckodriver" <web-driver-process> ] 2bi
    web-driver boa ;

: with-gecko-driver ( host port quote -- )
    [ [ ready?>> ] [ 1 seconds sleep status ] do until ] prepose
    [ <gecko-driver> current-web-driver ] dip with-variable ; inline

: with-default-gecko-driver ( quote -- )
    [ "127.0.0.1" get-free-listen-port ] dip with-gecko-driver ; inline

: <chrome-driver> ( host port -- process )
    [ ":" prepend append "http://" prepend "/" append >url ]
    [ "chromedriver" <web-driver-process> ] 2bi
    web-driver boa ;

: with-chrome-driver ( host port quote -- )
    [ <chrome-driver> current-web-driver ] dip with-variable ; inline

: with-default-chrome-driver ( quote -- )
    [ "127.0.0.1" get-free-listen-port ] dip with-chrome-driver ; inline

! : with-default-gecko-session ( caps quote -- )
!     [
!         2drop
!         [ ready?>> ] [ 1 seconds sleep status ] do until
!         [ <web-driver-session> current-web-driver-session ] dip with-variable
!         delete-session
!     ] with-default-gecko-driver ;

! : <web-driver-session> ( host port capabilities -- session )
!     [
!         [ <gecko-driver-process> ]
!         [ ":" prepend append "http://" prepend "/" append ] 2bi
!     ] dip
!
!     [
!         [ ready?>> ] [ 1 seconds sleep status ] do until
!     ] dip
!
!     2dup new-session  new-session [ "sessionId" of ] [ "capabilities" of ] bi
!
! : init-driver-session ( -- )
!     f f web-driver-session boa

! : <web-driver-session> ( capabilities -- session )
!    init-driver-session
!
!    [ ready?>> ] [ 1 seconds sleep status ] do until
!
!    new-session [ "sessionId" of ] [ "capabilities" of ] bi
!
!    current-web-driver-session> swap >>capabilities swap >>session-id
!    >current-web-driver-session ;