chat-backend.rkt 20 KB
Newer Older
1
2
#lang racket

3
4
5
(provide ^chatroom
         spawn-user-controller-pair)

6
7
8
9
(require goblins
         goblins/actor-lib/methods
         goblins/actor-lib/actor-sealers
         goblins/actor-lib/common
10
         goblins/actor-lib/ward
11
12
         goblins/actor-lib/pubsub
         goblins/actor-lib/joiners
13
         goblins/actor-lib/let-on
14
         goblins/ocapn/structs-urls)
15

16
17
(require pk)

18
19
20
21
;;; =============
;;; Backend stuff
;;; =============

22

23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
;; When we're given a user, it's always sealed with the presence
;; sealer on the persona. This is to ensure that we can trust that
;; this user actor can represent the persona.
(define (unseal-user sealed-user persona)
  (define presence-unsealer-vow (<- persona 'get-presence-unsealer))
  (on (<- presence-unsealer-vow sealed-user)
      (lambda (unsealed-user)
        unsealed-user)
      #:catch
      (lambda (err)
        (error "Failed to unseal the presence with the unsealer"))
      #:promise? #t))

(define (make-sealed-user persona persona-incanter user)
  (on (<- persona-incanter persona 'get-presence-sealer)
      (lambda (presence-sealer)
        (on (<- presence-sealer user)
            (lambda (sealed-user)
              sealed-user)
            #:promise? #t))
      #:promise? #t))

45
(define (call-with-unsealed-user-message from-user sealed-msg
46
47
48
49
50
51
52
53
                                         proc)
  ;; Unseal from the user
  (define user-chat-unsealer-vow
    (<- from-user 'get-chat-unsealer))
  (define unsealed-msg-vow
    (<- user-chat-unsealer-vow sealed-msg))
  (on unsealed-msg-vow proc))

54
(define (^chatroom _bcom name)
55
56
57
  (define-spawned subscribers
    ^hasheq)

58
59
60
61
62
63
  (define send-to-subscribers
    (make-keyword-procedure
     (lambda (kws kw-vals . args)
       (for ([subscriber ($ subscribers 'values)])
         (keyword-apply <-np kws kw-vals subscriber args)))))

64
  (define (^user-messaging-channel bcom associated-presence-pair user-inbox)
65
    (define main-beh
66
67
      (methods
       [(leave)
68
        ($ subscribers 'remove associated-presence-pair)
69
70
71
        (send-to-subscribers 'user-left
                             (associated-presence-pair 'sealed-user)
                             (associated-presence-pair 'persona))
72
73
74
75
76
77
        (bcom dead-beh)]
       ;; In this version we don't even bother checking if the user
       ;; was the one that sent the message or not... instead we structure
       ;; things such that the message will error out when recieved by
       ;; clients.  However it is nicer to check the predicate probably.
       [(send-message sealed-message)
78
79
80
81
        (send-to-subscribers 'new-message
                             (associated-presence-pair 'sealed-user)
                             (associated-presence-pair 'persona)
                             sealed-message)
82
        'OK]
83
84
       ;; This state should be propagated (but can be occasionally stale)
       ;; so I don't know that we really need to have this method...
85
       [(list-users)
86
87
        (for/set ([presence-pair ($ subscribers 'keys)])
          (presence-pair 'persona))]))
88
89
90
91
    (define dead-beh
      (lambda _ 'CONNECTION-CLOSED))
    main-beh)

92
  (define (^finalize-subscription bcom associated-sealed-user associated-persona)
93
    (define (pre-finalize-beh user-inbox)
94
      ;; send to subscribers other than this user first
95
96
      (send-to-subscribers 'user-joined associated-sealed-user associated-persona)

97
      ;; now subscribe this user
98
      (define associated-presence-pair
99
100
101
        (methods
         [(persona) associated-persona]
         [(sealed-user) associated-sealed-user]))
102
103
104
105
      ($ subscribers 'set
         associated-presence-pair
         user-inbox)
      
106
107
      ;; send to the user who just joined a bunch of messages
      ;; as if everyone *else* already in the channel just joined
108
109
      (for [(presence-pair ($ subscribers 'keys))]
        (<-np user-inbox 'user-joined (presence-pair 'sealed-user) (presence-pair 'persona)))
110
      (bcom post-finalize-beh
111
112
113
            ;; We need to give both the user messaging channel as a way
            ;; for the user to communicate with us but also we should give
            ;; the current list of users, since that might change later
114
            (spawn ^user-messaging-channel associated-presence-pair user-inbox)))
115
116
117
118
119
    (define (post-finalize-beh . _args)
      (error "Already finalized!"))
    pre-finalize-beh)

  (methods
120
   [(self-proposed-name) name]
121
122
123
   ;; Return a sealed user messaging channel, sealed for that user
   ;; specifically.  If they can open it they can complete the
   ;; subscription process.
124
125
126
127
   [(subscribe sealed-user persona)
    (define unsealed-user-vow
      (unseal-user sealed-user persona))

128
    (define subscription-sealer-vow
129
      (<- unsealed-user-vow 'get-subscription-sealer))
130
    ;; TODO: throw an error if the user is already in the chat
131
    
132
    (<- subscription-sealer-vow
133
134
        (spawn ^finalize-subscription
               sealed-user persona))]))
135
136
137
138


;;; Here we spawn a user and also an actor that can control that user
;;; Return both as a cons cell of (user . user-controller)
139
(define (spawn-user-controller-pair persona persona-manager enliven-facet)
140
141
142
143
144
145
146
  (define-values (chat-msg-sealer chat-msg-unsealer chat-msg-sealed?)
    (spawn-sealer-triplet))
  (define-values (subscription-sealer subscription-unsealer subscription-sealed?)
    (spawn-sealer-triplet))
  (define-values (controller-warden controller-incanter)
    (spawn-warding-pair))

147
  (define-spawned rooms->inboxes/channels
148
149
150
    ^hasheq)
  (define-spawned client-subscribers
    ^seteq)
151
  (define-spawned personas->proxy-users
Jessica Tallon's avatar
Jessica Tallon committed
152
    ^hasheq)
153
154
155
156
157
158
  
  ;; Here's our user object.  More or less it's a profile that provides
  ;; a self-proposed name, an unsealer, and a predicate to check whether
  ;; we sealed things
  (define (^user _bcom)
    (methods
Jessica Tallon's avatar
Jessica Tallon committed
159
     #:extends persona
160
161
162
163
164
     [(get-chat-sealed?)
      chat-msg-sealed?]
     [(get-chat-unsealer)
      chat-msg-unsealer]
     [(get-subscription-sealer)
Jessica Tallon's avatar
Jessica Tallon committed
165
166
167
      subscription-sealer]
     [(get-persona)
      persona]))
168
169
170
  (define user
    (spawn ^user))

171
172
  ;; This is kind of a kluge but is good enough to paper over the
  ;; "sending a bunch of messages unnecessarily" problem for now
Jessica Tallon's avatar
Jessica Tallon committed
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
  (define (^proxy-user _bcom user)
    (define (^proxy-handler _bcom method)
      (define cache (spawn ^cell))
      (lambda _
        (if ($ cache)
            ($ cache)
            (on (<- user method)
                (lambda (result)
                  ($ cache result)
                  result)
                #:promise? #t))))

    (define cached-self-proposed-name
      (spawn ^proxy-handler 'self-proposed-name))
    (define cached-get-chat-sealed?
      (spawn ^proxy-handler 'get-chat-sealed?))
    (define cached-get-subscription-sealer
      (spawn ^proxy-handler 'get-subscription-sealer))

    (methods
193
     #:extends user
Jessica Tallon's avatar
Jessica Tallon committed
194
195
196
197
     [(self-proposed-name) ($ cached-self-proposed-name)]
     [(get-chat-sealed?) ($ cached-get-chat-sealed?)]
     [(get-subscription-sealer) ($ cached-get-subscription-sealer)]))

198
199
200
201
202
203
204
  (define send-to-clients
    (make-keyword-procedure
     (lambda (kws kw-vals . args)
       (for ([client ($ client-subscribers 'data)])
         (keyword-apply <-np kws kw-vals client args)))))

  (define (^user-inbox bcom context)
205
206
207
208
209
210
    (define room-users
      (spawn ^seteq))
    (define inbox-pubsub
      (spawn ^pubsub))

    (define controller-methods
211
212
      (methods
       [(revoke)
213
        (bcom revoked-beh)]
214
       ;; TODO: Maybe call client-subscribe
215
216
217
       [(subscribe subscriber)
        ($ inbox-pubsub 'subscribe subscriber)
        (for ([user ($ room-users 'data)])
218
          (pk 'controller-methods 'user-joined)
219
          (<-np subscriber 'user-joined user))]))
220
221
    (define public-methods
      (methods
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
       [(new-message sealed-user persona sealed-msg)
        (on (unseal-user sealed-user persona)
            (lambda (from-user)
              ;; The purpose of calling call-with-unsealed-user-message is to
              ;; ensure that it unseals correctly
              (let ([proxy-user ($ personas->proxy-users 'ref persona)])
                (call-with-unsealed-user-message
                 proxy-user sealed-msg
                 (lambda (unwrapped-user-msg)
                   ($ inbox-pubsub 'publish
                      'new-message context proxy-user unwrapped-user-msg))))))]
       [(user-joined sealed-user persona)
        (on (unseal-user sealed-user persona)
            (lambda (user)
              (let ([proxy-user (spawn ^proxy-user user)])
                ($ personas->proxy-users 'set persona proxy-user)
                ($ room-users 'add user)
                ($ inbox-pubsub 'publish
                   'user-joined user))))]
       [(user-left sealed-user persona)
        (on (unseal-user sealed-user persona)
            (lambda (user)
              ($ personas->proxy-users 'remove persona)
              ($ room-users 'remove user)
              ($ inbox-pubsub 'publish
                 'user-left context sealed-user persona)))]
248
       [(context) context]))
249
250
251
252
253
254

    ;; Now for the two primary states.
    ;; Either we are in an "enabled" state or a "revoked" state.

    ;; When enabled, main access is enabled
    (define enabled-beh
255
      (ward controller-warden controller-methods
256
257
258
259
260
261
262
263
264
265
            #:extends public-methods))

    ;; but when revoked, only admin access is enabled
    (define revoked-beh
      (make-keyword-procedure
       (lambda _
         (error "Revoked!"))))

    enabled-beh)

266
  ;; Basically a channel which is set up with our sealers.
267
  (define (^authenticated-channel _bcom room-channel inbox)
268
269
270
    (methods
     [(send-message contents)
      (<- room-channel 'send-message ($ chat-msg-sealer contents))]
271
     ;; TODO: maybe rename to subscribe-client
272
273
274
275
276
277
     [(subscribe subscriber)
      (define ((^unsubscribe bcom))
        ($ controller-incanter inbox 'unsubscribe subscriber))
      ($ controller-incanter inbox 'subscribe subscriber)
      ;; give the user a way to unsubscribe
      `#(OK ,(spawn ^unsubscribe))]
278
279
     #:extends room-channel))

280
  ;; TODO: resume here with all the race condition stuff
281
  (define (^user-controller _bcom)
282
283
    (define persona->sturdyref (spawn ^hasheq))
    (define (get-and-verify-persona-sturdyref-vow persona)
Jessica Tallon's avatar
Jessica Tallon committed
284
285
286
      (define cached-persona ($ persona->sturdyref 'ref persona #f))
      (if cached-persona
          cached-persona
287
288
289
290
291
292
293
294
          (on (<- persona 'get-sturdyref)
              (lambda (persona-sturdyref)
                (on (ensure-same (<- enliven-facet persona-sturdyref) persona)
                    (lambda (verified-refr)
                      ($ persona->sturdyref 'set persona persona-sturdyref)
                      persona-sturdyref)
                    #:promise? #t))
              #:promise? #t)))
295
    (methods
296
     [(whoami) user]
Jessica Tallon's avatar
Jessica Tallon committed
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
     [(enliven target-sref-vow)
      (on target-sref-vow
          (lambda (target-sref)
            (<- enliven-facet target-sref))
          #:promise? #t)]

     [(get-contacts)
      (define persona-incanter (<- persona-manager 'get-incanter))
      (define petnames-db (<- persona-incanter persona 'get-petname-database))
      (define edgenames-db (<- persona-incanter persona 'get-edgename-database))
      (let-on ([petnames-keys (<- petnames-db 'keys)]
               [edgenames-keys (<- edgenames-db 'keys)])
              (for/hasheq ([persona-sref (list->set (append petnames-keys edgenames-keys))])
                (values
                 persona-sref
                 (let-on ([petname (<- petnames-db 'find persona-sref)]
                          [my-edgename (<- edgenames-db 'find persona-sref)]
                          [edgenames (<- persona-incanter persona 'find-shared-edgenames persona-sref)])
                         (methods
                          [(petname) petname]
                          [(my-edgename) my-edgename]
                          [(edgenames) edgenames])))))]
319

320
     [(find-contact target)
321
322
      (define persona-incanter (<- persona-manager 'get-incanter))
      (define petnames (<- persona-incanter persona 'get-petname-database))
323
      (define edgenames (<- persona-incanter persona 'get-edgename-database))
Jessica Tallon's avatar
Jessica Tallon committed
324
325
326
      (define target-sref-vow
        (if (ocapn-sturdyref? target)
            target
327
            (get-and-verify-persona-sturdyref-vow target)))
Jessica Tallon's avatar
Jessica Tallon committed
328
      (on target-sref-vow
329
          (lambda (target-sturdyref)
330
            (define target-sturdyref-str (ocapn-sturdyref->string target-sturdyref))
331
332
333
334
335
336
337
338
            (let-on ([petname (<- petnames 'find target-sturdyref-str)]
                     [my-edgename (<- edgenames 'find target-sturdyref-str)]
                     [edgenames (<- persona-incanter persona 'find-shared-edgenames
                                    target-sturdyref-str)])
              (methods
               [(petname) petname]
               [(my-edgename) my-edgename]
               [(edgenames) edgenames])))
339
340
          #:promise? #t)]

341
     [(save-contact target petname edgename)
342
343
      (define persona-incanter (<- persona-manager 'get-incanter))
      (define petnames (<- persona-incanter persona 'get-petname-database))
344
      (define edgenames (<- persona-incanter persona 'get-edgename-database))
345

Jessica Tallon's avatar
Jessica Tallon committed
346
347
348
349
350
351
      (define sturdyref-vow
        (if (ocapn-sturdyref? target)
            target
            (get-and-verify-persona-sturdyref-vow target)))

      (on sturdyref-vow
352
353
          (lambda (target-sturdyref)
            (define target-sturdyref-str (ocapn-sturdyref->string target-sturdyref))
354
            (define petname-added-vow
355
356
357
              (if petname
                  (<- petnames 'add target-sturdyref-str petname)
                  (<- petnames 'delete target-sturdyref-str)))
358
            (define edgename-added-vow
359
360
361
              (if edgename
                  (<- edgenames 'add target-sturdyref-str edgename)
                  (<- edgenames 'delete target-sturdyref-str)))
362
            (on (all-of petname-added-vow edgename-added-vow)
363
364
365
366
                (lambda _
                  (<-np persona-manager 'commit))
                #:promise? #t))
          #:promise? #t)]
367
368
369
370

     [(remove-petname target)
      (define persona-incanter (<- persona-manager 'get-incanter))
      (define petnames (<- persona-incanter persona 'get-petname-database))
371
372
373
374
375
      (define sturdyref-vow
        (if (ocapn-sturdyref? target)
            target
            (get-and-verify-persona-sturdyref-vow target)))
      (on sturdyref-vow
376
377
378
379
380
381
382
383
          (lambda (target-sturdyref)
            (define target-sturdyref-str (ocapn-sturdyref->string target-sturdyref))
            (on (<- petnames 'delete target-sturdyref-str)
                (lambda _
                  (<-np persona-manager 'commit))
                #:promise? #t))
          #:promise? #t)]

384
     [(share-edgenames target)
385
      (define persona-incanter (<- persona-manager 'get-incanter))
386
      (<-np persona-incanter persona 'share-edgenames target)]
387

388
389
     ;; This creates weird race conditions I think... we need an unum
     ;; kind of thing in order for it to work ok.
390
     [(connect-client subscriber)
391
      ($ client-subscribers 'add subscriber)
392
      `#(OK ,($ rooms->inboxes/channels 'data))]
393
     [(join-room room)
394
      (when ($ rooms->inboxes/channels 'has-key? room)
395
396
        (error "Already subscribed to room"))

397
398
399
400
      (define persona-incanter-vow (<- persona-manager 'get-incanter))
      (define sealed-user-vow
        (make-sealed-user persona persona-incanter-vow user))
      
401
402
403
404
405
      ;; Make a new inbox specifically for this purpose, and associate
      ;; it with this room
      (define inbox
        (spawn ^user-inbox room))
      (define sealed-finalizer-vow
406
407
408
409
410
        (on sealed-user-vow
            (lambda (sealed-user)
              ;; TODO: Debug
              (<- room 'subscribe sealed-user persona))
            #:promise? #t))
411
412
413
414
415
      ;; First we request to subscribe, unseal it
      (define subscription-finalizer-vow
        (on sealed-finalizer-vow
            (lambda (sealed-finalizer)
              ($ subscription-unsealer sealed-finalizer))
416
            #:promise? #t))
417
418
419
420
421
422
423
424
425
426
427
      ;; User -> Channel: Hi!  I'm <USER> and I'd like to subscribe!
      ;; Channel returns: Oh really?!  Well then here's a sealed
      ;;   finalizer CAN YOU OPEN IT ARE YOU REALLY THIS USER
      ;; User: I opened it... so, next step, here's my inbox (for this channel)!
      ;; Channel: Okay, I gotta do a few things:
      ;;  - I'm going to remember that you're in the room
      ;;  - I'm going to tell everyone else that you joined
      ;;  - I'm going to tell you everyone else who joined
      ;;  - Finally, here's an object by which you can talk inside of
      ;;    this channel

428
429
430
      ;; If all goes well, we can finalize (letting the other side set up)
      ;; and get the relevant inbox.
      (on (<- subscription-finalizer-vow inbox)
431
432
433
434
435
436
437
          (lambda (room-channel)
            (define authenticated-channel
              (spawn ^authenticated-channel room-channel inbox))
            ($ rooms->inboxes/channels 'set room authenticated-channel)
            ;; TODO: this should actually be the subscription
            (send-to-clients 'we-joined-room room authenticated-channel)
            authenticated-channel)
438
          #:promise? #t)]))
439
440
441
442
443
  (define user-controller
    (spawn ^user-controller))
  (cons user user-controller))

(module+ test
Jessica Tallon's avatar
Jessica Tallon committed
444
  (require aurie ;; TODO: remove me
445
           brux/persona)
Jessica Tallon's avatar
Jessica Tallon committed
446
  
447
448
449
450
451
452
453
454
455
  (define a-vat
    (make-vat))
  (define b-vat
    (make-vat))
  (define c-vat
    (make-vat))
  (define m-vat
    (make-vat))

456
457
458
459
460
461
462
463
464
465
466
467
468
  (define (^dummy-mycapn-facet _bcom)
    ;; We never resolve the promises to the sturdyrefs
    (define-values (promise promise-resolve)
      (spawn-promise-values))
    (methods
     [(register obj) promise]
     [(restore obj sturdyref) promise]))

  (define (^dummy-enliven-facet _bcom)
    (methods
     ;; TODO: probably return something more like a refr.
     [(enliven sturdyref) #f]))

Jessica Tallon's avatar
Jessica Tallon committed
469
470
471
472
473
474
475
476
  (define (make-persona spn)
    ;; bootstrap a temp persona.
    (define depict-mgr (make-depict-manager))
    (define-values (persona-warden persona-incanter)
      (spawn-warding-pair))
    (define-values (depict-warden depict-incanter)
      (spawn-warding-pair))
    (define-values (^persona persona-depict)
477
      (persona depict-mgr (spawn ^dummy-mycapn-facet) (spawn ^dummy-enliven-facet) depict-warden persona-warden))
Jessica Tallon's avatar
Jessica Tallon committed
478
479
480
    (values
     (spawn ^persona spn spn)
     persona-incanter))
481

Jessica Tallon's avatar
Jessica Tallon committed
482
  (define (^mock-manager _bcom incanter)
483
484
    (define petnames ^hasheq)
    (methods
Jessica Tallon's avatar
Jessica Tallon committed
485
486
487
     [(commit) #f]
     [(get-petname-database) petnames]
     [(get-incanter) incanter]))
Jessica Tallon's avatar
Jessica Tallon committed
488
  
489
490
491
  (match-define (cons alice alice-controller)
    (a-vat 'run
           (lambda ()
Jessica Tallon's avatar
Jessica Tallon committed
492
493
             (define-values (alice alice-incanter) (make-persona "Alice"))
             (define manager (spawn ^mock-manager alice-incanter))
494
             (spawn-user-controller-pair alice manager (spawn ^dummy-enliven-facet)))))
495
496
497
  (match-define (cons bob bob-controller)
    (b-vat 'run
           (lambda ()
Jessica Tallon's avatar
Jessica Tallon committed
498
499
             (define-values (bob bob-incanter) (make-persona "Bob"))
             (define manager (spawn ^mock-manager bob-incanter))
500
             (spawn-user-controller-pair bob manager (spawn ^dummy-enliven-facet)))))
501
502
503
  (match-define (cons mallet mallet-controller)
    (m-vat 'run
           (lambda ()
Jessica Tallon's avatar
Jessica Tallon committed
504
505
             (define-values (mallet mallet-incanter) (make-persona "Mallet"))
             (define manager (spawn ^mock-manager mallet-incanter))
506
             (spawn-user-controller-pair mallet manager (spawn ^dummy-enliven-facet)))))
507
  (define chatroom
508
    (c-vat 'spawn ^chatroom "#butterflies"))
509

510
511
512
513
514
  (define alice-channel-vow
    (a-vat 'call alice-controller 'join-room chatroom))
  (define bob-channel-vow
    (b-vat 'call bob-controller 'join-room chatroom))

515
  (require pk)
516
517
518
519
520
521
522
523
524
525
  (define (^print-whatever _bcom user)
    (methods
     [(we-joined-room room channel)
      (define ((^hear-room bcom) . args)
        (pk 'user user 'from-room room 'args args))
      (<-np channel 'subscribe
            (spawn ^hear-room))]
     #:extends
     (lambda args
       (pk 'print-whatever 'user-watching: user 'args: args))))
526
527
528
529
530
  (define alice-print-whatever
    (a-vat 'spawn ^print-whatever 'alice))
  (define bob-print-whatever
    (b-vat 'spawn ^print-whatever 'bob))

531
532
  (a-vat 'call alice-controller 'connect-client alice-print-whatever)
  (b-vat 'call bob-controller 'connect-client bob-print-whatever)
533

534
  (a-vat '<-np alice-channel-vow 'send-message
535
         "hello everyone, how are you?")
536
  (b-vat '<-np bob-channel-vow 'send-message
537
         "I'm fine, thanks for asking alice"))