2016-11-30 05:08:35 +00:00
|
|
|
#lang syndicate/actor
|
|
|
|
|
|
|
|
(require/activate syndicate/reload)
|
|
|
|
(require/activate syndicate/supervise)
|
|
|
|
(require/activate syndicate/broker/server)
|
|
|
|
(require/activate syndicate/drivers/web)
|
|
|
|
(require/activate "trust.rkt")
|
|
|
|
|
|
|
|
(require "protocol.rkt")
|
|
|
|
(require "session-cookie.rkt")
|
|
|
|
|
2017-02-20 17:54:52 +00:00
|
|
|
(spawn #:name 'broker-listener
|
2016-11-30 05:08:35 +00:00
|
|
|
(stop-when-reloaded)
|
|
|
|
(on (web-request-get (id req) _ ("broker" ()))
|
|
|
|
(when (web-request-header-websocket-upgrade? req)
|
|
|
|
(with-session id
|
|
|
|
[(email sid)
|
|
|
|
(define (scope v) (api (session email sid) v))
|
|
|
|
(spawn-broker-server-connection
|
|
|
|
id
|
|
|
|
req
|
|
|
|
#:scope scope
|
|
|
|
#:hook (lambda ()
|
|
|
|
(stop-when (message (end-session sid)))
|
2017-01-05 01:57:26 +00:00
|
|
|
(stop-when (message (delete-resource (account email))))))]
|
2016-12-06 02:04:41 +00:00
|
|
|
[else
|
|
|
|
(web-respond/xexpr! id
|
|
|
|
#:header (web-response-header #:code 401
|
|
|
|
#:message #"Unauthorized")
|
|
|
|
`(html (body (h1 "Unauthorized")
|
|
|
|
(a ((href "/")) "Login"))))]))))
|
2016-11-30 05:08:35 +00:00
|
|
|
|
|
|
|
(supervise
|
2017-02-20 17:54:52 +00:00
|
|
|
(spawn #:name 'reflect-trust
|
2016-11-30 05:08:35 +00:00
|
|
|
(stop-when-reloaded)
|
|
|
|
(during (session $who _)
|
|
|
|
(during ($ p (permitted _ who _ _))
|
|
|
|
(assert (api (session who _) p)))
|
|
|
|
(during ($ r (permission-request _ who _))
|
|
|
|
(assert (api (session who _) r)))
|
|
|
|
(during ($ g (grant _ who _ _ _))
|
2016-12-06 02:04:41 +00:00
|
|
|
(assert (api (session who _) g)))
|
|
|
|
(during ($ c (contact-list-entry who _))
|
|
|
|
(assert (api (session who _) c))))))
|
2016-11-30 05:08:35 +00:00
|
|
|
|
|
|
|
(supervise
|
2017-02-20 17:54:52 +00:00
|
|
|
(spawn #:name 'reflect-grant-requests
|
2016-11-30 05:08:35 +00:00
|
|
|
(stop-when-reloaded)
|
|
|
|
(during (permission-request $issuer $grantee $permission)
|
|
|
|
(define r (permission-request issuer grantee permission))
|
|
|
|
(during (permitted issuer $grantor permission #t)
|
|
|
|
(assert (api (session grantor _) r))
|
|
|
|
(on (message (api (session grantor _) (delete-resource r)))
|
|
|
|
(send! (delete-resource r)))))))
|
|
|
|
|
|
|
|
(supervise
|
2017-02-20 17:54:52 +00:00
|
|
|
(spawn #:name 'take-trust-instructions
|
2016-11-30 05:08:35 +00:00
|
|
|
(stop-when-reloaded)
|
|
|
|
|
|
|
|
(on (message (api (session $grantor _) (create-resource (? grant? $g))))
|
|
|
|
(when (equal? grantor (grant-grantor g))
|
|
|
|
(send! (create-resource g))))
|
|
|
|
(on (message (api (session $grantor _) (delete-resource (? grant? $g))))
|
2016-12-06 04:58:52 +00:00
|
|
|
(when (or (equal? grantor (grant-grantor g))
|
|
|
|
(equal? grantor (grant-issuer g)))
|
2016-11-30 05:08:35 +00:00
|
|
|
(send! (delete-resource g))))
|
|
|
|
|
2016-12-06 04:58:52 +00:00
|
|
|
(on (message (api (session $principal _) (delete-resource (? permitted? $p))))
|
|
|
|
(when (or (equal? principal (permitted-email p)) ;; relinquish
|
|
|
|
(equal? principal (permitted-issuer p))) ;; revoke; TODO: deal with delegation
|
2016-11-30 05:08:35 +00:00
|
|
|
(send! (delete-resource p))))
|
|
|
|
|
|
|
|
(on (message (api (session $grantee _) (create-resource (? permission-request? $r))))
|
|
|
|
(when (equal? grantee (permission-request-grantee r))
|
|
|
|
(send! (create-resource r))))
|
|
|
|
(on (message (api (session $grantee _) (delete-resource (? permission-request? $r))))
|
|
|
|
(when (equal? grantee (permission-request-grantee r))
|
|
|
|
(send! (delete-resource r))))))
|