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

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: 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-get-request> ( path -- request )
    <web-driver-url> <get-request> ;

: <web-driver-post-request> ( data path -- request )
    <web-driver-url> <post-request> ;

: <web-driver-delete-request> ( path -- request )
    <web-driver-url> <delete-request> ;

: <web-driver-post-data> ( hashtable -- post-data )
    "application/json" <post-data> swap
    [ >json utf8 encode ] [ B{ 123 125 } ] if* >>data ;

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

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

! navigation

: get-current-url ( -- url )
    "url" <session-get-request> http-web-driver-request >url ;

: navigate-to ( url -- )
    present '{ { "url" _ } } >hashtable "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 )
    [ "value" swap 2array ] [ "using" swap 2array ] bi* 2array >hashtable ;

: <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 -- )
    '{ { "text" _ } } >hashtable "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 )
    '{ { "script" _ } { "args" _ } } >hashtable "execute/sync" <session-post-request> http-web-driver-request ;

: execute-async-script ( script arguments -- return )
    '{ { "script" _ } { "args" _ } } >hashtable "execute/async" <session-post-request> http-web-driver-request ;

! cookies

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

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