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
))
10 (in-package #:lw2.login
)
12 (defparameter *sockjs-debug-output
* nil
)
14 (declaim (inline maybe-output
))
15 (defun maybe-output (stream prefix message
)
16 (if stream
(format stream
"~&~A: ~A~%" prefix message
))
19 (defun forwarded-header ()
20 (let ((addr (and (boundp 'hunchentoot
:*request
*) (hunchentoot:real-remote-addr
))))
22 (list (cons "X-Forwarded-For" addr
))
25 (defun sockjs-encode-alist (alist)
26 (encode-json-to-string (list (encode-json-alist-to-string alist
))))
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)
33 (error "Unsupported sockjs message.")))))
35 (defun password-digest (password)
36 (byte-array-to-hex-string
37 (digest-sequence :sha256
38 (string-to-octets password
:external-format
:utf8
))))
40 (defun random-string (length)
41 (coerce (loop repeat length collecting
(code-char (+ (char-code #\a) (ironclad:strong-random
26)))) 'string
))
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
))
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
)
57 (wsd:send client
(maybe-output debug-output
"sockjs sent" (sockjs-encode-alist operation
))))
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
))
67 (defun do-lw2-sockjs-method (method params
)
68 (do-lw2-sockjs-operation `(("msg" .
"method")
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
)))))
84 (defun do-lw2-resume (auth-token)
85 (let ((result (do-lw2-sockjs-method "login" `((("resume" .
,auth-token
))))))
86 (parse-login-result result
)))
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
))
93 (digest .
,(password-digest password
))
94 ("algorithm" .
"sha-256")))))))
95 (parse-login-result result
))))
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
)
103 (digest .
,(password-digest password
))
104 ("algorithm" .
"sha-256")))))))
105 (parse-login-result result
))))
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
)))
115 (define-backend-function do-lw2-reset-password
(auth-token password
)
116 (backend-websocket-login
117 (let ((result (do-lw2-sockjs-method "resetPassword"
119 ((digest .
,(password-digest password
))
120 ("algorithm" .
"sha-256"))))))
121 (parse-login-result result
))))
123 ; resume session ["{\"msg\":\"connect\",\"session\":\"mKvhev8p2f4WfKd6k\",\"version\":\"1\",\"support\":[\"1\",\"pre2\",\"pre1\"]}"]
125 ; logout ["{\"msg\":\"method\",\"method\":\"logout\",\"params\":[],\"id\":\"7\"}"]
127 ; new user ["{\"msg\":\"method\",\"method\":\"createUser\",\"params\":[{\"username\":\"test2\",\"email\":\"test@example.com\",\"password\":{\"digest\":\"37268335dd6931045bdcdf92623ff819a64244b53d0e746d438797349d4da578\",\"algorithm\":\"sha-256\"}}],\"id\":\"8\"}"]
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"))))
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
))))))
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
)))
147 (t (error "Unknown response from LW2 server: ~A" response-json
)))))
149 (defun do-lw2-post-query* (auth-token data
)
150 (cdr (assoc :--id
(do-lw2-post-query auth-token data
))))
152 (define-backend-function lw2-mutation-string
(target-type mutation-type terms fields
)
154 (let* ((mutation-type-string (case mutation-type
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
)))
167 (cdr (assoc :document terms
))
168 (cdr (assoc :set terms
))
169 (map 'list
(lambda (x) (cons (car x
) :null
)) (cdr (assoc :unset terms
)))))
171 (loop for
(k . v
) in terms collect
176 (:document-id
(cons :selector
(alist :document-id v
)))
179 (list (cons :data data
)))))
180 (fields (list (list* :data fields
))))
181 (values (graphql-mutation-string mutation-name terms fields
) mutation-name
))))
183 (define-backend-function do-lw2-mutation
(auth-token target-type mutation-type terms fields
)
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)))))
192 (defun do-lw2-post (auth-token data
)
193 (do-lw2-mutation auth-token
:post
:create
(alist :document data
) '(:--id
:slug
)))
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
))))
200 (defun do-lw2-post-remove (auth-token post-id
)
201 (do-lw2-mutation auth-token
:post
:delete
(alist :document-id post-id
) '(:----typename
)))
203 (defun do-lw2-comment (auth-token data
)
204 (cdr (assoc :--id
(do-lw2-mutation auth-token
:comment
:create
(alist :document data
) '(:--id
)))))
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
)))))
209 (defun do-lw2-comment-remove (auth-token comment-id
)
210 (do-lw2-mutation auth-token
:comment
:delete
(alist :document-id comment-id
) '(----typename)))
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
)))
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)))
221 (define-backend-function do-create-conversation
(auth-token data
)
223 (cdr (assoc :--id
(do-lw2-mutation auth-token
:conversation
:create
(alist :document data
) '(:--id
))))))
225 (define-backend-function generate-message-document
(conversation-id text
)
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
234 :conversation-id conversation-id
)))
236 (define-backend-function do-create-message
(auth-token conversation-id text
)
238 (do-lw2-mutation auth-token
:message
:create
(alist :document
(generate-message-document conversation-id text
)) '(:--id
))))