140 lines
3.8 KiB
Scheme
140 lines
3.8 KiB
Scheme
(define-module (e2e marionette)
|
|
#:export (with-marionette
|
|
start-firefox
|
|
close-firefox
|
|
client-setup
|
|
client-teardown
|
|
navigate
|
|
input-line
|
|
get-display))
|
|
|
|
(use-modules
|
|
(json)
|
|
(scheme base)
|
|
(srfi srfi-9))
|
|
|
|
(define-syntax-rule (with-marionette client body ...)
|
|
(let ((client #f) (pid #f))
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(set! pid (start-firefox))
|
|
(set! client (client-setup)))
|
|
(lambda () body ...)
|
|
(lambda ()
|
|
(when client (client-teardown client))
|
|
(when pid (close-firefox pid))))))
|
|
|
|
(define (start-firefox)
|
|
(let* ((profile-dir (mkdtemp "/tmp/marionette-XXXXXX"))
|
|
(i/o (pipe))
|
|
(pid (spawn "firefox"
|
|
`("firefox" "--marionette" "--headless"
|
|
"--profile" ,profile-dir "about:blank")
|
|
#:output (cdr i/o)
|
|
#:error (cdr i/o))))
|
|
(let loop ((line (read-line (car i/o))))
|
|
(cond
|
|
((string-contains line "Listening on port") #nil)
|
|
((eof-object? line) (format #t "EOF when starting firefox~%"))
|
|
(#t (loop (read-line (car i/o))))))
|
|
(close-port (car i/o))
|
|
(close-port (cdr i/o))
|
|
pid))
|
|
|
|
(define (close-firefox pid)
|
|
(kill pid SIGINT)
|
|
(waitpid pid)
|
|
*unspecified*)
|
|
|
|
(define-record-type client
|
|
(make-client socket msg-num)
|
|
client?
|
|
(socket client-socket)
|
|
(msg-num client-msg-num client-msg-num-set!))
|
|
|
|
(define (client-msg-num-1+! client)
|
|
(client-msg-num-set! client (1+ (client-msg-num client))))
|
|
|
|
(define (open-socket host port)
|
|
(let ((sock (socket PF_INET SOCK_STREAM 0))
|
|
(addr (inet-pton AF_INET host)))
|
|
(connect sock AF_INET addr port)
|
|
sock))
|
|
|
|
(define (handle-start-msg client)
|
|
(let* ((msg (read-msg (client-socket client)))
|
|
(protocol (assoc-ref msg "marionetteProtocol")))
|
|
(unless (= 3 protocol)
|
|
(format #t "Unsupported protocol: ~a~%" protocol))))
|
|
|
|
(define* (client-setup #:key (host "127.0.0.1") (port 2828))
|
|
(let ((client (make-client (open-socket host port) 0)))
|
|
(handle-start-msg client)
|
|
(create-session client)
|
|
client))
|
|
|
|
(define (client-teardown client)
|
|
(close (client-socket client)))
|
|
|
|
(define (add-digit val digit)
|
|
(+ (* val 10) (- digit 48)))
|
|
|
|
(define (read-msg-len sock)
|
|
(let loop ((len 0) (byte (read-u8 sock)))
|
|
(if (eq? byte 58)
|
|
len
|
|
(loop (add-digit len byte)
|
|
(read-u8 sock)))))
|
|
|
|
(define (read-msg sock)
|
|
(let ((len (read-msg-len sock)))
|
|
(json-string->scm (utf8->string (read-bytevector len sock)))))
|
|
|
|
(define (send-msg sock msg)
|
|
(let* ((payload (string->utf8 (scm->json-string msg)))
|
|
(len (bytevector-length payload)))
|
|
(write-bytevector (string->utf8 (number->string len)) sock)
|
|
(write-u8 58 sock)
|
|
(write-bytevector payload sock)))
|
|
|
|
(define (send-command client command params)
|
|
(send-msg (client-socket client)
|
|
(vector 0 (client-msg-num client) command params))
|
|
(client-msg-num-1+! client)
|
|
(let* ((response (read-msg (client-socket client)))
|
|
(error (vector-ref response 2))
|
|
(result (vector-ref response 3)))
|
|
(unless (eq? 'null error)
|
|
(format #t "Error: ~a~%" (assoc-ref error "message")))
|
|
(assoc-ref result "value")))
|
|
|
|
(define (create-session client)
|
|
(send-command client "WebDriver:NewSession" '())
|
|
*unspecified*)
|
|
|
|
(define (navigate client url)
|
|
(send-command client "WebDriver:Navigate" `(("url" . ,url)))
|
|
*unspecified*)
|
|
|
|
(define (find-element client selector)
|
|
(assoc-ref
|
|
(send-command client "WebDriver:FindElement"
|
|
`(("using" . "css selector")
|
|
("value" . ,selector)))
|
|
"element-6066-11e4-a52e-4f735466cecf"))
|
|
|
|
(define (send-keys client text)
|
|
(let ((id (find-element client "body")))
|
|
(send-command client "WebDriver:ElementSendKeys"
|
|
`(("id" . ,id) ("text" . ,text)))))
|
|
|
|
(define (get-element-text client selector)
|
|
(let ((id (find-element client selector)))
|
|
(send-command client "WebDriver:GetElementText" `(("id" . ,id)))))
|
|
|
|
(define (input-line client text)
|
|
(send-keys client (string-append text "\ue007")))
|
|
|
|
(define (get-display client)
|
|
(get-element-text client "#output"))
|