Break up Golem into separate modules

parent 847a3399
#lang racket
(provide (all-defined-out))
(require "params.rkt"
net/url
json
magenc/get-put
magenc/hungry-store)
;;; Database stuff
;;; ==============
;; The "collections database" is simply a mutable hashtable where keys
;; are symbols and values are lists of items.
;; Append VAL to COLLECTION in the global db
(define/contract (collections-append! collection val)
(-> symbol? any/c void?)
(hash-set! (collections) collection
(cons val (hash-ref (collections) collection '())))
(void))
;; Fetch all items from COLLECTION in the global COLLECTIONS
(define/contract (collections-ref collection)
(-> symbol? (or/c pair? null?)) ; technically list? but that's pricey :)
(hash-ref (collections) collection '()))
;;; Store stuff
;;; ===========
;; Handy utility for pulling json out of a magenc store
(define (store-get-json url [store (magenc-store)])
(define json-str
(call-with-output-string
(lambda (p)
(magenc-get p (if (string? url)
(string->url url)
url)
store))))
(call-with-input-string json-str
read-json))
;; This instantiates a new "hungry store" that has a belly of our
;; main magenc-store and which eats content from the other-stores
;; if it can't find it itself.
(define (hungry-store)
(new hungry-store%
[belly (magenc-store)]
[other-stores (other-stores)]))
#lang racket
(provide (all-defined-out))
(require json
net/url
"db.rkt")
;;; Message-sending/receiving workers
;;; =================================
;; Federate out message to all recipients.
;; We split out federating to each recipient into a separate thread
;; so each can happen asynchronously.
;; We need to retrieve each actor's inbox from their actor profile
;; before we can POST to them.
(define/contract (federate-message message recipients)
(-> bytes? (listof url?) any/c)
;; TODO: get recipients even in case they are objects rather than just uris
(for ([recipient recipients])
(thread
(lambda ()
(define actor-profile
(read-json (get-pure-port recipient
'("Accept: application/activity+json"))))
(define inbox-url
(string->url (hash-ref actor-profile 'inbox)))
(post-pure-port inbox-url message
'("Content-Type: application/activity+json")))))
(void))
;; Process an incoming message.
;; Spawns a separate thread, so this doesn't block the caller.
(define (process-federated-message message)
(thread
(lambda ()
(define message-json
(call-with-input-bytes message read-json))
(define activity-url
(string->url (hash-ref message-json '@id)))
(define activity
(store-get-json activity-url
(hungry-store)))
(define object
(store-get-json (string->url (hash-ref activity 'object))
(hungry-store)))
(collections-append! 'inbox activity-url)))
(void))
#lang racket
(require net/url
net/uri-codec
json
web-server/servlet
(require web-server/servlet
web-server/servlet-env
web-server/dispatch
magenc/install-factory
magenc/memory-store
magenc/hungry-store
magenc/web-store
magenc/get-put
sql db
"utils.rkt")
;;; Some parameters
;;; ===============
;; Username of this instance. To simplify the demo, Golem instances
;; are single-user only (and we don't even bother with authentication!)
(define users-name
(make-parameter #f)) ; set this to a string
;; The "collections database" of this instance.
;; This is a hashtable where keys are collection names and values are
;; lists of items.
(define collections
(make-parameter #f)) ; set this to a mutable hasheq
;; The "magenc" store is where we store encrypted chunks of data.
(define magenc-store
(make-parameter #f)) ; set this to a magenc store instance
;; A list of other magenc stores that might have chunks we want.
(define other-stores
(make-parameter '()))
;; The base URL of this instance.
(define base-url
(make-parameter #f))
;; (not really a parameter but it uses them)
;; This instantiates a new "hungry store" that has a belly of our
;; main magenc-store and which eats content from the other-stores
;; if it can't find it itself.
(define (hungry-store)
(new hungry-store%
[belly (magenc-store)]
[other-stores (other-stores)]))
;;; Routing
;;; =======
(define-values (golem-dispatch golem-url)
(dispatch-rules
[("") actor-profile]
[("inbox") #:method "get" get-inbox]
[("inbox") #:method "post" post-inbox]
[("outbox") #:method "get" get-outbox]
[("post-note") #:method "post" post-note]
[("read-only-cas") read-only-cas]
[("enc" (string-arg) (string-arg)) decrypt-encrypted-object]))
(define (golem-absolute-url handler)
(combine-url/relative (base-url)
(golem-url handler)))
(define (golem-absolute-url-str handler)
(url->string (golem-absolute-url handler)))
;;; Pages
;;; =====
;; This is the page for the actor's profile (which is mounted at the
;; root in this demo, but is the same as eg "https://octodon.social/@cwebber")
;; We serve content differently depending on whether the request
;; asks for ActivityStreams json-ld (in which case we return the json
;; representation of this actor, which most critically for this demo
;; has the inbox property attached).
;; Otherwise we return an html render.
(define (actor-profile req)
;; A very naive (and incorrect) version of header parsing.
;; A demo kludge for sure ;P
(define accept-headers
(string-split (match (assoc 'accept (request-headers req))
[(cons 'accept str) str]
[#f ""])
","))
(cond
;; If we get request for json-ld, return that
;; TODO: Accept other json-ld content types here, and parse it right
[(member "application/activity+json" accept-headers)
(define profile
`#hasheq((name . ,(users-name))
(inbox . ,(golem-absolute-url-str get-inbox))
(outbox . ,(golem-absolute-url-str get-outbox))))
(ok (json->bytes profile)
#:content-type #"application/activity+json")]
;; Return the html page
[else
(define (header-entry key content)
`(div (@ (class "feedish-header-entry"))
(b (@ (class "header-key"))
,(string-append key ": "))
(span (@ (class "header-content"))
,content)))
;; Render a collection, but only one item from that collection
;; TODO: move this to the templates section?
(define (preview-collection col-sym col-name col-handler)
`(div
(h2 "Most recent post in your "
(a (@ (href ,(golem-url col-handler)))
,col-name))
,(match (collections-ref col-sym)
['()
'(p (i "Hey look... nothing!"))]
[(list post-uri posts-uris ...)
(define activity
(store-get-json post-uri))
(define object
(store-get-json (hash-ref activity 'object)))
`(div (@ (class "feedish-top-post feedish-post"))
(div (@ (class "feedish-header"))
,(header-entry "From" (hash-ref activity 'actor)))
(p ,(hash-ref object 'content)))])))
(render-ok
(generic-base-tmpl
`(div ,(post-note-form)
(div ,(preview-collection 'outbox "outbox" get-outbox)
,(preview-collection 'inbox "inbox" get-inbox)))))]))
;; Render the actor's inbox in response to a GET against /inbox
;; Should return a nice html gallery of the content unless requested
;; as json-ld, in which case we'll return an OrderedCollection
;; ActivityStreams object.
;; TODO: Actually implement this :)
(define (get-inbox req)
(render-ok
(generic-base-tmpl
'(p "Inbox goes here!"))))
;; Process an incoming message in response to a POST to our /inbox
;; Here's how we actually receive federated content!
(define (post-inbox req)
;; Hand off the content to a worker.
(process-federated-message (request-post-data/raw req))
;; We respond asynchronously with an OK response.
;; TODO: This is wrong! According to the spec:
;; > If an Activity is submitted with a value in the id property,
;; > servers MUST ignore this and generate a new id for the
;; > Activity. Servers MUST return a 201 Created HTTP code, and unless
;; > the activity is transient, MUST include the new id in the
;; > Location header.
(render-ok
'(html (title "got it")
(body (p "Got it... processing!")))))
;; Render the actor's outbox in response to a GET against /outbox
;; See get-inbox's documentation, but for our outbox :)
(define (get-outbox req)
(render-ok
(generic-base-tmpl
'(p "Outbox goes here!"))))
;; Submit a message via the web UI's form.
;; More or less this is the "client composition" part of this demo.
;; We aren't implementing the ActivityPub C2S (client-to-server) API
;; because it doesn't really matter for this demo.
(define (post-note req)
;;; Process form data
(define form-data
(form-urlencoded->alist
(bytes->string/utf-8 (request-post-data/raw req))))
;; Extract the `to' and `content' fields from the form data
;; and error out if they aren't there.
;; TODO: Properly signal user about problem
(match-define (cons _ to)
(assoc 'to form-data))
(match-define (cons _ content)
(assoc 'content form-data))
;; Split up the To address and convert them to url structs.
;; In this demo we keep things simple and split recipients on whitespace
;; from the form data.
(define to-addrs-strs
(string-split to))
(define to-addrs-urls
(map string->url to-addrs-strs))
;; Now generate Note and Create structures.
;; Every federated message in the fediverse has an object wrapped
;; in an activity (verb'ing a noun).
;; In this demo we're keeping things lean and just assume every
;; message sent across the network is like {Create {Note}}.
;; (Technically every activity sent is supposed to have an actor too;
;; in the future I might explain why in an ocap AP system that isn't
;; strictly necessary...)
(define actor-url-str
(golem-absolute-url-str actor-profile))
(define note
`#hasheq((type . "Note")
(content . ,content)
(attributed-to . ,actor-url-str)))
(define note-str
(json->string note))
(define note-url
(call-with-input-string note-str
(lambda (p)
(magenc-put! p (magenc-store)))))
(define create
`#hasheq((type . "Create")
(object . ,(url->string note-url))
(actor . ,actor-url-str)
;; not strictly necessary, but good to be kept in the loop
;; in case someone replies to us :)
(to . ,to-addrs-strs)))
(define create-str
(json->string create))
(define create-url
(call-with-input-string create-str
(lambda (p)
(magenc-put! p (magenc-store)))))
;; Now we federate it out.
;; The federate-message function generates separate workers/threads
;; for every recipient so this won't block.
(federate-message (call-with-output-bytes
(lambda (p)
(write-json
`#hasheq((@id . ,(url->string create-url)))
p)))
to-addrs-urls)
;; We set things up enough to pass it off for federation, so at this
;; point we should add it to our outbox.
(collections-append! 'outbox create-url)
;; Now render a template saying we saved it.
;; TODO: We should redirect.
(render-ok (generic-base-tmpl
(centered-content-tmpl
`(div (h1 "Saved it!")
(p "Now "
(a (@ (href ,(golem-url actor-profile)))
"go home") "!"))))))
;; Respond to GETs against /read-only-cas
;; CAS stands for "Content Addressed Storage".
;; If a user makes a request like:
;; GET /read-only-cas?xt=urn:sha256:<hash>
;; we'll see if we have that object and will return it if we do.
(define (read-only-cas req)
(match (assoc 'xt (url-query (request-uri req)))
[#f (not-found)]
[(cons 'xt uri-to-get)
(match (send (magenc-store) get (string->url uri-to-get))
[#f (not-found)]
[(? bytes? out-bytes)
(ok out-bytes)])]))
(define (decrypt-encrypted-object req enc-hash-str-key)
'TODO)
;;; Templates
;;; =========
;; All templates here use SXML, an s-expressions based xml representation.
;; Quasiquote, the ultimate templating language!
(define (base-tmpl body #:title [title #f])
(define (header-link link-name link-url)
(list
"[" `(a (@ (href ,link-url))
,link-name)
"]"))
`(html (@ (xmlns "http://www.w3.org/1999/xhtml"))
(head
(meta (@ (charset "utf-8")))
(title ,(if title
(string-append title " -- Golem")
"Golem"))
;; css
(link (@ (rel "stylesheet")
(href "/css/main.css"))))
(body
(div (@ (id "main-wrapper"))
(header (@ (id "site-header"))
;; @@: Not semantic naming!
(span (@ (id "site-header-left-stuff"))
(b (a (@ (href ,(golem-url actor-profile)))
"*golem*"))
" :: "
,(users-name) "'s site")
(span (@ (id "site-header-right-stuff"))
,(header-link "inbox"
(golem-url get-inbox))
" "
,(header-link "outbox"
(golem-url get-outbox))))
(div (@ (id "site-main-content"))
,body))
(div (@ (id "site-footer"))
(a (@ (href "https://gitlab.com/spritely/golem"))
"Golem")
" is released under Apache v2 or later"))))
(define (generic-base-tmpl . content)
(base-tmpl (apply generic-content-tmpl content)))
(define (generic-content-tmpl . content)
`(div (@ (class "generic-content-box"))
,@content))
(define (centered-content-tmpl . content)
`(div (@ (class "simple-centered-wrap"))
,(apply generic-content-tmpl content)))
(define (post-note-form)
`(div (@ (class "simple-centered-wrap"))
(div (@ (class "post-new-note")
(style "max-width: 500px; min-width: 50%;"))
(h2 "What's up?")
(form (@ (action ,(golem-url post-note))
(method "POST")
(enctype "application/x-www-form-urlencoded"))
(div (@ (style "display: flex; width: 100%"))
(b "To: ")
(input (@ (type "text")
(name "to")
(style "flex: 2"))))
(textarea (@ (name "content")
(style "width: 100%; resize: none; height: 8em;")))
(div (@ (style "text-align: right"))
(button (@ (type "submit"))
"Submit"))))))
;;; Message-sending/receiving workers
;;; =================================
;; Federate out message to all recipients.
;; We split out federating to each recipient into a separate thread
;; so each can happen asynchronously.
;; We need to retrieve each actor's inbox from their actor profile
;; before we can POST to them.
(define/contract (federate-message message recipients)
(-> bytes? (listof url?) any/c)
;; TODO: get recipients even in case they are objects rather than just uris
(for ([recipient recipients])
(thread
(lambda ()
(define actor-profile
(read-json (get-pure-port recipient
'("Accept: application/activity+json"))))
(define inbox-url
(string->url (hash-ref actor-profile 'inbox)))
(post-pure-port inbox-url message
'("Content-Type: application/activity+json")))))
(void))
;; Process an incoming message.
;; Spawns a separate thread, so this doesn't block the caller.
(define (process-federated-message message)
(thread
(lambda ()
(define message-json
(call-with-input-bytes message read-json))
(define activity-url
(string->url (hash-ref message-json '@id)))
(define activity
(store-get-json activity-url
(hungry-store)))
(define object
(store-get-json (string->url (hash-ref activity 'object))
(hungry-store)))
(collections-append! 'inbox activity-url)))
(void))
;;; Database stuff
;;; ==============
;; The "collections database" is simply a mutable hashtable where keys
;; are symbols and values are lists of items.
;; Append VAL to COLLECTION in the global db
(define/contract (collections-append! collection val)
(-> symbol? any/c void?)
(hash-set! (collections) collection
(cons val (hash-ref (collections) collection '())))
(void))
;; Fetch all items from COLLECTION in the global COLLECTIONS
(define/contract (collections-ref collection)
(-> symbol? (or/c pair? null?)) ; technically list? but that's pricey :)
(hash-ref (collections) collection '()))
;;; Store stuff
;;; ===========
;; Handy utility for pulling json out of a magenc store
(define (store-get-json url [store (magenc-store)])
(define json-str
(call-with-output-string
(lambda (p)
(magenc-get p (if (string? url)
(string->url url)
url)
store))))
(call-with-input-string json-str
read-json))
"utils.rkt"
"params.rkt"
"routes.rkt")
;;; Application launching
;;; =====================
......
#lang racket
(provide (all-defined-out))
(require racket/lazy-require
net/url
net/uri-codec
json
web-server/http/bindings
web-server/http/request-structs
magenc/get-put
"params.rkt"
"utils.rkt"
"db.rkt"
"federation.rkt")
(lazy-require ["routes.rkt"
(golem-dispatch
golem-url golem-aboslute-url
golem-absolute-url-str)]
;; TODO: a prefixed lazy template importer would be nice
["templates.rkt"
([base tmpl:generic-base]
[centered-content tmpl:centered-content]
post-note-form)])
;;; Pages
;;; =====
;; This is the page for the actor's profile (which is mounted at the
;; root in this demo, but is the same as eg "https://octodon.social/@cwebber")
;; We serve content differently depending on whether the request
;; asks for ActivityStreams json-ld (in which case we return the json
;; representation of this actor, which most critically for this demo
;; has the inbox property attached).
;; Otherwise we return an html render.
(define (actor-profile req)
;; A very naive (and incorrect) version of header parsing.
;; A demo kludge for sure ;P
(define accept-headers
(string-split (match (assoc 'accept (request-headers req))
[(cons 'accept str) str]
[#f ""])
","))
(cond
;; If we get request for json-ld, return that
;; TODO: Accept other json-ld content types here, and parse it right
[(member "application/activity+json" accept-headers)
(define profile
`#hasheq((name . ,(users-name))
(inbox . ,(golem-absolute-url-str get-inbox))
(outbox . ,(golem-absolute-url-str get-outbox))))
(ok (json->bytes profile)
#:content-type #"application/activity+json")]
;; Return the html page
[else
(define (header-entry key content)
`(div (@ (class "feedish-header-entry"))
(b (@ (class "header-key"))
,(string-append key ": "))
(span (@ (class "header-content"))
,content)))
;; Render a collection, but only one item from that collection
;; TODO: move this to the templates section?
(define (preview-collection col-sym col-name col-handler)
`(div
(h2 "Most recent post in your "
(a (@ (href ,(golem-url col-handler)))
,col-name))
,(match (collections-ref col-sym)
['()
'(p (i "Hey look... nothing!"))]
[(list post-uri posts-uris ...)
(define activity
(store-get-json post-uri))
(define object
(store-get-json (hash-ref activity 'object)))
`(div (@ (class "feedish-top-post feedish-post"))
(div (@ (class "feedish-header"))
,(header-entry "From" (hash-ref activity 'actor)))
(p ,(hash-ref object 'content)))])))
(render-ok
(tmpl:generic-base
`(div ,(post-note-form)
(div ,(preview-collection 'outbox "outbox" get-outbox)
,(preview-collection 'inbox "inbox" get-inbox)))))]))
;; Render the actor's inbox in response to a GET against /inbox
;; Should return a nice html gallery of the content unless requested
;; as json-ld, in which case we'll return an OrderedCollection
;; ActivityStreams object.
;; TODO: Actually implement this :)
(define (get-inbox req)
(render-ok
(tmpl:generic-base
'(p "Inbox goes here!"))))
;; Process an incoming message in response to a POST to our /inbox
;; Here's how we actually receive federated content!
(define (post-inbox req)
;; Hand off the content to a worker.
(process-federated-message (request-post-data/raw req))
;; We respond asynchronously with an OK response.
;; TODO: This is wrong! According to the spec: