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

USING: kernel http http.client http.server 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 ;
USING: prettyprint ;

IN: web-driver



SYMBOL: current-session-id
SYMBOL: current-remote-host

! 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 uri session-id process ;
TUPLE: session-status message ready? ;

: current-session-relative-url ( -- url )
    "session" current-session-id get append-path >url ;

: current-base-url ( -- url )
    current-remote-host get >url ;

: current-session-url ( -- url )
    current-base-url current-session-relative-url derive-url ;

: <web-driver-url> ( path -- url )
    [ current-base-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" _ } } ;

 ! 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: handle driver processes better

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

: <gecko-driver-stream> ( url capabilities -- stream )
    2drop
    "geckodriver --port 4444" utf8 <process-stream> ;