;; -*- 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))