golem.rkt 17.1 KB
Newer Older
1 2
#lang racket

3
(require net/url
4
         net/uri-codec
5
         json
6 7 8
         web-server/servlet
         web-server/servlet-env
         web-server/dispatch
9 10
         magenc/install-factory
         magenc/memory-store
Christopher Lemmer Webber's avatar
Christopher Lemmer Webber committed
11 12
         magenc/hungry-store
         magenc/web-store
13
         magenc/get-put
14
         "utils.rkt")
15

16 17 18
;;; Some parameters
;;; ===============

19 20
;; Username of this instance.  To simplify the demo, Golem instances
;; are single-user only (and we don't even bother with authentication!)
21
(define users-name
22 23
  (make-parameter #f))  ; set this to a string

24
;; The "collections database" of this instance.
25 26
;; This is a hashtable where keys are collection names and values are
;; lists of items.
27
(define collections
28 29 30
  (make-parameter #f))  ; set this to a mutable hasheq

;; The "magenc" store is where we store encrypted chunks of data.
31
(define magenc-store
32 33 34
  (make-parameter #f))  ; set this to a magenc store instance

;; A list of other magenc stores that might have chunks we want.
Christopher Lemmer Webber's avatar
Christopher Lemmer Webber committed
35 36
(define other-stores
  (make-parameter '()))
37 38

;; The base URL of this instance.
39 40
(define base-url
  (make-parameter #f))
41

42 43 44 45
;; (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.
Christopher Lemmer Webber's avatar
Christopher Lemmer Webber committed
46 47 48 49 50
(define (hungry-store)
  (new hungry-store%
       [belly (magenc-store)]
       [other-stores (other-stores)]))

51 52
;;; Routing
;;; =======
53

54 55
(define-values (golem-dispatch golem-url)
  (dispatch-rules
56
   [("") actor-profile]
57
   [("inbox") #:method "get" get-inbox]
58
   [("inbox") #:method "post" post-inbox]
59 60
   [("outbox") #:method "get" get-outbox]
   [("post-note") #:method "post" post-note]
61
   [("read-only-cas") read-only-cas]
62
   [("enc" (string-arg) (string-arg)) decrypt-encrypted-object]))
63

64
(define (golem-absolute-url handler)
65 66
  (combine-url/relative (base-url)
                        (golem-url handler)))
67 68 69 70

(define (golem-absolute-url-str handler)
  (url->string (golem-absolute-url handler)))

71 72 73
;;; Pages
;;; =====

74 75 76
;; 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
77 78 79
;; 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).
80
;; Otherwise we return an html render.
81
(define (actor-profile req)
82 83
  ;; A very naive (and incorrect) version of header parsing.
  ;; A demo kludge for sure ;P
84
  (define accept-headers
85
    (string-split (match (assoc 'accept (request-headers req))
86 87 88
                    [(cons 'accept str) str]
                    [#f ""])
                  ","))
89 90
  (cond
    ;; If we get request for json-ld, return that
91
    ;; TODO: Accept other json-ld content types here, and parse it right
92
    [(member "application/activity+json" accept-headers)
93 94 95 96 97 98 99 100
     (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
101
     (define (header-entry key content)
102 103 104
       `(tr (@ (class "feedish-header-entry"))
            (th (@ (class "header-key")
                   (valign "top"))
105
                ,(string-append key ": "))
106 107 108
            (td (@ (class "header-content")
                   (valign "top"))
                ,content)))
109 110
     ;; Render a collection, but only one item from that collection
     ;; TODO: move this to the templates section?
111 112 113 114 115
     (define (preview-collection col-sym col-name col-handler)
       `(div
         (h2 "Most recent post in your "
             (a (@ (href ,(golem-url col-handler)))
                ,col-name))
116
         ,(match (collections-ref col-sym)
117 118 119 120 121 122 123
            ['()
             '(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)))
124
             `(div (@ (class "feedish-top-post feedish-post"))
125 126 127 128 129 130 131 132 133 134 135
                   (div
                    (@ (class "feedish-entry-headers"))
                    (table ,(header-entry "From"
                                          (let ([actor (hash-ref activity 'actor)])
                                            `(a (@ (href ,actor))
                                                ,actor)))
                           ,(header-entry "Id"
                                          `(pre (@ (class "magnet-preview"))
                                                ,(pretty-format-magnet post-uri)))))
                   (div (@ (class "feedish-entry-content"))
                        (p ,(hash-ref object 'content))))])))
136 137
     (render-ok
      (generic-base-tmpl
138
       `(div ,(post-note-form)
139 140
             (div ,(preview-collection 'outbox "outbox" get-outbox)
                  ,(preview-collection 'inbox "inbox" get-inbox)))))]))
141

142 143 144 145 146
;; 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 :)
147 148 149 150 151
(define (get-inbox req)
  (render-ok
   (generic-base-tmpl
    '(p "Inbox goes here!"))))

152 153
;; Process an incoming message in response to a POST to our /inbox
;; Here's how we actually receive federated content!
154
(define (post-inbox req)
155
  ;; Hand off the content to a worker.
Christopher Lemmer Webber's avatar
Christopher Lemmer Webber committed
156
  (process-federated-message (request-post-data/raw req))
157 158 159 160 161 162 163
  ;; 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.
164
  (render-ok
Christopher Lemmer Webber's avatar
Christopher Lemmer Webber committed
165 166
   '(html (title "got it")
          (body (p "Got it... processing!")))))
167

168 169
;; Render the actor's outbox in response to a GET against /outbox
;; See get-inbox's documentation, but for our outbox :)
170 171 172 173
(define (get-outbox req)
  (render-ok
   (generic-base-tmpl
    '(p "Outbox goes here!"))))
174

175 176 177 178
;; 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.
179
(define (post-note req)
180 181 182 183
  ;;; Process form data
  (define form-data
    (form-urlencoded->alist
     (bytes->string/utf-8 (request-post-data/raw req))))
184 185 186

  ;; Extract the `to' and `content' fields from the form data
  ;; and error out if they aren't there.
187 188 189 190 191
  ;; TODO: Properly signal user about problem
  (match-define (cons _ to)
    (assoc 'to form-data))
  (match-define (cons _ content)
    (assoc 'content form-data))
192 193 194 195

  ;; 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.
196 197 198 199 200
  (define to-addrs-strs
    (string-split to))
  (define to-addrs-urls
    (map string->url to-addrs-strs))

201 202 203 204 205 206 207 208
  ;; 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...)
209 210
  (define actor-url-str
    (golem-absolute-url-str actor-profile))
211 212 213
  (define note
    `#hasheq((type . "Note")
             (content . ,content)
214
             (attributed-to . ,actor-url-str)))
215 216 217 218 219 220 221 222 223
  (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))
224
             (actor . ,actor-url-str)
225 226
             ;; not strictly necessary, but good to be kept in the loop
             ;; in case someone replies to us :)
227 228 229 230 231 232 233 234
             (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)))))

235 236 237
  ;; Now we federate it out.
  ;; The federate-message function generates separate workers/threads
  ;; for every recipient so this won't block.
238 239 240
  (federate-message (call-with-output-bytes
                     (lambda (p)
                       (write-json
Christopher Lemmer Webber's avatar
Christopher Lemmer Webber committed
241 242
                        `#hasheq((@id . ,(url->string create-url)))
                        p)))
243
                    to-addrs-urls)
244 245 246

  ;; We set things up enough to pass it off for federation, so at this
  ;; point we should add it to our outbox.
247
  (collections-append! 'outbox create-url)
248 249
  ;; Now render a template saying we saved it.
  ;; TODO: We should redirect.
250 251 252 253 254 255
  (render-ok (generic-base-tmpl
              (centered-content-tmpl
               `(div (h1 "Saved it!")
                     (p "Now "
                        (a (@ (href ,(golem-url actor-profile)))
                           "go home") "!"))))))
256

257 258 259 260 261
;; 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.
262 263 264 265 266 267 268 269 270
(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)])]))

271 272 273
(define (decrypt-encrypted-object req enc-hash-str-key)
  'TODO)

274 275 276
;;; Templates
;;; =========

277 278 279
;; All templates here use SXML, an s-expressions based xml representation.
;; Quasiquote, the ultimate templating language!

280
(define (base-tmpl body #:title [title #f])
281
  (define (header-link link-name link-url)
282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299
    (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"))
300
                             (b (a (@ (href ,(golem-url actor-profile)))
301 302 303
                                   "*golem*"))
                             " :: "
                             ,(users-name) "'s site")
304 305
                       (span (@ (id "site-header-right-stuff"))
                             ,(header-link "inbox"
306
                                           (golem-url get-inbox))
307 308
                             " "
                             ,(header-link "outbox"
309
                                           (golem-url get-outbox))))
310 311 312 313 314
               (div (@ (id "site-main-content"))
                    ,body))
          (div (@ (id "site-footer"))
               (a (@ (href "https://gitlab.com/spritely/golem"))
                  "Golem")
315
               " is released under Apache v2 or later"))))
316

317 318 319
(define (generic-base-tmpl . content)
  (base-tmpl (apply generic-content-tmpl content)))

320 321 322 323 324 325 326 327
(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)))

328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346
(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"))))))

Christopher Lemmer Webber's avatar
Christopher Lemmer Webber committed
347 348
;;; Message-sending/receiving workers
;;; =================================
349

350 351 352 353 354
;; 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.
355 356 357 358 359 360 361 362 363 364 365 366 367 368 369
(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))

370 371
;; Process an incoming message.
;; Spawns a separate thread, so this doesn't block the caller.
Christopher Lemmer Webber's avatar
Christopher Lemmer Webber committed
372 373 374 375 376 377 378 379 380 381 382 383 384
(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)))
385
     (collections-append! 'inbox activity-url)))
Christopher Lemmer Webber's avatar
Christopher Lemmer Webber committed
386 387
  (void))

388

389 390 391
;;; Database stuff
;;; ==============

392 393
;; The "collections database" is simply a mutable hashtable where keys
;; are symbols and values are lists of items.
394 395

;; Append VAL to COLLECTION in the global db
396
(define/contract (collections-append! collection val)
397
  (-> symbol? any/c void?)
398 399
  (hash-set! (collections) collection
             (cons val (hash-ref (collections) collection '())))
400 401
  (void))

402 403
;; Fetch all items from COLLECTION in the global COLLECTIONS
(define/contract (collections-ref collection)
404
  (-> symbol? (or/c pair? null?))  ; technically list? but that's pricey :)
405
  (hash-ref (collections) collection '()))
406 407 408 409

;;; Store stuff
;;; ===========

410
;; Handy utility for pulling json out of a magenc store
411 412 413 414 415 416 417 418 419 420
(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))
421

422 423
;;; Application launching
;;; =====================
424

425
;; TODO: This could be simplified if we just set the parameters
426
(define (main #:users-name users-name_
427 428
              #:magenc-store [magenc-store_
                              (new memory-store%)]
429 430 431 432
              #:port [port 8000]
              #:host [host "localhost"]
              #:base-url [base-url_ (url "http" #f
                                         host port
433 434
                                         #f '() '() #f)]
              #:other-stores [other-stores_ '()])
435
  (parameterize ([users-name users-name_]
436
                 [collections (make-hasheq)]
437
                 [magenc-store magenc-store_]
438 439
                 [base-url base-url_]
                 [other-stores other-stores_])
440 441 442
    (serve/servlet golem-dispatch
                   #:servlet-regexp #rx""
                   #:launch-browser? #f
443 444
                   #:listen-ip host
                   #:port port
445 446
                   #:extra-files-paths
                   (list (build-path cwd "static"))))
447 448 449 450
  (void))

(module+ main
  (install-default-factories!)
451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484
  (define other-stores
    (make-parameter '()))
  (define port
    (make-parameter 8000))
  (define host
    (make-parameter "localhost"))
  (command-line
   #:program "golem"
   #:once-each
   [("-o" "--other-stores")
    other-stores-option
    ("Space-separated set of other store URIs to check for content")
    (other-stores
     (map (lambda (str-uri)
            (new web-store%
                 [server-url (string->url str-uri)]))
          (string-split other-stores-option)))]
   [("--port")
    port-option
    ("Port to serve on")
    (port (string->number port-option))]
   [("--host")
    host-option
    ("Hostname to serve on")
    (host host-option)]
   #:args (users-name)
   (main #:users-name users-name
         #:host (host)
         #:port (port)
         #:other-stores (other-stores))))

(module+ try-it-out
  (install-default-factories!)
  (main #:users-name "Alice"))