factor-work/web-driver/web-driver.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