2022-05-10 10:18:17 +00:00
|
|
|
;; -*- geiser-scheme: chicken -*-
|
|
|
|
|
|
|
|
(import (r7rs))
|
|
|
|
(import (scheme base))
|
|
|
|
(import (srfi 180))
|
2022-05-13 00:57:33 +00:00
|
|
|
(import coops coops-extras coops-primitive-objects coops-utils)
|
|
|
|
(import (chicken process)
|
|
|
|
(chicken gc)
|
|
|
|
(chicken condition))
|
|
|
|
(import uri-common)
|
2022-05-12 00:12:50 +00:00
|
|
|
(import intarweb)
|
2022-05-10 10:18:17 +00:00
|
|
|
(import http-client)
|
|
|
|
|
2022-05-12 00:12:50 +00:00
|
|
|
(define-class <Browser> ()
|
2022-05-13 00:57:33 +00:00
|
|
|
((base-url accessor: base-url)
|
|
|
|
(stdout accessor: stdout)
|
|
|
|
(stdin accessor: stdin)
|
|
|
|
(stderr accessor: stderr)
|
|
|
|
(pid accessor: pid)
|
|
|
|
(session accessor: session)))
|
2022-05-12 00:12:50 +00:00
|
|
|
|
|
|
|
(define-method (initialize-instance (browser <Browser>))
|
2022-05-13 00:57:33 +00:00
|
|
|
(set-finalizer! browser (lambda (obj) (terminate browser)))
|
|
|
|
(call-next-method))
|
|
|
|
|
|
|
|
(define-method (send (browser <Browser>) struct path method)
|
|
|
|
(let ((uri (string-append (base-url browser) path)))
|
|
|
|
(with-input-from-request
|
|
|
|
(make-request method: method
|
|
|
|
uri: (uri-reference uri)
|
|
|
|
headers: (headers `((content-type application/json))))
|
|
|
|
(lambda () (json-write struct))
|
|
|
|
json-read)))
|
|
|
|
|
|
|
|
(define-method (initialize-session (browser <Browser>))
|
|
|
|
(set! (session browser) (alist-ref 'sessionId (send browser '() "session" 'POST))))
|
2022-05-12 00:12:50 +00:00
|
|
|
|
2022-05-13 00:57:33 +00:00
|
|
|
(define-method (terminate-session (browser <Browser>))
|
|
|
|
(send browser '() (string-append "session/" (session browser)) 'DELETE))
|
|
|
|
|
|
|
|
;; TODO: Apparently session has to be closed first
|
|
|
|
(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)))))))
|
2022-05-12 00:12:50 +00:00
|
|
|
|
|
|
|
(define-class <Firefox> (<Browser>))
|
|
|
|
|
|
|
|
(define (firefox #!key ip ip port port)
|
|
|
|
(let-values (((stdout stdin pid stderr) (process* "geckodriver")))
|
2022-05-13 00:57:33 +00:00
|
|
|
(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 (send (browser <Firefox>) struct path method)
|
|
|
|
(let ((result (call-next-method)))
|
|
|
|
(alist-ref 'value result)))
|