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 ;
USING: prettyprint ;

IN: web-driver

SYMBOL: current-web-driver-session

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

TUPLE: web-driver-session remote-url session-id capabilities ;
TUPLE: session-status message ready? ;

: current-web-driver-session> ( -- session )
    current-web-driver-session get ;
: >current-web-driver-session ( session -- )
    current-web-driver-session set ;

: current-session-id ( -- session-id )
    current-web-driver-session> session-id>> ;
: current-remote-url ( -- remote-url )
    current-web-driver-session> remote-url>> ;

: current-session-relative-url ( -- url )
    "session" current-session-id get append-path >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" } } }
    } ;

 ! Sessions
 ! https://www.w3.org/TR/webdriver/#sessions

 : status ( -- session-status )
     "status" <web-driver-get-request> http-web-driver-request
     [ "message" of ] [ "ready" of ] bi session-status boa ;

: new-session ( capabilities -- json )
    "session" <web-driver-post-request> http-web-driver-request
     dup "sessionId" of current-session-id set ;

: delete-session ( id -- )
    <web-driver-delete-request> http-web-driver-request drop ;

: delete-current-session ( -- )
    current-session-id get delete-session ;

! 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

: get-free-listen-port ( -- port )
    <any-port-local-inet4> utf8 <server>
    [ addr>> port>> ] [ dispose ] bi number>string ;

: <chrome-driver-process> ( capabilities -- process )
    drop
    "chromedriver --silent --port 4444" utf8 <process-stream> ;

: <gecko-driver-process> ( host port -- process )
    '{ "geckodriver" "--host" _ "--port" _ } utf8 <process-reader> ;

: <web-driver-session> ( -- )
    "127.0.0.1" get-free-listen-port
    [ ":" prepend append "http://" prepend "/" append >url ]
    [ <gecko-driver-process> ] 2bi
    f f web-driver-session boa
    >current-web-driver-session ;

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