225 lines
8.0 KiB
Scheme
225 lines
8.0 KiB
Scheme
;; -*- geiser-scheme: chicken -*-
|
|
|
|
(import (r7rs))
|
|
(import (scheme base))
|
|
(import (srfi 1)
|
|
(srfi 180))
|
|
(import coops coops-extras coops-primitive-objects coops-utils)
|
|
(import (chicken process)
|
|
(chicken gc)
|
|
(chicken condition))
|
|
(import uri-common)
|
|
(import intarweb)
|
|
(import http-client)
|
|
|
|
(define-class <Browser> ()
|
|
((base-url accessor: base-url)
|
|
(stdout accessor: stdout)
|
|
(stdin accessor: stdin)
|
|
(stderr accessor: stderr)
|
|
(pid accessor: pid)
|
|
(session accessor: session)))
|
|
|
|
(define-method (initialize-instance (browser <Browser>))
|
|
(set-finalizer! browser (lambda (obj) (terminate browser)))
|
|
(call-next-method))
|
|
|
|
(define (raise-error error-alist)
|
|
(print "BOOM!")
|
|
(error (alist-ref 'error error-alist)
|
|
error-alist))
|
|
|
|
(define-method (read-reply (browser <Browser>))
|
|
(lambda ()
|
|
(json-read)))
|
|
|
|
(define-method (send (browser <Browser>) struct path method)
|
|
(let ((reply
|
|
(with-input-from-request
|
|
(make-request method: method
|
|
uri: (uri-reference (string-append (base-url browser) path))
|
|
headers: (headers `((content-type application/json))))
|
|
(lambda () (json-write struct))
|
|
(read-reply browser))))
|
|
(if (and (list? reply) (find (lambda (x) (eqv? (car x) 'error)) reply))
|
|
(raise-error (alist-ref 'error reply))
|
|
reply)))
|
|
|
|
(define-method (initialize-session (browser <Browser>))
|
|
(set! (session browser) (alist-ref 'sessionId (send browser '() "session" 'POST))))
|
|
|
|
(define-method (terminate-session (browser <Browser>))
|
|
(send browser '() (string-append "session/" (session browser)) 'DELETE))
|
|
|
|
(define-method (send-with-session (browser <Browser>) struct path method)
|
|
(send browser struct
|
|
(string-append "session/" (session browser) "/" path)
|
|
method))
|
|
|
|
(define-method (terminate (browser <Browser>))
|
|
(call/cc
|
|
(lambda (c)
|
|
(with-exception-handler
|
|
(lambda (x) (c #t))
|
|
(lambda ()
|
|
(terminate-session browser)
|
|
(process-signal (pid browser))
|
|
(close-input-port (stdout browser))
|
|
(close-input-port (stderr browser))
|
|
(close-output-port (stdin browser)))))))
|
|
|
|
(define-class <Firefox> (<Browser>))
|
|
|
|
(define (firefox #!key ip ip port port)
|
|
(let-values (((stdout stdin pid stderr) (process* "geckodriver")))
|
|
(make <Firefox>
|
|
'base-url (string-append "http://" (or ip "127.0.0.1")
|
|
":" (or port "4444") "/")
|
|
'stdout stdout
|
|
'stdin stdin
|
|
'stderr stderr
|
|
'pid pid)))
|
|
|
|
(define-method (read-reply (browser <Firefox>))
|
|
(lambda ()
|
|
(alist-ref 'value (json-read))))
|
|
|
|
;; =======================
|
|
;; Main API Implementation
|
|
;; =======================
|
|
|
|
(define-method (status (browser <Browser>))
|
|
(send browser '() "status" 'GET))
|
|
|
|
(define-method (maximize! (browser <Browser>))
|
|
(send-with-session browser '() "maximize" 'POST))
|
|
|
|
(define-method (minimize! (browser <Browser>))
|
|
(send-with-session browser '() "minimize" 'POST))
|
|
|
|
(define-method (fullscreen! (browser <Browser>))
|
|
(send-with-session browser '() "fullscreen" 'POST))
|
|
|
|
(define-method (forward! (browser <Browser>))
|
|
(send-with-session browser '() "forward" 'POST))
|
|
|
|
(define-method (back! (browser <Browser>))
|
|
(send-with-session browser '() "back" 'POST))
|
|
|
|
(define-method (refresh! (browser <Browser>))
|
|
(send-with-session browser '() "refresh" 'POST))
|
|
|
|
(define-method (url (browser <Browser>))
|
|
(send-with-session browser '() "url" 'GET))
|
|
|
|
(define-method (url! (browser <Browser>) (uri <string>))
|
|
(send-with-session browser `((url . ,uri)) "url" 'POST))
|
|
|
|
(define-method (title (browser <Browser>))
|
|
(send-with-session browser '() "title" 'GET))
|
|
|
|
(define-method (source (browser <Browser>))
|
|
(send-with-session browser '() "source" 'GET))
|
|
|
|
;; =============================
|
|
;; Timeout Settings
|
|
;; =============================
|
|
(define-record timeouts script page-load implicit)
|
|
(define-method (get-timeouts (browser <Browser>))
|
|
(let ((result (send-with-session browser '() "timeouts" 'GET)))
|
|
(make-timeouts (alist-ref 'script result)
|
|
(alist-ref 'pageLoad result)
|
|
(alist-ref 'implicit result))))
|
|
(define-method (timeouts! (browser <Browser>) timeouts)
|
|
(let ((timeouts-alist `((script . ,(timeouts-script timeouts))
|
|
(pageLoad . ,(timeouts-page-load timeouts))
|
|
(implicit . ,(timeouts-implicit timeouts)))))
|
|
(send-with-session browser timeouts-alist "timeouts" 'POST)))
|
|
|
|
;; =============================
|
|
;; Elements
|
|
;; =============================
|
|
|
|
(define-record element id)
|
|
(define locator-strategies '((css: . "css selector")
|
|
(linktext: . "link text")
|
|
(partial-linktext: . "partial link text")
|
|
(tag: . "tag name")
|
|
(xpath: . "xpath")))
|
|
(define-method (get-element (browser <Browser>) (locator-strategy <keyword>) (locator <string>))
|
|
(make-element
|
|
(cdar
|
|
(send-with-session browser `((using . ,(alist-ref locator-strategy locator-strategies))
|
|
(value . ,locator))
|
|
"element" 'POST))))
|
|
(define-method (get-elements (browser <Browser>) (locator-strategy <keyword>) (locator <string>))
|
|
(map (lambda (elem) (make-element (cdar elem)))
|
|
(send-with-session browser `((using . ,(alist-ref locator-strategy locator-strategies))
|
|
(value . ,locator))
|
|
"elements" 'POST)))
|
|
|
|
(define-method (element-selected? (browser <Browser>) elem)
|
|
(send-with-session browser '()
|
|
(string-append "element/" (element-id elem) "/selected")
|
|
'GET))
|
|
|
|
(define-method (element-attribute (browser <Browser>) elem attribute)
|
|
(send-with-session browser '()
|
|
(string-append "element/" (element-id elem) "/attribute/" attribute)
|
|
'GET))
|
|
|
|
(define-method (element-property (browser <Browser>) elem property)
|
|
(send-with-session browser '()
|
|
(string-append "element/" (element-id elem) "/property/" property)
|
|
'GET))
|
|
|
|
(define-method (element-css-value (browser <Browser>) elem property)
|
|
(send-with-session browser '()
|
|
(string-append "element/" (element-id elem) "/css/" property)
|
|
'GET))
|
|
|
|
(define-method (element-text (browser <Browser>) elem)
|
|
(send-with-session browser '()
|
|
(string-append "element/" (element-id elem) "/text")
|
|
'GET))
|
|
|
|
(define-method (element-tag-name (browser <Browser>) elem)
|
|
(send-with-session browser '()
|
|
(string-append "element/" (element-id elem) "/name")
|
|
'GET))
|
|
|
|
(define-method (element-rect (browser <Browser>) elem)
|
|
(send-with-session browser '()
|
|
(string-append "element/" (element-id elem) "/rect")
|
|
'GET))
|
|
|
|
(define-method (element-enabled? (browser <Browser>) elem)
|
|
(send-with-session browser '()
|
|
(string-append "element/" (element-id elem) "/enabled")
|
|
'GET))
|
|
|
|
(define-method (element-computed-role (browser <Browser>) elem)
|
|
(send-with-session browser '()
|
|
(string-append "element/" (element-id elem) "/computedrole")
|
|
'GET))
|
|
|
|
(define-method (element-computed-label (browser <Browser>) elem)
|
|
(send-with-session browser '()
|
|
(string-append "element/" (element-id elem) "/computedlabel")
|
|
'GET))
|
|
|
|
(define-method (element-click (browser <Browser>) elem)
|
|
(send-with-session browser '()
|
|
(string-append "element/" (element-id elem) "/click")
|
|
'POST))
|
|
|
|
(define-method (element-clear (browser <Browser>) elem)
|
|
(send-with-session browser '()
|
|
(string-append "element/" (element-id elem) "/clear")
|
|
'POST))
|
|
|
|
(define-method (element-type-text (browser <Browser>) elem text)
|
|
(send-with-session browser `((text . ,text))
|
|
(string-append "element/" (element-id elem) "/value")
|
|
'POST))
|