;; [[file:webdriver.org::*Dependencies][Dependencies:4]]
(import r7rs
        (chicken base)
        (chicken string)
        (chicken process)
        (chicken gc)
        srfi-34		;;Exception Handling
        srfi-35		;;Exception Types
        base64		;;decoding screenshot data
        http-client		;;API interaction
        intarweb		;;Supporting HTTP functionality
        uri-common		;;Supporting HTTP functionality
        coops		;;Object system
        alist-lib		;;Handling alists from JSON objects
        medea		;;JSON handling
        )
;; Dependencies:4 ends here



;; * Error Conditions

;; #+name: wd-exception

;; [[file:webdriver.org::wd-exception][wd-exception]]
(define-condition-type &wd-exception &error wd-exception?
  (stacktrace wd-stacktrace)
  (data wd-data))
;; wd-exception ends here



;; #+name: conditions

;; [[file:webdriver.org::conditions][conditions]]
(define-condition-type &detached-shadow-root &wd-exception detached-shadow-root?)
(define-condition-type &element-click-intercepted &wd-exception element-click-intercepted?)
(define-condition-type &element-not-interactable &wd-exception element-not-interactable?)
(define-condition-type &insecure-certificate &wd-exception insecure-certificate?)
(define-condition-type &invalid-argument &wd-exception invalid-argument?)
(define-condition-type &invalid-cookie-domain &wd-exception invalid-cookie-domain?)
(define-condition-type &invalid-element-state &wd-exception invalid-element-state?)
(define-condition-type &invalid-selector &wd-exception invalid-selector?)
(define-condition-type &invalid-session-id &wd-exception invalid-session-id?)
(define-condition-type &javascript-error &wd-exception javascript-error?)
(define-condition-type &move-target-out-of-bounds &wd-exception move-target-out-of-bounds?)
(define-condition-type &no-such-alert &wd-exception no-such-alert?)
(define-condition-type &no-such-cookie &wd-exception no-such-cookie?)
(define-condition-type &no-such-element &wd-exception no-such-element?)
(define-condition-type &no-such-frame &wd-exception no-such-frame?)
(define-condition-type &no-such-shadow-root &wd-exception no-such-shadow-root?)
(define-condition-type &no-such-window &wd-exception no-such-window?)
(define-condition-type &script-timeout &wd-exception script-timeout?)
(define-condition-type &session-not-created &wd-exception session-not-created?)
(define-condition-type &stale-element-reference &wd-exception stale-element-reference?)
(define-condition-type &timeout &wd-exception timeout?)
(define-condition-type &unable-to-capture-screen &wd-exception unable-to-capture-screen?)
(define-condition-type &unable-to-set-cookie &wd-exception unable-to-set-cookie?)
(define-condition-type &unexpected-alert-open &wd-exception unexpected-alert-open?)
(define-condition-type &unknown-command &wd-exception unknown-command?)
(define-condition-type &unknown-error &wd-exception unknown-error?)
(define-condition-type &unknown-method &wd-exception unknown-method?)
(define-condition-type &unsupported-operation &wd-exception unsupported-operation?)

(define (wd-throw data)
  (case (alist-ref data 'error)
    (("detached shadow root") (raise (make-condition &detached-shadow-root (alist-ref data 'stacktrace) data)))
    (("element click intercepted") (raise (make-condition &element-click-intercepted (alist-ref data 'stacktrace) data)))
    (("element not interactable") (raise (make-condition &element-not-interactable (alist-ref data 'stacktrace) data)))
    (("insecure certificate") (raise (make-condition &insecure-certificate (alist-ref data 'stacktrace) data)))
    (("invalid argument") (raise (make-condition &invalid-argument (alist-ref data 'stacktrace) data)))
    (("invalid cookie domain") (raise (make-condition &invalid-cookie-domain (alist-ref data 'stacktrace) data)))
    (("invalid element state") (raise (make-condition &invalid-element-state (alist-ref data 'stacktrace) data)))
    (("invalid selector") (raise (make-condition &invalid-selector (alist-ref data 'stacktrace) data)))
    (("invalid session id") (raise (make-condition &invalid-session-id (alist-ref data 'stacktrace) data)))
    (("javascript error") (raise (make-condition &javascript-error (alist-ref data 'stacktrace) data)))
    (("move target out of bounds") (raise (make-condition &move-target-out-of-bounds (alist-ref data 'stacktrace) data)))
    (("no such alert") (raise (make-condition &no-such-alert (alist-ref data 'stacktrace) data)))
    (("no such cookie") (raise (make-condition &no-such-cookie (alist-ref data 'stacktrace) data)))
    (("no such element") (raise (make-condition &no-such-element (alist-ref data 'stacktrace) data)))
    (("no such frame") (raise (make-condition &no-such-frame (alist-ref data 'stacktrace) data)))
    (("no such shadow root") (raise (make-condition &no-such-shadow-root (alist-ref data 'stacktrace) data)))
    (("no such window") (raise (make-condition &no-such-window (alist-ref data 'stacktrace) data)))
    (("script timeout") (raise (make-condition &script-timeout (alist-ref data 'stacktrace) data)))
    (("session not created") (raise (make-condition &session-not-created (alist-ref data 'stacktrace) data)))
    (("stale element reference") (raise (make-condition &stale-element-reference (alist-ref data 'stacktrace) data)))
    (("timeout") (raise (make-condition &timeout (alist-ref data 'stacktrace) data)))
    (("unable to capture screen") (raise (make-condition &unable-to-capture-screen (alist-ref data 'stacktrace) data)))
    (("unable to set cookie") (raise (make-condition &unable-to-set-cookie (alist-ref data 'stacktrace) data)))
    (("unexpected alert open") (raise (make-condition &unexpected-alert-open (alist-ref data 'stacktrace) data)))
    (("unknown command") (raise (make-condition &unknown-command (alist-ref data 'stacktrace) data)))
    (("unknown error") (raise (make-condition &unknown-error (alist-ref data 'stacktrace) data)))
    (("unknown method") (raise (make-condition &unknown-method (alist-ref data 'stacktrace) data)))
    (("unsupported operation") (raise (make-condition &unsupported-operation (alist-ref data 'stacktrace) data)))
    (else (raise (make-condition &wd-exception (alist-ref data 'stacktrace) data)))
  )
)
;; conditions ends here



;; * WebDriver

;; The core element of the library is the ~<WebDriver>~ class and its subclasses. The class has the following fields:

;; #+name: webdriver-class

;; [[file:webdriver.org::webdriver-class][webdriver-class]]
(define-class <WebDriver> ()
  ((browser #f)
   (active? #f)
   (browser-pid #f)
   (server #f)
   (port #f)
   (session-id #f)
   (prefs #f)
   (capabilities #f)))
;; webdriver-class ends here



;; The parent class provides a handful of methods, but does not implement all of them; some are the sole responsibility of the subclass. The ~launch~ method, on the other hand, bears shared responsibility. It sets a finalizer to ensure termination of the web driver process in case the class is disposed of with a still-open driver.

;; #+name: webdriver-basics

;; [[file:webdriver.org::webdriver-basics][webdriver-basics]]
(define-method (launch #:after (instance <WebDriver>) options)
  (set-finalizer! instance (lambda (obj)
                             (when (slot-value instance 'active?)
                               (terminate instance)))))

(define-method (terminate (instance <WebDriver>))
  (terminate-session instance)
  (process-signal (slot-value instance 'browser-pid))
  (set! (slot-value instance 'browser-pid) #f)
  (set! (slot-value instance 'active?) #f))

(define-method (construct-capabilities (instance <WebDriver>) #!optional caps)
  (raise 'subclass-responsibility))

(define-method (postprocess-result (instance <WebDriver>) result)
  result)
;; webdriver-basics ends here



;; Main initialization is done by calling the ~make-WebDriver~ procedure with the respective class name and optionally an alist of options.

;; #+name: webdriver-init

;; [[file:webdriver.org::webdriver-init][webdriver-init]]
(define (make-WebDriver browser #!optional options)
  (let ((instance (make browser)))
    (launch instance options)
    (sleep 1)
    instance))
;; webdriver-init ends here



;; ** Geckodriver

;; The Geckodriver is used to control Firefox.

;; #+name: geckodriver-basic

;; [[file:webdriver.org::geckodriver-basic][geckodriver-basic]]
(define-class <Gecko> (<WebDriver>)
  ((browser #:firefox)
   (server "127.0.0.1")
   (port 4444)))

(define-method (launch (instance <Gecko>) options)
  (let ((pid (process-run "geckodriver > /dev/null 2>&1")))
    (set! (slot-value instance 'browser-pid) pid)
    (set! (slot-value instance 'active?) #t)
    (set! (slot-value instance 'capabilities) options)))
;; geckodriver-basic ends here



;; The capabilities object for Geckodriver is of the form ={"capabilities": {...}}=.
;; For more information on capabilities, see https://developer.mozilla.org/en-US/docs/Web/WebDriver/Capabilities.

;; #+name: geckodriver-capabilities

;; [[file:webdriver.org::geckodriver-capabilities][geckodriver-capabilities]]
(define-method (construct-capabilities (instance <Gecko>))
  (let ((caps (or (slot-value instance 'capabilities) (list))))
    `((capabilities . ,caps))))
;; geckodriver-capabilities ends here



;; Sometimes, Geckodriver returns the results of a command in a JSON object with the sole key ="value"=. We have to correct that before returning the data to the user.

;; #+name: geckodriver-postprocess

;; [[file:webdriver.org::geckodriver-postprocess][geckodriver-postprocess]]
(define-method (postprocess-result (instance <Gecko>) result)
  (alist-ref/default result 'value result))
;; geckodriver-postprocess ends here



;; * WebDriver API

;; ** Communication

;; Data is sent to the API via a central class method. For convenience, there is a ~send-with-session~ variant that automatically adds the session id.

;; #+name: wd-send

;; [[file:webdriver.org::wd-send][wd-send]]
(define-method (send (instance <WebDriver>) data uri method)
  (let* ((remote (string-append "http://" (slot-value instance 'server) ":" (->string (slot-value instance 'port)) "/"))
         (result (postprocess-result instance
                                     (with-input-from-request
                                      (make-request #:method method
                                                    #:uri (uri-reference (string-append remote uri))
                                                    #:headers (headers `((content-type application/json))))
                                      (if data (json->string data) "")
                                      read-json))))
    (if (and (list? result) (alist-ref/default result 'error #f))
        (wd-throw result)
        result)))

(define-method (send-with-session (instance <WebDriver>) data uri method)
  (send instance data (string-append "session/" (slot-value instance 'session-id) "/" uri) method))
;; wd-send ends here



;; ** Session management

;; Session management is very simple. There is just one method to initialize a new session. Everything else is handled automatically.

;; #+name: wd-init-session

;; [[file:webdriver.org::wd-init-session][wd-init-session]]
(define-method (initialize-session (instance <WebDriver>))
 (let ((result (send instance (construct-capabilities instance) "session" 'POST)))
   (set! (slot-value instance 'session-id) (alist-ref result 'sessionId))))
;; wd-init-session ends here



;; #+name: wd-term-session

;; [[file:webdriver.org::wd-term-session][wd-term-session]]
(define-method (terminate-session (instance <WebDriver>))
  (when (slot-value instance 'session-id)
    (send instance #f (string-append "session/" (slot-value instance 'session-id)) 'DELETE))
  (set! (slot-value instance 'session-id) #f))
;; wd-term-session ends here



;; #+RESULTS: wd-session-test
;; : -- testing session -----------------------------------------------------------
;; : Initial state ........................................................ [ PASS]
;; : Session id check ..................................................... [ PASS]
;; : Session id after termination ......................................... [ PASS]
;; : 3 tests completed in 3.788 seconds.
;; : 3 out of 3 (100%) tests passed.
;; : -- done testing session ------------------------------------------------------

;; ** API Access Methods

;; #+name: wd-url

;; [[file:webdriver.org::wd-url][wd-url]]
(define-method (set-url (instance <WebDriver>) url)
  (send-with-session instance `((url . ,url)) "url" 'POST))

(define-method (url (instance <WebDriver>))
  (send-with-session instance #f "url" 'GET))
;; wd-url ends here



;; #+RESULTS: wd-url-test
;; : -- testing url ---------------------------------------------------------------
;; : Initial state ........................................................ [ PASS]
;; : Navigating to the first website ...................................... [ PASS]
;; : 2 tests completed in 5.247 seconds.
;; : 2 out of 2 (100%) tests passed.
;; : -- done testing url ----------------------------------------------------------


;; [[file:webdriver.org::*API Access Methods][API Access Methods:3]]
(define-method (back (instance <WebDriver>))
  (send-with-session instance #f "back" 'POST))
;; API Access Methods:3 ends here

;; [[file:webdriver.org::*API Access Methods][API Access Methods:4]]
(define-method (forward (instance <WebDriver>))
  (send-with-session instance #f "forward" 'POST))
;; API Access Methods:4 ends here

;; [[file:webdriver.org::*API Access Methods][API Access Methods:5]]
(define-method (refresh (instance <WebDriver>))
  (send-with-session instance #f "refresh" 'POST))
;; API Access Methods:5 ends here

;; [[file:webdriver.org::*API Access Methods][API Access Methods:6]]
(define-method (title (instance <WebDriver>))
  (send-with-session instance #f "title" 'GET))
;; API Access Methods:6 ends here

;; [[file:webdriver.org::*API Access Methods][API Access Methods:7]]
(define-method (status (instance <WebDriver>))
  (send-with-session instance #f "status" 'GET))
;; API Access Methods:7 ends here

;; [[file:webdriver.org::*API Access Methods][API Access Methods:8]]
(define-method (source (instance <WebDriver>))
  (send-with-session instance #f "source" 'GET))
;; API Access Methods:8 ends here

;; [[file:webdriver.org::*API Access Methods][API Access Methods:9]]
(define-method (screenshot (instance <WebDriver>))
  (base64-decode (send-with-session instance #f "screenshot" 'GET)))
;; API Access Methods:9 ends here

;; [[file:webdriver.org::*API Access Methods][API Access Methods:10]]
(define-method (print-page (instance <WebDriver>))
  (send-with-session instance #f "print" 'POST))
;; API Access Methods:10 ends here

;; [[file:webdriver.org::*API Access Methods][API Access Methods:11]]
(define-method (execute-async (instance <WebDriver>) script args)
  (send-with-session instance `((script . ,script) (args . ,args)) "execute/async" 'POST))
;; API Access Methods:11 ends here

;; [[file:webdriver.org::*API Access Methods][API Access Methods:12]]
(define-method (execute-sync (instance <WebDriver>) script args)
  (send-with-session instance `((script . ,script) (args . ,args)) "execute/sync" 'POST))
;; API Access Methods:12 ends here



;; The following timeouts are defined:

;; - =script=: defaults to 30'000, specifies when to interrupt a script that is being evaluated. A nil value implies that scripts should never be interrupted, but instead run indefinitely.
;; - =pageLoad=: defaults to 300'000, provides the timeout limit used to interrupt an explicit navigation attempt.
;; - =implicit=: defaults to 0, specifies a time to wait for the element location strategy to complete when locating an element.


;; [[file:webdriver.org::*Timeouts][Timeouts:1]]
(define-class <WDTimeouts> ()
  ((script 30000)
   (pageLoad 300000)
   (implicit 0)))
;; Timeouts:1 ends here

;; [[file:webdriver.org::*Timeouts][Timeouts:2]]
(define-method (extract (instance <WDTimeouts>))
  `((script . ,(slot-value instance 'script))
    (pageLoad . ,(slot-value instance 'pageLoad))
    (implicit . ,(slot-value instance 'implicit))))
;; Timeouts:2 ends here

;; [[file:webdriver.org::*Setting and getting timeouts][Setting and getting timeouts:1]]
(define-method (set-timeouts (instance <WebDriver>) (timeouts <WDTimeouts>))
  (send-with-session instance (extract timeouts) "timeouts" 'POST))

(define-method (timeouts (instance <WebDriver>))
  (let ((result (send-with-session instance #f "timeouts" 'GET)))
    (make <WDTimeouts>
      'script (alist-ref result 'script)
      'pageLoad (alist-ref result 'pageLoad)
      'implicit (alist-ref result 'implicit))))
;; Setting and getting timeouts:1 ends here

;; [[file:webdriver.org::*Element Class][Element Class:1]]
(define-class <WDElement> ()
  ((driver #f)
   (element #f)))
;; Element Class:1 ends here

;; [[file:webdriver.org::*Element Class][Element Class:2]]
(define-method (send-with-session (instance <WDElement>) data uri method)
  (send-with-session (slot-value instance 'driver) data
                     (string-append "element/" (slot-value instance 'element) "/" uri)
                     method))
;; Element Class:2 ends here

;; [[file:webdriver.org::*Location Strategies][Location Strategies:1]]
(define css-selector "css selector")
(define link-text "link text")
(define partial-link-text "partial link text")
(define tag-name "tag name")
(define xpath "xpath")
;; Location Strategies:1 ends here

;; [[file:webdriver.org::*Accessor Methods][Accessor Methods:1]]
(define-method (find-element (instance <WebDriver>) strategy selector)
  (let ((result (send-with-session instance `((using . ,strategy) (value . ,selector)) "element" 'POST)))
    (make <WDElement> 'driver instance 'element (car (alist-values result)))))
;; Accessor Methods:1 ends here

;; [[file:webdriver.org::*Accessor Methods][Accessor Methods:2]]
(define-method (find-elements (instance <WebDriver>) strategy selector)
  (let ((result (send-with-session instance `((using . ,strategy) (value . ,selector)) "elements" 'POST)))
    (map
     (lambda (elem)
       (make <WDElement> 'driver instance 'element (car (alist-values elem))))
     result)))
;; Accessor Methods:2 ends here

;; [[file:webdriver.org::*Accessor Methods][Accessor Methods:3]]
(define-method (find-element (instance <WDElement>) strategy selector)
  (let ((result (send-with-session instance `((using . ,strategy) (value . ,selector)) "element" 'POST)))
    (make <WDElement> 'driver (slot-value instance 'driver) 'element (car (alist-values result)))))
;; Accessor Methods:3 ends here

;; [[file:webdriver.org::*Accessor Methods][Accessor Methods:4]]
(define-method (find-elements (instance <WDElement>) strategy selector)
  (let ((result (send-with-session instance `((using . ,strategy) (value . ,selector)) "elements" 'POST)))
    (map
     (lambda (elem)
       (make <WDElement> 'driver (slot-value instance 'driver) 'element (car (alist-values elem))))
     result)))
;; Accessor Methods:4 ends here

;; [[file:webdriver.org::*Working with Elements][Working with Elements:1]]
(define-method (attribute (instance <WDElement>) attribute)
  (let ((result (send-with-session instance #f
                                   (string-append "attribute/" attribute)
                                   'GET)))
    (if (equal? "true" result)
        #t
        result)))
;; Working with Elements:1 ends here

;; [[file:webdriver.org::*Working with Elements][Working with Elements:2]]
(define-method (property (instance <WDElement>) property)
  (send-with-session instance #f (string-append "property/" property) 'GET))
;; Working with Elements:2 ends here

;; [[file:webdriver.org::*Working with Elements][Working with Elements:3]]
(define-method (clear (instance <WDElement>))
  (send-with-session instance #f "clear" 'POST))
;; Working with Elements:3 ends here

;; [[file:webdriver.org::*Working with Elements][Working with Elements:4]]
(define-method (click (instance <WDElement>))
  (send-with-session instance #f "click" 'POST))
;; Working with Elements:4 ends here

;; [[file:webdriver.org::*Working with Elements][Working with Elements:5]]
(define-method (computed-label (instance <WDElement>))
  (send-with-session instance #f "computedlabel" 'GET))
;; Working with Elements:5 ends here

;; [[file:webdriver.org::*Working with Elements][Working with Elements:6]]
(define-method (computed-role (instance <WDElement>))
  (send-with-session instance #f "computedrole" 'GET))
;; Working with Elements:6 ends here

;; [[file:webdriver.org::*Working with Elements][Working with Elements:7]]
(define-method (enabled? (instance <WDElement>))
  (send-with-session instance #f "enabled" 'GET))
;; Working with Elements:7 ends here

;; [[file:webdriver.org::*Working with Elements][Working with Elements:8]]
(define-method (selected? (instance <WDElement>))
  (send-with-session instance #f "selected" 'GET))
;; Working with Elements:8 ends here

;; [[file:webdriver.org::*Working with Elements][Working with Elements:9]]
(define-method (name (instance <WDElement>))
  (send-with-session instance #f "name" 'GET))
;; Working with Elements:9 ends here

;; [[file:webdriver.org::*Working with Elements][Working with Elements:10]]
(define-method (rect (instance <WDElement>))
  (send-with-session instance #f "rect" 'GET))
;; Working with Elements:10 ends here

;; [[file:webdriver.org::*Working with Elements][Working with Elements:11]]
(define-method (screenshot (instance <WDElement>))
  (base64-decode (send-with-session instance #f "screenshot" 'GET)))
;; Working with Elements:11 ends here

;; [[file:webdriver.org::*Working with Elements][Working with Elements:12]]
(define-method (text (instance <WDElement>))
  (send-with-session instance #f "text" 'GET))
;; Working with Elements:12 ends here

;; [[file:webdriver.org::*Working with Elements][Working with Elements:13]]
(define-method (set-value (instance <WDElement>) value)
  (send-with-session instance `((text . ,value)) "value" 'POST))
;; Working with Elements:13 ends here