chomp/private/rules.rkt

#lang racket

;; static generation rules

(require json
         net/url-string
         markdown
         markdown/toc
         racket/fasl
         "compile.rkt"
         "prefs.rkt")

(define ACTOR-CONTEXT
  (list "https://www.w3.org/ns/activitystreams"
        "https://w3id.org/security/v1"
        (hash 'manuallyApprovesFollowers "as:manuallyApprovesFollowers"
              'sensitive "as:sensitive"
              'movedTo (hash '@id "as:movedTo"
                             '@type "@id")
              'alsoKnownAs (hash '@id "as:alsoKnownAs"
                                 '@type "@id")
              'Hashtag "as:Hashtag"
              ;; i like how there's actually nothing in this ns
              ;; thanks eugen lmao
              'toot "http://joinmastodon.org/ns#"
              'Emoji "toot:Emoji"
              'focalPoint (hash '@container "@list"
                                '@id "toot:focalPoint")
              'featured (hash '@id "toot:featured"
                              '@type "@id")
              'schema "http://schema.org#"
              'PropertyValue "schema:PropertyValue"
              'value "schema:value"
              'discoverable "toot:discoverable"
              ;; welcome to the awoo zone
              'awoo "https://awoo.systems/ns#"
              ;; misskey has no ns for this so i'm stealing it
              'isCat "awoo:isCat"
              ;; yeah ok why not lol
              'pronouns "awoo:pronouns")))

;; transforms the xexpr into an xexpr that includes links to hashtags
(define (process-hashtags! xexpr instance-url hashtags)
  (define (process+ xexpr)
    (match xexpr
      [(list tag attrs children ...)
       (list (cons tag (cons attrs
                       (apply append
                              (map (lambda (child) (process+ child)) children)))))]
      [(? string? str)
       (define posns (regexp-match-positions* #px"#(\\p{L}|\\p{N})+" str))
       (define-values [items last-pos]
         (for/fold ([items '()] [last-pos 0]) ([pos (in-list posns)])
           (define hashtag (substring str (car pos) (cdr pos)))
           (set-add! hashtags hashtag)
           (values (cons `(a ((href ,(string-append
                                       instance-url
                                       "tags/"
                                       (substring hashtag 1))))
                             ,hashtag)
                         (cons (substring str last-pos (car pos)) items))
                   (cdr pos))))
       (reverse (cons (substring str last-pos) items))]))
  (first (process+ xexpr)))

(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 (prefs-load (hash-ref in "src/instance.rktd")))
          (define instance-url (prefs-get prefs 'instance-url))
          (define bio-md (port->string (hash-ref in "src/bio.md")))

          (define bio-hashtags (mutable-set))
          (define bio-xs (map (lambda (b) (process-hashtags! b instance-url bio-hashtags))
                              (parse-markdown bio-md)))
          (define bio (apply string-append (map xexpr->string bio-xs)))

          (define (render-pronouns)
            (define p (prefs-get prefs 'pronouns))
            (match p
              [(list a b _ ...) (format "~a/~a" a b)]
              [_ "any"]))
          (define actor (hash
                          '@context ACTOR-CONTEXT
                          'Type "Person"
                          'id instance-url
                          'name (prefs-get prefs 'display-name)
                          'preferredUsername (prefs-get prefs 'name)
                          'discoverable (prefs-get prefs 'make-discoverable)
                          'isCat (prefs-get prefs 'is-cat)
                          'pronouns (hash 'en (prefs-get prefs 'pronouns))
                          'icon (hash 'type "Image"
                                      'url "something"
                                      'sensitive #f)
                          'image (hash 'type "Image"
                                       'url "something"
                                       'sensitive #f)
                          'tag (for/list ([hashtag (in-set bio-hashtags)])
                                 (hash 'type "Hashtag"
                                       'href (string-append instance-url "tags/"
                                                            (substring hashtag 1))
                                       'name hashtag))
                          'manuallyApprovesFollowers #f
                          'summary bio
                          'attachment (list (hash 'type "PropertyValue"
                                                  'name "pronouns"
                                                  'value (render-pronouns)))
                          '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 (prefs-load (hash-ref in "src/instance.rktd")))
          (define instance-url (prefs-get prefs 'instance-url))
          (define host (url-host (string->url instance-url)))
          (define name (prefs-get prefs '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 (generate-post-render-rules)
  (define (make-post-cache-rule post-src post-dst)
    (rule `("src/instance.rktd" ,post-src) post-dst
          (lambda (in out)
            (define prefs (prefs-load (hash-ref in "src/instance.rktd")))
            (define instance-url (prefs-get prefs 'instance-url))
            (define src-meta-raw (read (hash-ref in post-src)))
            (define src-meta
              (for/hash ([x (in-list src-meta-raw)])
                (values (first x) (second x))))
            (define post-content (port->string (hash-ref in post-src)))
            (define hashtags (mutable-set))
            (define post-htmls (map (lambda (b)
                                      (process-hashtags! b instance-url hashtags))
                                    (parse-markdown post-content)))
            (write-bytes
              (s-exp->fasl
                (hash 'is-meow (hash-ref src-meta 'is-meow #t)
                      'title (hash-ref src-meta 'title "unknown")
                      'date (hash-ref src-meta 'date '(0 0 0))
                      'hashtags (set->list hashtags)
                      'toc (toc post-htmls)
                      'content post-htmls))
              out))))

  (define-values [posts-set cache-set]
    (for/fold ([posts (set)] [caches (set)]) ([post-name (in-list (directory-list "src/posts"))]
                                              #:when (regexp-match? #px"\\.md$" post-name))
      (define post-src (build-path "src/posts" post-name))
      (define cache-dst (build-path "cache/posts"
                                    (path-replace-extension post-name ".rktb")))
      (define json-dst (build-path "public/posts/"))
      (values
        (set-add posts (make-post-cache-rule post-src cache-dst))
        (set-add caches cache-dst))))
  ;; use the cache set to make a tags rule
  (set-add
    posts-set
    (rule (set->list cache-set) "cache/tagindex.rktb"
          (lambda (in out)
            (define index (make-hash))
            (for ([(fname port) (in-hash in)])
              (define meta (fasl->s-exp (port->bytes port)))
              (for ([tag (in-list (hash-ref meta 'hashtags))])
                (hash-update! index tag (lambda (s) (set-add s fname)) set)))
            (write-bytes (s-exp->fasl (for/hash ([(k v) (in-hash index)])
                                        (values k (set->list v)))) out)))))


(define compiler-rules
  (set-union
    (generate-post-render-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))