src/web-push.lisp

   1 (uiop:define-package #:lw2.web-push
   2   (:use #:cl #:alexandria #:lw2.utils #:lw2.conditions)
   3   (:export #:get-vapid-public-key #:send-notification))
   4
   5 (in-package #:lw2.web-push)
   6
   7 (defparameter *vapid-key-filename* (asdf:system-relative-pathname :lw2-viewer "webpush.vapid.key"))
   8 (sb-ext:defglobal *vapid-key* nil)
   9 (sb-ext:defglobal *vapid-header-cache* (make-hash-table :test 'equal))
  10 (sb-ext:defglobal *vapid-header-cache-lock* (sb-thread:make-mutex :name "vapid header cache lock"))
  11
  12 (defun call-with-private-file (fn name)
  13   (let ((fd nil))
  14     (unwind-protect
  15          (progn
  16            (setf fd (sb-posix:open name (logior sb-posix:o-creat sb-posix:o-rdwr) #o600))
  17            (funcall fn (sb-sys:make-fd-stream fd :input t :output t)))
  18       (when fd (sb-posix:close fd)))))
  19
  20 (defun invoke-node-process (command &optional (output #'json:decode-json))
  21   (uiop:run-program "node js-foreign-lib/web-push.js"
  22                     :input (list command)
  23                     :output output
  24                     :error-output *error-output*))
  25
  26 (defun ensure-vapid-key ()
  27   (unless *vapid-key*
  28     (labels ((read-vapid-key (stream)
  29                (setf *vapid-key* (json:decode-json stream))))
  30       (log-and-ignore-errors
  31        (with-open-file (stream *vapid-key-filename* :direction :input :if-does-not-exist nil)
  32          (if stream
  33              (read-vapid-key stream)
  34              (call-with-private-file (lambda (stream)
  35                                        (invoke-node-process "webPush.generateVAPIDKeys()" stream)
  36                                        (file-position stream 0)
  37                                        (read-vapid-key stream))
  38                                      *vapid-key-filename*)))))))
  39
  40 (ensure-vapid-key)
  41
  42 (defun get-vapid-public-key ()
  43   (cdr (assoc :public-key *vapid-key*)))
  44
  45 (defun generate-vapid-headers (origin)
  46   (let* ((result-json
  47           (invoke-node-process
  48            (format nil "webPush.getVapidHeaders(~{~A~^,~});"
  49                    (mapcar #'json:encode-json-to-string
  50                            (list origin "mailto:test@example.com"
  51                                  (cdr (assoc :public-key *vapid-key*)) (cdr (assoc :private-key *vapid-key*)) "aes128gcm")))))
  52          (result-string (cdar result-json))
  53          (result-parts (nth-value 1
  54                                   (ppcre:scan-to-strings "vapid t=([^,]+), k=([^,]+)" result-string))))
  55     (assert (= (length result-parts) 2))
  56     (alist :authorization (format nil "WebPush ~A" (aref result-parts 0))
  57            :crypto-key (format nil "p256ecdsa=~A" (aref result-parts 1)))))
  58
  59 (defun get-vapid-headers (origin)
  60   (let ((unlocked-value
  61          (sb-thread:with-mutex (*vapid-header-cache-lock*)
  62            (let ((value (gethash origin *vapid-header-cache*))
  63                  (current-time (get-unix-time)))
  64              (if (and value (< current-time (+ (car value) (* 60 60 12))))
  65                  (cdr value)
  66                  (setf (gethash origin *vapid-header-cache*)
  67                        (sb-thread:make-thread (lambda ()
  68                                                 (let ((vapid (generate-vapid-headers origin)))
  69                                                   (sb-thread:with-mutex (*vapid-header-cache-lock*)
  70                                                     (setf (gethash origin *vapid-header-cache*) (cons current-time vapid)))
  71                                                   vapid))
  72                                               :name "generate vapid headers")))))))
  73     (typecase unlocked-value
  74       (sb-thread:thread (sb-thread:join-thread unlocked-value))
  75       (t unlocked-value))))
  76
  77 (defun send-notification (endpoint &key (ttl (* 60 60 24)))
  78   ;; we don't support content yet since it requires encryption
  79   (let* ((endpoint-uri (quri:uri endpoint))
  80          (origin (concatenate 'string (quri:uri-scheme endpoint-uri) "://" (quri:uri-authority endpoint-uri)))
  81          (headers (alist* :ttl ttl
  82                           :content-encoding "identity"
  83                           (get-vapid-headers origin))))
  84     (dex:request endpoint
  85                  :method :post
  86                  :headers headers
  87                  :keep-alive nil)))