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 #:do-logout
   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   (:unintern #:parse-login-result)
  10   (:recycle #:lw2.utils))
  11
  12 (in-package #:lw2.login)
  13
  14 (defparameter *sockjs-debug-output* nil)
  15
  16 (declaim (inline maybe-output))
  17 (defun maybe-output (stream prefix message)
  18   (if stream (format stream "~&~A: ~A~%" prefix message))
  19   message)
  20
  21 (defun sockjs-encode-alist (alist)
  22   (encode-json-to-string (list (encode-json-alist-to-string alist))))
  23
  24 (defun sockjs-decode (msg)
  25   (if (eq (elt msg 0) #\a)
  26     (let ((response (map 'list #'decode-json-from-string (decode-json-from-string (subseq msg 1)))))
  27       (if (= (length response) 1)
  28         (first response)
  29         (error "Unsupported sockjs message.")))))
  30
  31 (defun password-digest (password &key (algorithm :sha256))
  32   (byte-array-to-hex-string
  33     (digest-sequence algorithm
  34       (string-to-octets password :external-format :utf8))))
  35
  36 (defun do-lw2-sockjs-operation (operation)
  37   (let ((client (wsd:make-client (concatenate 'string (websocket-uri *current-backend*) "sockjs/329/" (random-string 8) "/websocket")
  38                                  :additional-headers (forwarded-header)))
  39         (debug-output *sockjs-debug-output*)
  40         (result-semaphore (sb-thread:make-semaphore))
  41         result)
  42     (unwind-protect
  43       (progn
  44         (wsd:start-connection client)
  45         (wsd:on :message client (lambda (encoded-message)
  46                                   (maybe-output debug-output "sockjs recd" encoded-message)
  47                                   (let ((message (sockjs-decode encoded-message)))
  48                                     (switch ((cdr (assoc :msg message)) :test 'equal)
  49                                             ("connected"
  50                                              (wsd:send client (maybe-output debug-output "sockjs sent" (sockjs-encode-alist operation))))
  51                                             ("result"
  52                                              (setf result message)
  53                                              (sb-thread:signal-semaphore result-semaphore))))))
  54         (wsd:send client (maybe-output debug-output "sockjs sent" (sockjs-encode-alist (alist "msg" "connect"
  55                                                                                               "version" "1"
  56                                                                                               "support" '("1")))))
  57         (unless (sb-thread:wait-on-semaphore result-semaphore :timeout 10)
  58           (error "Timeout while waiting for LW2 server.")))
  59       (wsd:close-connection client))
  60     result))
  61
  62 (defun do-lw2-sockjs-method (method &rest params)
  63   (do-lw2-sockjs-operation (alist :msg "method"
  64                                   :method method
  65                                   :params params
  66                                   :id "3")))
  67
  68 (defun parse-websocket-login-result (result)
  69   (let* ((result-inner (cdr (assoc :result result)))
  70          (userid (cdr (assoc :id result-inner)))
  71          (token (cdr (assoc :token result-inner)))
  72          (expires (cdadr (assoc :token-expires result-inner))))
  73     (if (and userid token)
  74       (values userid token nil (and expires (floor expires 1000)))
  75       (if-let (error-message (cdr (assoc :reason (cdr (assoc :error result)))))
  76               (values nil nil error-message)
  77               (error "Unknown response from LW2: ~A" result)))))
  78
  79 (defun do-graphql-post-query (auth-token data)
  80   (call-with-http-response
  81    #'json:decode-json
  82    (graphql-uri *current-backend*)
  83    :method :post
  84    :want-stream t
  85    :headers (backend-request-headers auth-token t)
  86    :content (encode-json-to-string data)))
  87
  88 (defun do-lw2-resume (auth-token)
  89   (let ((result (do-lw2-sockjs-method "login" (alist :resume auth-token))))
  90     (parse-websocket-login-result result)))
  91
  92 (define-backend-function do-login (user-designator password &key (try-legacy t))
  93   (backend-websocket-login
  94    (let ((result (do-lw2-sockjs-method "login"
  95                    (alist :user (alist "username" user-designator)
  96                           :password (alist :digest (password-digest password)
  97                                            :algorithm "sha-256")))))
  98      (trivia:match result
  99                    ((assoc :error (trivia:alist (:error . "legacy-account")
 100                                                 (:details . (trivia:alist (:salt . legacy-salt)
 101                                                                           (:username . legacy-username)))))
 102                     (if try-legacy
 103                         (do-login user-designator
 104                                   (format nil "~A~A" legacy-salt
 105                                           (password-digest (format nil "~A~A ~A" legacy-salt legacy-username password)
 106                                                            :algorithm :sha1))
 107                                   :try-legacy nil)
 108                         (values nil nil "Incorrect password")))
 109                    (_
 110                     (parse-websocket-login-result result))))))
 111
 112 (define-backend-function do-lw2-create-user (username email password)
 113   (backend-websocket-login
 114    (let ((result (do-lw2-sockjs-method "createUser"
 115                    (alist :username username
 116                           :email email
 117                           :password (alist :digest (password-digest password)
 118                                            :algorithm "sha-256")))))
 119      (parse-websocket-login-result result))))
 120
 121 (define-backend-function do-lw2-forgot-password (email)
 122   (backend-websocket-login
 123    (let ((result (do-lw2-sockjs-method "forgotPassword"
 124                    (alist :email email))))
 125      (if-let (error-data (cdr (assoc :error result)))
 126              (values nil (cdr (assoc :reason error-data)))
 127              t))))
 128
 129 (define-backend-function do-lw2-reset-password (auth-token password)
 130   (backend-websocket-login
 131    (let ((result (do-lw2-sockjs-method "resetPassword"
 132                    auth-token
 133                    (alist :digest (password-digest password)
 134                           :algorithm "sha-256"))))
 135      (parse-websocket-login-result result))))
 136
 137 (define-backend-function do-logout (auth-token)
 138   (backend-websocket-login
 139    (declare (ignore auth-token))))
 140
 141 (defun parse-passport-js-login-result (result)
 142   (let* ((res-errors (first (cdr (assoc :errors result))))
 143          (res-data (cdr (first (cdr (assoc :data result)))))
 144          (token (cdr (assoc :token res-data))))
 145     (if res-errors
 146         (values nil nil (cdr (assoc :message res-errors)))
 147         (let ((user-id (cdr (first (do-lw2-post-query
 148                                        token (alist "query"
 149                                                     (graphql-query-string :current-user nil '(:--id))))))))
 150           (values user-id token nil)))))
 151
 152 (defun do-passport-js-login-operation (operation params)
 153   (parse-passport-js-login-result
 154    (do-graphql-post-query nil (alist :query (graphql-operation-string :mutation operation params '(:token))))))
 155
 156 (define-backend-operation do-login backend-passport-js-login (user-designator password &key try-legacy)
 157   (declare (ignore try-legacy))
 158   (do-passport-js-login-operation :login (alist :username user-designator
 159                                                 :password password)))
 160
 161 (define-backend-operation do-lw2-create-user backend-passport-js-login (username email password)
 162   (do-passport-js-login-operation :signup (alist :username username
 163                                                  :email email
 164                                                  :password password)))
 165
 166 (define-backend-operation do-logout backend-passport-js-login (auth-token)
 167   (do-graphql-post-query auth-token (alist :query (graphql-operation-string :mutation :logout nil '(:token)))))
 168
 169 ; (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"))))
 170
 171 (defun do-lw2-post-query (auth-token data)
 172   (lw2.backend::do-graphql-debug data)
 173   (let* ((response-alist (do-graphql-post-query auth-token data))
 174          (res-errors (cdr (assoc :errors response-alist)))
 175          (res-data (rest (first (cdr (assoc :data response-alist))))))
 176     (cond
 177       (res-errors (lw2.backend:signal-lw2-errors res-errors))
 178       (res-data res-data)
 179       (t (error "Unknown response from LW2 server: ~A" response-alist)))))
 180
 181 (defun do-lw2-post-query* (auth-token data)
 182   (cdr (assoc :--id (do-lw2-post-query auth-token data))))
 183
 184 (define-backend-function lw2-mutation-string (target-type mutation-type terms fields)
 185   (backend-lw2-legacy
 186    (let* ((mutation-type-string (case mutation-type
 187                                   (:create "New")
 188                                   (:update "Edit")
 189                                   (:delete "Remove")))
 190           (mutation-name (concatenate 'string
 191                                       (if (eq target-type :user)
 192                                           (string-downcase target-type)
 193                                           (string-capitalize target-type))
 194                                       "s" mutation-type-string)))
 195      (values (graphql-mutation-string mutation-name terms fields) mutation-name)))
 196   (backend-lw2-modernized
 197    (let* ((mutation-name (concatenate 'string (string-downcase mutation-type) (string-capitalize target-type)))
 198           (selector-type (concatenate 'string (string-capitalize target-type) "SelectorUniqueInput"))
 199           (data-type (concatenate 'string (string-capitalize mutation-type) (string-capitalize target-type) "DataInput"))
 200           (data (append
 201                  (cdr (assoc :document terms))
 202                  (cdr (assoc :set terms))
 203                  (map 'list (lambda (x) (cons (car x) :null)) (cdr (assoc :unset terms)))))
 204           (data (map 'list (lambda (x) (destructuring-bind (k . v) x
 205                                          (if (eq k :body)
 206                                              (cons :contents
 207                                                    (alist :original-contents (alist :data v :type "markdown")
 208                                                           :update-type "minor"
 209                                                           :commit-message ""))
 210                                              x)))
 211                      data))
 212           (terms (nconc
 213                   (loop for (k . v) in terms nconc
 214                        (case k
 215                          (:document nil)
 216                          (:set nil)
 217                          (:unset nil)
 218                          (:document-id (alist :selector (alist :document-id v)))
 219                          (t (list (cons k v)))))
 220                   (when data
 221                     (nalist :data data)))))
 222      (values (with-output-to-string (stream)
 223                (format stream "mutation ~A(~@[$selector: ~A!, ~]$data: ~A!)~3:*{~A(~:[~;selector: $selector, ~]data: $data)"
 224                      mutation-name
 225                      (if (cdr (assoc :selector terms)) selector-type)
 226                      data-type)
 227                (write-graphql-simple-field-list (list (list* :data fields)) stream)
 228                (write-string "}" stream))
 229              mutation-name
 230              terms))))
 231 #|
 232 do-lw2-mutation:
 233
 234 Low level graphQL mutation string builder. This is a good function to override
 235 with a define-backend-operation and translate into the semantics of higher level functions,
 236 that way you can avoid having to recreate them all for each backend service.
 237
 238 auth-token - The authentication token to use with the API, fairly straightforward.
 239 target-type - The type of object that we're mutating
 240 mutation-type - The request method (or analogous equivalent) that we're using
 241 terms - The additional parameters/variables/etc that we're sending to the server with our request
 242 fields - The return values we want to get from the server after it completes our request
 243 |#
 244 (define-backend-function do-lw2-mutation (auth-token target-type mutation-type terms fields)
 245   (backend-lw2-legacy
 246    (multiple-value-bind (mutation-string operation-name variables)
 247        (lw2-mutation-string target-type mutation-type terms fields)
 248      (do-lw2-post-query auth-token (alist "query" mutation-string
 249                                           "variables" variables
 250                                           "operationName" operation-name))))
 251   (backend-lw2-modernized
 252    (cdr (assoc :data (call-next-method)))))
 253
 254 (defun do-lw2-post (auth-token data)
 255   (do-lw2-mutation auth-token :post :create (alist :document data) '(:--id :slug :html-body)))
 256
 257 (defun do-lw2-post-edit (auth-token post-id set &optional unset)
 258   (let* ((terms (alist* :document-id post-id :set set
 259                         (alist-without-null :unset unset))))
 260     (declare (dynamic-extent terms))
 261     (do-lw2-mutation auth-token :post :update terms '(:--id :slug :html-body))))
 262
 263 (defun do-lw2-post-remove (auth-token post-id)
 264   (do-lw2-mutation auth-token :post :delete (alist :document-id post-id) '(:----typename)))
 265
 266 (defun do-lw2-comment (auth-token data)
 267   (do-lw2-mutation auth-token :comment :create (alist :document data) '(:--id :html-body)))
 268
 269 (defun do-lw2-comment-edit (auth-token comment-id set)
 270   (do-lw2-mutation auth-token :comment :update (alist :document-id comment-id :set set) '(:--id :html-body)))
 271
 272 (define-backend-function do-lw2-comment-remove (auth-token comment-id &key reason)
 273   (backend-lw2-legacy
 274    (declare (ignore reason)) ; reasons not supported
 275    (do-lw2-mutation auth-token :comment :delete (alist :document-id comment-id) '(----typename)))
 276   (backend-lw2-modernized
 277    (do-lw2-comment-edit auth-token comment-id (alist :deleted t :deleted-public t
 278                                                      :deleted-reason reason))))
 279
 280 (defun do-lw2-vote (auth-token target-collection target-id vote)
 281   (let* ((mutation (format nil "setVote~:(~A~)" target-collection))
 282          (karma-vote (or (nonempty-string vote)
 283                          (cdr (assoc :karma vote))))
 284          (extended-vote (remove :karma vote :key #'car))
 285          (ret (do-lw2-post-query auth-token
 286                 (alist "query" (graphql-mutation-string mutation
 287                                                         (remove-if #'null
 288                                                                    (alist :document-id target-id
 289                                                                           :vote-type karma-vote
 290                                                                           :extended-vote extended-vote)
 291                                                                    :key #'cdr)
 292                                                         '(:--id :base-score :af :af-base-score :vote-count :extended-score (:all-votes :vote-type :extended-vote-type)
 293                                                           :current-user-vote :current-user-extended-vote))
 294                        "variables" nil
 295                        "operationName" mutation)))
 296          (confirmed-vote (block nil
 297                            (alist-bind (current-user-vote current-user-extended-vote) ret
 298                                        (return (list-cond* (current-user-vote :karma current-user-vote)
 299                                                            current-user-extended-vote))))))
 300     (values confirmed-vote ret)))
 301
 302
 303 (defun do-user-edit (auth-token user-id data)
 304   (do-lw2-mutation auth-token :user :update (alist :document-id user-id :set data) '(--id)))
 305
 306 (define-backend-function do-create-conversation (auth-token data)
 307   (backend-lw2-legacy
 308    (cdr (assoc :--id (do-lw2-mutation auth-token :conversation :create (alist :document data) '(:--id))))))
 309
 310 (define-backend-function generate-message-document (conversation-id text)
 311   (backend-lw2-legacy
 312    (alist :content
 313           (alist :blocks (loop for para in (ppcre:split "\\n+" text)
 314                             collect (alist :text para :type "unstyled"))
 315                  :entity-map (make-hash-table))
 316           :conversation-id conversation-id))
 317   (backend-lw2-modernized
 318    (alist :body text
 319           :conversation-id conversation-id)))
 320
 321 (define-backend-function do-create-message (auth-token conversation-id text)
 322   (backend-lw2-legacy
 323    (do-lw2-mutation auth-token :message :create (alist :document (generate-message-document conversation-id text)) '(:--id))))