165 lines
7.7 KiB
Racket
165 lines
7.7 KiB
Racket
#lang syndicate
|
|
|
|
(require racket/port)
|
|
(require markdown)
|
|
|
|
(require/activate syndicate/reload)
|
|
(require/activate syndicate/supervise)
|
|
(require/activate "trust.rkt")
|
|
|
|
(require "protocol.rkt")
|
|
(require "duplicate.rkt")
|
|
(require "util.rkt")
|
|
|
|
(define (user-in-conversation? who cid)
|
|
(immediate-query [query-value #f (in-conversation cid who) #t]))
|
|
|
|
(supervise
|
|
(spawn #:name 'take-conversation-instructions
|
|
(stop-when-reloaded)
|
|
|
|
(on (message (api (session $creator _) (create-resource (? conversation? $c))))
|
|
(when (equal? creator (conversation-creator c))
|
|
(send! (create-resource c))))
|
|
(on (message (api (session $updater _) (update-resource (? conversation? $c))))
|
|
(when (user-in-conversation? updater (conversation-id c))
|
|
(send! (update-resource c))))
|
|
(on (message (api (session $creator _) (delete-resource (? conversation? $c))))
|
|
(when (equal? creator (conversation-creator c))
|
|
(send! (delete-resource c))))
|
|
|
|
(on (message (api (session $joiner _) (create-resource (? in-conversation? $i))))
|
|
(when (equal? joiner (in-conversation-member i))
|
|
(send! (create-resource i))))
|
|
(on (message (api (session $leaver _) (delete-resource (? in-conversation? $i))))
|
|
(when (equal? leaver (in-conversation-member i))
|
|
(send! (delete-resource i))))
|
|
|
|
(on (message (api (session $inviter _) (create-resource (? invitation? $i))))
|
|
(when (equal? inviter (invitation-inviter i))
|
|
(send! (create-resource i))))
|
|
(on (message (api (session $who _) (delete-resource (? invitation? $i))))
|
|
(when (or (equal? who (invitation-inviter i))
|
|
(equal? who (invitation-invitee i)))
|
|
(send! (delete-resource i))))
|
|
|
|
(on (message (api (session $who _) (create-resource (? post? $p))))
|
|
(when (and (user-in-conversation? who (post-conversation-id p))
|
|
(equal? who (post-author p)))
|
|
(send! (create-resource p))))
|
|
(on (message (api (session $who _) (update-resource (? post? $p))))
|
|
(when (equal? who (post-author p))
|
|
(send! (update-resource p))))
|
|
(on (message (api (session $who _) (delete-resource (? post? $p))))
|
|
(when (equal? who (post-author p))
|
|
(send! (delete-resource p))))))
|
|
|
|
(supervise
|
|
(spawn #:name 'relay-conversation-state
|
|
(stop-when-reloaded)
|
|
|
|
(during (invitation $cid $inviter $invitee)
|
|
(assert (api (session invitee _) (invitation cid inviter invitee)))
|
|
(during ($ c (conversation cid _ _ _))
|
|
(assert (api (session invitee _) c))))
|
|
|
|
(during (in-conversation $cid $who)
|
|
(during ($ i (invitation cid _ _))
|
|
(assert (api (session who _) i)))
|
|
(during ($ i (in-conversation cid _))
|
|
(assert (api (session who _) i)))
|
|
(during ($ c (conversation cid _ _ _))
|
|
(assert (api (session who _) c)))
|
|
(during ($ p (post _ _ cid _ _))
|
|
(assert (api (session who _) p))))))
|
|
|
|
(supervise
|
|
(spawn #:name 'conversation-factory
|
|
(stop-when-reloaded)
|
|
(on (message (create-resource ($ c0 (conversation $cid $title0 $creator $blurb0))))
|
|
(spawn #:name c0
|
|
(field [title title0]
|
|
[blurb blurb0])
|
|
(define/dataflow c (conversation cid (title) creator (blurb)))
|
|
(on-start (log-info "~v created" (c)))
|
|
(on-stop (log-info "~v deleted" (c)))
|
|
(assert (c))
|
|
(stop-when-duplicate (list 'conversation cid))
|
|
(stop-when (message (delete-resource (conversation cid _ _ _))))
|
|
(on (message (update-resource (conversation cid $newtitle _ $newblurb)))
|
|
(title newtitle)
|
|
(blurb newblurb))))))
|
|
|
|
(supervise
|
|
(spawn #:name 'in-conversation-factory
|
|
(stop-when-reloaded)
|
|
(on (message (create-resource ($ i (in-conversation $cid $who))))
|
|
(spawn #:name i
|
|
(on-start (log-info "~s joins conversation ~a" who cid))
|
|
(on-stop (log-info "~s leaves conversation ~a" who cid))
|
|
(assert i)
|
|
(stop-when-duplicate i)
|
|
(stop-when (message (delete-resource i)))
|
|
(stop-when (message (delete-resource (conversation cid _ _ _))))))))
|
|
|
|
(supervise
|
|
(spawn #:name 'invitation-factory
|
|
(stop-when-reloaded)
|
|
(on (message (create-resource ($ i (invitation $cid $inviter $invitee))))
|
|
(spawn #:name i
|
|
(on-start (log-info "~s invited to conversation ~a by ~s" invitee cid inviter))
|
|
(on-stop (log-info "invitation of ~s to conversation ~a by ~s retracted"
|
|
invitee cid inviter))
|
|
(assert i)
|
|
(stop-when-duplicate i)
|
|
(stop-when (message (delete-resource i)))
|
|
(stop-when (message (delete-resource (conversation cid _ _ _))))
|
|
(stop-when (asserted (in-conversation cid invitee)))))))
|
|
|
|
(supervise
|
|
(spawn #:name 'post-factory
|
|
(stop-when-reloaded)
|
|
(on (message (create-resource
|
|
($ p0 (post $pid $timestamp $cid $author $items0))))
|
|
(spawn #:name p0
|
|
(field [items items0])
|
|
(define/dataflow p (post pid timestamp cid author (items)))
|
|
(assert (p))
|
|
(stop-when-duplicate (list 'post cid pid))
|
|
(stop-when (message (delete-resource (post pid _ cid _ _))))
|
|
(stop-when (message (delete-resource (conversation cid _ _ _))))
|
|
(on (message (update-resource (post pid _ cid _ $newitems)))
|
|
(items newitems))))))
|
|
|
|
(supervise
|
|
(spawn #:name 'conversation:questions
|
|
(stop-when-reloaded)
|
|
;; TODO: CHECK THE FOLLOWING: When the `invitation` vanishes (due to satisfaction
|
|
;; or rejection), this should remove the question from all eligible answerers at once
|
|
(during (invitation $cid $inviter $invitee)
|
|
;; `inviter` has invited `invitee` to conversation `cid`...
|
|
(define qid (random-hex-string 32)) ;; Fix qid and timestamp even as title/creator vary
|
|
(define timestamp (current-seconds))
|
|
(during (conversation cid $title $creator _)
|
|
;; ...and it exists...
|
|
(during (permitted invitee inviter (p:follow invitee) _)
|
|
;; ...and they are permitted to do so
|
|
(assert (question qid timestamp "q-invitation" invitee
|
|
(format "Invitation from ~a" inviter)
|
|
(with-output-to-string
|
|
(lambda ()
|
|
(display-xexpr
|
|
`(div
|
|
(p "You have been invited by " (b ,inviter)
|
|
" to join a conversation started by " (b ,creator) ".")
|
|
(p "The conversation is titled "
|
|
(i "\"" ,title "\"") ".")))))
|
|
(option-question (list (list "join" "Join conversation")
|
|
(list "decline" "Decline invitation")))))
|
|
(stop-when (asserted (answer qid $v))
|
|
(match v
|
|
["join"
|
|
(send! (create-resource (in-conversation cid invitee)))]
|
|
["decline"
|
|
(send! (delete-resource (invitation cid inviter invitee)))])))))))
|