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