diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/call-id.lisp | 15 | ||||
| -rw-r--r-- | src/config.lisp | 54 | ||||
| -rw-r--r-- | src/devtools-protocol.lisp | 45 | ||||
| -rw-r--r-- | src/macro.lisp | 14 | ||||
| -rw-r--r-- | src/main.lisp | 141 | ||||
| -rw-r--r-- | src/option.lisp | 82 | ||||
| -rw-r--r-- | src/package.lisp | 3 |
7 files changed, 354 insertions, 0 deletions
diff --git a/src/call-id.lisp b/src/call-id.lisp new file mode 100644 index 0000000..a21e6ab --- /dev/null +++ b/src/call-id.lisp @@ -0,0 +1,15 @@ +(in-package :extreload) + +(defclass call-id () + ((id + :initform 0 + :reader id + :documentation "Current call ID.")) + + (:documentation "An incrementing identifier.")) + +(defgeneric next-call-id (call-id) + (:documentation "Increment the call ID and return the result.")) + +(defmethod next-call-id ((call-id call-id)) + (incf (slot-value call-id 'id))) diff --git a/src/config.lisp b/src/config.lisp new file mode 100644 index 0000000..ab973cd --- /dev/null +++ b/src/config.lisp @@ -0,0 +1,54 @@ +(in-package :extreload) + +(defclass config () + ((socket-url + :initarg :socket-url + :reader socket-url + :documentation "DevTools WebSocket URL") + (extension-ids + :initarg :extension-ids + :reader extension-ids + :documentation "Sequence of extension IDs") + (reload-current-tab + :initarg :reload-current-tab + :initform nil + :reader reload-current-tab + :documentation "True if the current tab should be reloaded") + (debug-output + :initarg :debug-output + :initform nil + :reader debug-output + :documentation "True to enable debug output") + + (ws-client + :reader ws-client + :documentation "WebSocket client"))) + +(defmethod print-object ((object config) stream) + (print-unreadable-object (object stream :type t) + (with-slots (socket-url + extension-ids + reload-current-tab + debug-output + ws-client) + object + (format + stream + ":socket-url ~s :extension-ids ~s :reload-current-tab ~s :debug-output ~s :ws-client ~s" + socket-url extension-ids reload-current-tab debug-output ws-client)))) + +(defun make-config (&key socket-url + extension-ids + reload-current-tab + debug-output) + "Initialise a new config." + (let ((config (make-instance 'config + :socket-url socket-url + :extension-ids extension-ids + :reload-current-tab reload-current-tab + :debug-output debug-output))) + + ;; Initialise a new websocket-driver client + (setf (slot-value config 'ws-client) (wsd:make-client socket-url)) + + config)) diff --git a/src/devtools-protocol.lisp b/src/devtools-protocol.lisp new file mode 100644 index 0000000..2d67033 --- /dev/null +++ b/src/devtools-protocol.lisp @@ -0,0 +1,45 @@ +;;;; DevTools Protocol messages. + +(in-package :extreload) + +(defun target-get-targets-msg (call-id) + "DevTools Protocol `Target.getTargets` message." + (jsown:to-json + `(:obj ("id" . ,call-id) + ("method" . "Target.getTargets")))) + +(defun target-attach-to-target-msg (call-id target-id) + "DevTools Protocol `Target.attachToTarget` message." + (jsown:to-json + `(:obj ("id" . ,call-id) + ("method" . "Target.attachToTarget") + ("params" . (:obj ("targetId" . ,target-id) + ("flatten" . t)))))) + +(defun target-attached-to-target-msg-p (message) + "Returns true if `message` is `Target.attachedToTarget`." + (equal + (json-obj-get message "method") + "Target.attachedToTarget")) + +(defun runtime-evaluate-msg (call-id session-id expression) + "DevTools Protocol `Runtime.evaluate` message." + (jsown:to-json + `(:obj ("id" . ,call-id) + ("sessionId" . ,session-id) + ("method" . "Runtime.evaluate") + ("params" . (:obj ("expression" . ,expression)))))) + +(defun runtime-evaluate-msg-p (message) + "Returns true if `message` is a response to `Runtime.evaluate`." + (jsown:keyp (json-obj-get message "result") "sessionId")) + +(defun runtime-evaluate-exception-p (message) + "Returns true if `message` describes a runtime exception" + (jsown:keyp (json-obj-get message "result") "exceptionDetails")) + +(defun parse-get-targets-response (response) + "Parses a list of target info objects from the response to `Target.getTargets`." + (let* ((result (json-obj-get response "result")) + (targetInfos (json-obj-get result "targetInfos"))) + targetInfos)) diff --git a/src/macro.lisp b/src/macro.lisp new file mode 100644 index 0000000..18c7d21 --- /dev/null +++ b/src/macro.lisp @@ -0,0 +1,14 @@ +(in-package :extreload) + +(defmacro filter (predicate list-form) + "Returns a sequence that only includes elements of `list-form` that satisfy +the test of `predicate`." + `(remove-if-not ,predicate ,list-form)) + +(defmacro with-websocket-connection ((client) &body body) + "Open a WebSocket connection on `client` and run `body` forms. The connection +is automatically closed at the end of execution." + `(progn + (wsd:start-connection ,client) + (unwind-protect (progn ,@body) + (wsd:close-connection ,client)))) diff --git a/src/main.lisp b/src/main.lisp new file mode 100644 index 0000000..5e44158 --- /dev/null +++ b/src/main.lisp @@ -0,0 +1,141 @@ +(in-package :extreload) + +(defvar *wg* (wait-group:make-wait-group)) +(defvar *devtools-root-call-id* (make-instance 'call-id) + "DevTools Protocol call ID.") +(defvar *devtools-secondary-call-id* (make-instance 'call-id) + "DevTools Protocol call ID used for messages to individual target sessions.") + +(defconstant +timeout-seconds+ 5 + "Global timeout. The program will exit at the end of this delay.") + +(defun main () + (handler-bind ((error #'(lambda (e) + (exit-with-error e sysexits:+unavailable+)))) + + ;; Store the config as a global. + (defvar *config* (parse-options)) + + (trivial-timeout:with-timeout (+timeout-seconds+) + (with-websocket-connection ((ws-client *config*)) + (wsd:on :message (ws-client *config*) + #'(lambda (message) + (ws-on-message + message + (extension-ids *config*) + *config*))) + + (websocket-send + (ws-client *config*) + (target-get-targets-msg + (next-call-id *devtools-root-call-id*))) + + (wait-group:wait *wg*))))) + +(defun ws-on-message (message extension-ids config) + "Called when a WebSocket message is received." + (let* ((response (jsown:parse message)) + (targets (parse-get-targets-response response))) + (when (debug-output config) + (format t "Response: ~a~%" response) + (format t "~a~%" *wg*)) + + (when targets + (let ((targets (extension-targets targets))) + + (attach-extensions targets extension-ids))) + + (if (target-attached-to-target-msg-p response) + (reload-extension (json-obj-get + (json-obj-get response "params") + "sessionId"))) + + (when (and (reload-current-tab config) + (runtime-evaluate-msg-p response)) + (reload-tab (json-obj-get + (json-obj-get response "result") + "sessionId"))) + + ;; Failed to reload tab. + (when (runtime-evaluate-exception-p response) + ;; `reload-tab` adds an extra increment to the wait group. If the call + ;; fails, we only receive one message instead of two, so the wait group + ;; must be decremented to match. + (wait-group:done *wg*) + + (reload-tab (json-obj-get response "sessionId"))) + + (wait-group:done *wg*))) + +(defun json-obj-get (obj key) + "Get the value of `key` from `obj` (a `jsown` object). Return nil if `key` is +not defined." + (handler-case + (jsown:val obj key) + (simple-error (e) + (let ((s (format nil "~A" e))) + (if (search "not available" s) + nil))))) + +(defun attach-extensions (targets extension-ids) + "Attach to all extensions in `targets` that match the IDs in +`extension-ids`." + (labels ((requested-extension-p (target) + (find-if + #'(lambda (id) + (uiop:string-prefix-p + (concatenate 'string "chrome-extension://" id) + (json-obj-get target "url"))) + extension-ids))) + + (dolist (extension (filter #'requested-extension-p targets)) + (attach-to-target extension)))) + +(defun attach-to-target (extension) + "Send a message to the target in `extension` asking to attach to the target." + (let ((target-id (json-obj-get extension "targetId"))) + (websocket-send (ws-client *config*) + (target-attach-to-target-msg + (next-call-id *devtools-root-call-id*) + target-id)))) + +(defun reload-extension (session-id) + "Send a message to an extension page corresponding to `session-id`, telling +the target extension to reload itself." + (websocket-send + (ws-client *config*) + (runtime-evaluate-msg + (next-call-id *devtools-secondary-call-id*) + session-id + "chrome.runtime.reload()"))) + +(defun reload-tab (session-id) + "Send a message to an extension page corresponding to `session-id`, telling +the target to reload the current tab." + + ;; Two response messages always come back from the `chrome.tabs.reload()` + ;; messages, so we need to add a second increment to the wait group. + (wait-group:add *wg*) + + (websocket-send + (ws-client *config*) + (runtime-evaluate-msg + (next-call-id *devtools-secondary-call-id*) + session-id + "chrome.tabs.reload()"))) + +(defun extension-targets (targets) + "Filter `targets`, returning a list of targets corresponding to extensions." + (labels ((extensionp (target) + (string= (json-obj-get target "type") + "background_page"))) + + (filter #'extensionp targets))) + +(defun websocket-send (client data) + "Send `data` to WebSocket `client` and increment `*wg*`." + (when (debug-output *config*) + (format t "Sending: ~a~%" data)) + + (wsd:send client data) + (wait-group:add *wg*)) diff --git a/src/option.lisp b/src/option.lisp new file mode 100644 index 0000000..6f9129c --- /dev/null +++ b/src/option.lisp @@ -0,0 +1,82 @@ +;;;; Command line options. + +(in-package :extreload) + +;; Available command line options. +(opts:define-opts + (:name :socket-url + :description "DevTools protocol WebSocket URL" + :long "socket-url" + :arg-parser #'identity + :meta-var "SOCKET_URL") + (:name :reload-current-tab + :description "pass this to reload the active Chrome tab" + :long "reload-current-tab") + (:name :debug + :description "print debug output" + :long "debug") + (:name :help + :description "print this help menu" + :short #\h + :long "help") + (:name :version + :description "show the program version" + :short #\V + :long "version")) + +(defmacro when-option ((options option) &body body) + "When `option` is present in `options`, run `body`." + `(let ((value (getf ,options ,option))) + (when value + ,@body))) + +(defun exit-with-error (condition exit-code) + "Print the error associated with `condition` on standard error, then exit +with code `exit-code`." + (format *error-output* "error: ~a~%" condition) + + (opts:exit exit-code)) + +(defun handle-option-error (condition) + "Handle errors related to command line options. Prints the error specified by +`condition` and exits with EX_USAGE." + (exit-with-error condition sysexits:+usage+)) + +(defun parse-options () + "Parse command line options." + (multiple-value-bind (options free-args) + (handler-bind + ((opts:unknown-option #'handle-option-error) + (opts:missing-arg #'handle-option-error) + (opts:arg-parser-failed #'handle-option-error) + (opts:missing-required-option #'handle-option-error)) + + (opts:get-opts)) + + (when-option (options :help) + (opts:describe + :usage-of "extreload" + :args "EXTENSION_ID...") + + (opts:exit sysexits:+usage+)) + + (when-option (options :version) + (format t "~a~%" (asdf:component-version (asdf:find-system :extreload))) + + (opts:exit sysexits:+ok+)) + + (when (null (getf options :socket-url)) + (format *error-output* "error: '--socket-url' is required~%") + + (opts:exit sysexits:+usage+)) + + ;; Error if no extension IDs were given. + (when (null free-args) + (format *error-output* "error: missing extension IDs~%") + + (opts:exit sysexits:+usage+)) + + (make-config :socket-url (getf options :socket-url) + :reload-current-tab (getf options :reload-current-tab) + :debug-output (getf options :debug) + :extension-ids free-args))) diff --git a/src/package.lisp b/src/package.lisp new file mode 100644 index 0000000..03ee677 --- /dev/null +++ b/src/package.lisp @@ -0,0 +1,3 @@ +(defpackage :extreload + (:use :cl) + (:export :main)) |