chomp/private/rules.rkt

#lang racket

;; static generation rules

(require json
         net/url-string
         "compile.rkt")

(define (get-pref prefs what)
  (match prefs
    [(list _ ... (list (? (curry symbol=? what)) value) _ ...) value]
    [_ (error "no such pref" prefs what)]))

(define ACTOR-CONTEXT
  (list "https://www.w3.org/ns/activitystreams"
        "https://w3id.org/security/v1"
        (hash 'manuallyApprovesFollowers "as:manuallyApprovesFollowers"
              'sensitive "as:sensitive"
              'movedTo "as:movedTo"
              'Hashtag "as:Hashtag"
              'toot "http://joinmastodon.org/ns#"
              'Emoji "toot:Emoji"
              'focalPoint (hash '@container "@list"
                                 '@id "toot:focalPoint")
              'featured "toot:featured")))

(define compile-index-json
  (rule '("db/actorkey.pub" "src/instance.rktd" "src/bio.md") "public/index.json"
        (lambda (in out)
          (define key (port->string (hash-ref in "db/actorkey.pub")))
          (define prefs (read (hash-ref in "src/instance.rktd")))
          (define instance-url (get-pref prefs 'shonks:instance-url))
          (define display-name (get-pref prefs 'shonks:display-name))
          (define name (get-pref prefs 'shonks:name))
          (define bio (port->string (hash-ref in "src/bio.md")))
          (define actor (hash
                          '@context ACTOR-CONTEXT
                          'Type "Person"
                          'id instance-url
                          'name display-name
                          'preferredUsername name
                          'icon (hash 'type "Image"
                                       'url "something"
                                       'sensitive #f)
                          'image (hash 'type "Image"
                                       'url "something"
                                       'sensitive #f)
                          'tag (list (hash 'type "Hashtag"
                                            'href (string-append instance-url "tags/blahaj")
                                            'name "#blahaj"))
                          'manuallyApprovesFollowers #f
                          'summary bio
                          'attachment (list (hash 'type "PropertyValue"
                                                   'name "pronouns"
                                                   'value "they/them"))
                          'url instance-url
                          'inbox (string-append instance-url "inbox")
                          'sharedInbox (string-append instance-url "inbox")
                          'endpoints (hash 'sharedInbox (string-append instance-url "inbox"))
                          'outbox (string-append instance-url "outbox")
                          'following 'null
                          'followers (string-append instance-url "followers")
                          'liked 'null
                          'publicKey (hash 'id (string-append instance-url "#main-key")
                                            'type "Key"
                                            'owner instance-url
                                            'publicKeyPem key)))
          (write-json actor out))))

(define compile-webfinger
  (rule '("src/instance.rktd") "public/webfinger.json"
        (lambda (in out)
          (define prefs (read (hash-ref in "src/instance.rktd")))
          (define instance-url (get-pref prefs 'shonks:instance-url))
          (define host (url-host (string->url instance-url)))
          (define name (get-pref prefs 'shonks:name))
          (define webfinger
            (hash
              'subject (format "acct:~a@~a" name host)
              'links (list (hash
                             'rel "self"
                             'type "application/activity+json"
                             'href instance-url))))
          (write-json webfinger out))))

(define compiler-rules
   (set compile-index-json
        compile-webfinger))

(define ops (generate-operations compiler-rules))
(for ([op (in-list ops)])
  (printf "executing ~s\n" op)
  (execute-rule op))