src/lw2-login.lisp

   1 (uiop:define-package #:lw2.login
   2   (:use #:cl #:lw2-viewer.config #:lw2.utils #:lw2.graphql #:lw2.backend #:lw2.backend-modules #:alexandria #:cl-json #:flexi-streams #:websocket-driver-client)
   3   (:import-from #:ironclad #:byte-array-to-hex-string #:digest-sequence)
   4   (:import-from #:lw2.context #:*current-backend*)
   5   (:export #:do-lw2-resume #:do-login #:do-lw2-create-user #:do-lw2-forgot-password #:do-lw2-reset-password
   6            #:do-lw2-post-query #:do-lw2-post-query*
   7            #:do-lw2-post #:do-lw2-post-edit #:do-lw2-post-remove #:do-lw2-comment #:do-lw2-comment-edit #:do-lw2-comment-remove
   8            #:do-lw2-vote #:do-user-edit #:do-create-conversation #:do-create-message))
   9
  10 (in-package #:lw2.login)
  11
  12 (defparameter *sockjs-debug-output* nil)
  13
  14 (declaim (inline maybe-output))
  15 (defun maybe-output (stream prefix message)
  16   (if stream (format stream "~&~A: ~A~%" prefix message))
  17   message)
  18
  19 (defun forwarded-header ()
  20   (let ((addr (and (boundp 'hunchentoot:*request*) (hunchentoot:real-remote-addr))))
  21     (if addr
  22       (list (cons "X-Forwarded-For" addr))
  23       nil)))
  24
  25 (defun sockjs-encode-alist (alist)
  26   (encode-json-to-string (list (encode-json-alist-to-string alist))))
  27
  28 (defun sockjs-decode (msg)
  29   (if (eq (elt msg 0) #\a)
  30     (let ((response (map 'list #'decode-json-from-string (decode-json-from-string (subseq msg 1)))))
  31       (if (= (length response) 1)
  32         (first response)
  33         (error "Unsupported sockjs message.")))))
  34
  35 (defun password-digest (password)
  36   (byte-array-to-hex-string
  37     (digest-sequence :sha256
  38       (string-to-octets password :external-format :utf8))))
  39
  40 (defun random-string (length)
  41   (coerce (loop repeat length collecting (code-char (+ (char-code #\a) (ironclad:strong-random 26)))) 'string))
  42
  43 (defun do-lw2-sockjs-operation (operation)
  44   (let ((client (wsd:make-client (concatenate 'string (websocket-uri *current-backend*) "sockjs/329/" (random-string 8) "/websocket")
  45                                  :additional-headers (forwarded-header)))
  46         (debug-output *sockjs-debug-output*)
  47         (result-semaphore (sb-thread:make-semaphore))
  48         result)
  49     (unwind-protect
  50       (progn
  51         (wsd:start-connection client)
  52         (wsd:on :message client (lambda (encoded-message)
  53                                   (maybe-output debug-output "sockjs recd" encoded-message)
  54                                   (let ((message (sockjs-decode encoded-message)))
  55                                     (switch ((cdr (assoc :msg message)) :test 'equal)
  56                                             ("connected"
  57                                              (wsd:send client (maybe-output debug-output "sockjs sent" (sockjs-encode-alist operation))))
  58                                             ("result"
  59                                              (setf result message)
  60                                              (sb-thread:signal-semaphore result-semaphore))))))
  61         (wsd:send client (maybe-output debug-output "sockjs sent" (sockjs-encode-alist `(("msg" . "connect") ("version" . "1") ("support" . ("1"))))))
  62         (unless (sb-thread:wait-on-semaphore result-semaphore :timeout 10)
  63           (error "Timeout while waiting for LW2 server.")))
  64       (wsd:close-connection client))
  65     result))
  66
  67 (defun do-lw2-sockjs-method (method params)
  68   (do-lw2-sockjs-operation `(("msg" . "method")
  69                              ("method" . ,method)
  70                              ("params" . ,params)
  71                              ("id" . "3"))))
  72
  73 (defun parse-login-result (result)
  74   (let* ((result-inner (cdr (assoc :result result)))
  75          (userid (cdr (assoc :id result-inner)))
  76          (token (cdr (assoc :token result-inner)))
  77          (expires (cdadr (assoc :token-expires result-inner))))
  78     (if (and userid token)
  79       (values userid token nil (and expires (floor expires 1000)))
  80       (if-let (error-message (cdr (assoc :reason (cdr (assoc :error result)))))
  81               (values nil nil error-message)
  82               (error "Unknown response from LW2: ~A" result)))))
  83
  84 (defun do-lw2-resume (auth-token)
  85   (let ((result (do-lw2-sockjs-method "login" `((("resume" . ,auth-token))))))
  86     (parse-login-result result)))
  87
  88 (define-backend-function do-login (user-designator-type user-designator password)
  89   (backend-websocket-login
  90    (let ((result (do-lw2-sockjs-method "login"
  91                    `((("user" (,user-designator-type . ,user-designator))
  92                       ("password"
  93                        (digest . ,(password-digest password))
  94                        ("algorithm" . "sha-256")))))))
  95      (parse-login-result result))))
  96
  97 (define-backend-function do-lw2-create-user (username email password)
  98   (backend-websocket-login
  99    (let ((result (do-lw2-sockjs-method "createUser"
 100                    `((("username" . ,username)
 101                       ("email" . ,email)
 102                       ("password"
 103                        (digest . ,(password-digest password))
 104                        ("algorithm" . "sha-256")))))))
 105      (parse-login-result result))))
 106
 107 (define-backend-function do-lw2-forgot-password (email)
 108   (backend-websocket-login
 109    (let ((result (do-lw2-sockjs-method "forgotPassword"
 110                    `((("email" . ,email))))))
 111      (if-let (error-data (cdr (assoc :error result)))
 112              (values nil (cdr (assoc :reason error-data)))
 113              t))))
 114
 115 (define-backend-function do-lw2-reset-password (auth-token password)
 116   (backend-websocket-login
 117    (let ((result (do-lw2-sockjs-method "resetPassword"
 118                    `(,auth-token
 119                      ((digest . ,(password-digest password))
 120                       ("algorithm" . "sha-256"))))))
 121      (parse-login-result result))))
 122
 123 ; resume session ["{\"msg\":\"connect\",\"session\":\"mKvhev8p2f4WfKd6k\",\"version\":\"1\",\"support\":[\"1\",\"pre2\",\"pre1\"]}"]
 124 ;
 125 ; logout ["{\"msg\":\"method\",\"method\":\"logout\",\"params\":[],\"id\":\"7\"}"]
 126 ;
 127 ; new user ["{\"msg\":\"method\",\"method\":\"createUser\",\"params\":[{\"username\":\"test2\",\"email\":\"test@example.com\",\"password\":{\"digest\":\"37268335dd6931045bdcdf92623ff819a64244b53d0e746d438797349d4da578\",\"algorithm\":\"sha-256\"}}],\"id\":\"8\"}"]
 128
 129 ; (do-lw2-post-query "OCP7NeJEW9fPpYGG_nCN3g0felGTTNd0eg5uiLNQqBR" `((("query" . "mutation vote($documentId: String, $voteType: String, $collectionName: String) { vote(documentId: $documentId, voteType: $voteType, collectionName: $collectionName) { ... on Post { currentUserVotes { _id, voteType, power } } } }") ("variables" ("documentId" . "sqhAntEGpYgFXXH2H") ("voteType" . "upvote") ("collectionName" . "Posts")) ("operationName" . "vote"))))
 130
 131 (defun do-lw2-post-query (auth-token data)
 132   (lw2.backend::do-graphql-debug data)
 133   (let* ((response-data (drakma:http-request (graphql-uri *current-backend*) :method :post
 134                                              :additional-headers (remove-if #'null `(,(if auth-token (cons "authorization" auth-token))
 135                                                                                       ,@(forwarded-header)))
 136                                              :content-type "application/json"
 137                                              :content (encode-json-to-string data)))
 138          (response-json (progn (check-type response-data (vector (unsigned-byte 8)))
 139                                (octets-to-string response-data)))
 140          (response-alist (json:decode-json-from-string response-json))
 141          (res-error (first (cdr (assoc :errors response-alist))))
 142          (res-data (rest (first (cdr (assoc :data response-alist))))))
 143     (cond
 144       (res-error (if (search "not_allowed" (cdr (assoc :message res-error))) (error "LW2 server reports: not allowed.")
 145                    (error "Unknown LW2 error: ~A" res-error)))
 146       (res-data res-data)
 147       (t (error "Unknown response from LW2 server: ~A" response-json)))))
 148
 149 (defun do-lw2-post-query* (auth-token data)
 150   (cdr (assoc :--id (do-lw2-post-query auth-token data))))
 151
 152 (define-backend-function lw2-mutation-string (target-type mutation-type terms fields)
 153   (backend-lw2-legacy
 154    (let* ((mutation-type-string (case mutation-type
 155                                   (:create "New")
 156                                   (:update "Edit")
 157                                   (:delete "Remove")))
 158           (mutation-name (concatenate 'string
 159                                       (if (eq target-type :user)
 160                                           (string-downcase target-type)
 161                                           (string-capitalize target-type))
 162                                       "s" mutation-type-string)))
 163      (values (graphql-mutation-string mutation-name terms fields) mutation-name)))
 164   (backend-lw2-modernized
 165    (let* ((mutation-name (concatenate 'string (string-downcase mutation-type) (string-capitalize target-type)))
 166           (data (append
 167                  (cdr (assoc :document terms))
 168                  (cdr (assoc :set terms))
 169                  (map 'list (lambda (x) (cons (car x) :null)) (cdr (assoc :unset terms)))))
 170           (terms (nconc
 171                   (loop for (k . v) in terms collect
 172                        (case k
 173                          (:document (values))
 174                          (:set (values))
 175                          (:unset (values))
 176                          (:document-id (cons :selector (alist :document-id v)))
 177                          (t (cons k v))))
 178                   (when data
 179                     (list (cons :data data)))))
 180           (fields (list (list* :data fields))))
 181      (values (graphql-mutation-string mutation-name terms fields) mutation-name))))
 182
 183 (define-backend-function do-lw2-mutation (auth-token target-type mutation-type terms fields)
 184   (backend-lw2-legacy
 185    (multiple-value-bind (mutation-string operation-name)
 186        (lw2-mutation-string target-type mutation-type terms fields)
 187      (do-lw2-post-query auth-token `(("query" . ,mutation-string)
 188                                      ("operationName" . ,operation-name)))))
 189   (backend-lw2-modernized
 190    (cdr (assoc :data (call-next-method)))))
 191
 192 (defun do-lw2-post (auth-token data)
 193   (do-lw2-mutation auth-token :post :create (alist :document data) '(:--id :slug)))
 194
 195 (defun do-lw2-post-edit (auth-token post-id set &optional unset)
 196   (let* ((terms (alist :document-id post-id :set set))
 197          (terms (if unset (acons :unset unset terms) terms)))
 198     (do-lw2-mutation auth-token :post :update terms '(:--id :slug))))
 199
 200 (defun do-lw2-post-remove (auth-token post-id)
 201   (do-lw2-mutation auth-token :post :delete (alist :document-id post-id) '(:----typename)))
 202
 203 (defun do-lw2-comment (auth-token data)
 204   (cdr (assoc :--id (do-lw2-mutation auth-token :comment :create (alist :document data) '(:--id)))))
 205
 206 (defun do-lw2-comment-edit (auth-token comment-id set)
 207   (cdr (assoc :--id (do-lw2-mutation auth-token :comment :update (alist :document-id comment-id :set set) '(:--id)))))
 208
 209 (defun do-lw2-comment-remove (auth-token comment-id)
 210   (do-lw2-mutation auth-token :comment :delete (alist :document-id comment-id) '(----typename)))
 211
 212 (defun do-lw2-vote (auth-token target target-type vote-type)
 213   (let ((ret (do-lw2-post-query auth-token
 214                `(("query" . "mutation vote($documentId: String, $voteType: String, $collectionName: String) { vote(documentId: $documentId, voteType: $voteType, collectionName: $collectionName) { ... on Post { baseScore, currentUserVotes { _id, voteType, power } } ... on Comment { baseScore, currentUserVotes { _id, voteType, power } } } }")
 215                   ("variables" ("documentId" . ,target) ("voteType" . ,vote-type) ("collectionName" . ,target-type)) ("operationName" . "vote")))))
 216     (values (cdr (assoc :base-score ret)) (cdr (assoc :vote-type (first (cdr (assoc :current-user-votes ret))))) ret)))
 217
 218 (defun do-user-edit (auth-token user-id data)
 219   (do-lw2-mutation auth-token :user :update (alist :document-id user-id :set data) '(--id)))
 220
 221 (define-backend-function do-create-conversation (auth-token data)
 222   (backend-lw2-legacy
 223    (cdr (assoc :--id (do-lw2-mutation auth-token :conversation :create (alist :document data) '(:--id))))))
 224
 225 (define-backend-function generate-message-document (conversation-id text)
 226   (backend-lw2-legacy
 227    (alist :content
 228           (alist :blocks (loop for para in (ppcre:split "\\n+" text)
 229                             collect (alist :text para :type "unstyled"))
 230                  :entity-map (make-hash-table))
 231           :conversation-id conversation-id))
 232   (backend-lw2-modernized
 233    (alist :body text
 234           :conversation-id conversation-id)))
 235
 236 (define-backend-function do-create-message (auth-token conversation-id text)
 237   (backend-lw2-legacy
 238    (do-lw2-mutation auth-token :message :create (alist :document (generate-message-document conversation-id text)) '(:--id))))