From 29c829509ba908c249be32cdabd6d169fcefd924 Mon Sep 17 00:00:00 2001 From: haskal Date: Thu, 23 Jul 2020 01:02:00 -0400 Subject: [PATCH] add comments, create post template --- private/compile.rkt | 4 +++- private/prefs.rkt | 15 +++++++++++++++ private/rules.rkt | 25 ++++++++++++++++++++----- private/taskq.rkt | 5 +++++ scripts/init | 21 +++++++++++++++++++++ scripts/new-post | 1 + 6 files changed, 65 insertions(+), 6 deletions(-) diff --git a/private/compile.rkt b/private/compile.rkt index c6d72d7..f79bd25 100644 --- a/private/compile.rkt +++ b/private/compile.rkt @@ -1,6 +1,8 @@ #lang racket -;; compiler +;; compiler: +;; infrastructure for incrementally compiling blog contents from source to html/json/etc +;; lots of graphs (it's all graphs) (provide (struct-out rule) generate-operations diff --git a/private/prefs.rkt b/private/prefs.rkt index 5fc5e3f..80f6926 100644 --- a/private/prefs.rkt +++ b/private/prefs.rkt @@ -1,5 +1,8 @@ #lang racket +;; prefs: +;; utilities for reading and writing preferences + (require net/url-string) (provide prefs-save prefs-load prefs-get prefs-update DEFAULT-PREFS) @@ -17,31 +20,39 @@ (define (pronoun-list? x) (and (list? x) (= 5 (length x)))) +;; a preferences schema with validation functions (define SCHEMA (hash 'instance-url instance-url? 'display-name string? 'name id-string? + 'title string? 'make-discoverable boolean? 'is-cat boolean? + 'lang string? 'pronouns pronoun-list?)) (define DEFAULT-PREFS '((instance-url "https://myinstance.tld/") (display-name "Display Name(tm)") (name "username") + (title "My Shiny New Blog") + (lang "en") (make-discoverable #t) (is-cat #t) (pronouns ("they" "them" "their" "theirs" "themselves")))) +;; saves preferences to the given port (or current out) (define (prefs-save prefs [port (current-output-port)]) (pretty-write prefs port)) +;; validates a preference entry against the schema (define (validate-one k v) (unless (hash-has-key? SCHEMA k) (error "unknown preference name" k)) (unless (apply (hash-ref SCHEMA k) (list v)) (error "invalid preference value" v (hash-ref SCHEMA k)))) +;; validates a whole prefs object (define (validate x) (unless (list? x) (error "preferences must be list")) @@ -50,16 +61,20 @@ [(list k v) (validate-one k v)] [_ (error "invalid preference")])) x) +;; check the defaults (void (validate DEFAULT-PREFS)) +;; reads and validates preferences from the given port (or current in) (define (prefs-load [port (current-input-port)]) (validate (read port))) +;; finds a preference by name (define (prefs-get prefs what) (match prefs [(list _ ... (list (? (curry symbol=? what)) value) _ ...) value] [_ (error "no such pref" prefs what)])) +;; updates one key/value pair in the preferences list (define (prefs-update prefs key value) (validate-one key value) (define (upd p) diff --git a/private/rules.rkt b/private/rules.rkt index d2f8277..c533164 100644 --- a/private/rules.rkt +++ b/private/rules.rkt @@ -1,6 +1,7 @@ #lang racket -;; static generation rules +;; rules: +;; the actual rules that generate the blog contents (require json net/url-string @@ -11,6 +12,7 @@ "compile.rkt" "prefs.rkt") +;; actor context object (define ACTOR-CONTEXT (list "https://www.w3.org/ns/activitystreams" "https://w3id.org/security/v1" @@ -64,6 +66,7 @@ (reverse (cons (substring str last-pos) items))])) (first (process+ xexpr))) +;; creates the index.json file (an actor object for this blog) (define compile-index-json (rule '("db/actorkey.pub" "src/instance.rktd" "src/bio.md") "public/index.json" (lambda (in out) @@ -82,6 +85,7 @@ (match p [(list a b _ ...) (format "~a/~a" a b)] [_ "any"])) + (define actor (hash '@context ACTOR-CONTEXT 'Type "Person" @@ -92,35 +96,40 @@ 'isCat (prefs-get prefs 'is-cat) 'pronouns (hash 'en (prefs-get prefs 'pronouns)) 'icon (hash 'type "Image" - 'url "something" + 'url "something" ;; TODO 'sensitive #f) 'image (hash 'type "Image" - 'url "something" + 'url "something" ;; TODO '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 + 'manuallyApprovesFollowers #f ;; TODO 'summary bio - 'attachment (list (hash 'type "PropertyValue" + 'attachment (list (hash 'type "PropertyValue" ;; TODO 'name "pronouns" 'value (render-pronouns))) 'url instance-url 'inbox (string-append instance-url "inbox") 'sharedInbox (string-append instance-url "inbox") + ;; there's only one inbox 'endpoints (hash 'sharedInbox (string-append instance-url "inbox")) 'outbox (string-append instance-url "outbox") + ;; currently we don't support actually following anyone 'following 'null 'followers (string-append instance-url "followers") + ;; liking posts is similarly not supported 'liked 'null + ;; TODO key rotation or something idk 'publicKey (hash 'id (string-append instance-url "#main-key") 'type "Key" 'owner instance-url 'publicKeyPem key))) (write-json actor out)))) +;; builds the webfinger endpoint for the instance actor (define compile-webfinger (rule '("src/instance.rktd") "public/webfinger.json" (lambda (in out) @@ -137,7 +146,9 @@ 'href instance-url)))) (write-json webfinger out)))) +;; generates render rules for each post that is present (define (generate-post-render-rules) + ;; creates a rule that builds common post info into cache (define (make-post-cache-rule post-src post-dst) (rule `("src/instance.rktd" ,post-src) post-dst (lambda (in out) @@ -156,12 +167,14 @@ (s-exp->fasl (hash 'is-meow (hash-ref src-meta 'is-meow #t) 'title (hash-ref src-meta 'title "unknown") + 'summary (hash-ref src-meta 'summary "unknown") 'date (hash-ref src-meta 'date '(0 0 0)) 'hashtags (set->list hashtags) 'toc (toc post-htmls) 'content post-htmls)) out)))) + ;; add all cache rules (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)) @@ -185,12 +198,14 @@ (write-bytes (s-exp->fasl (for/hash ([(k v) (in-hash index)]) (values k (set->list v)))) out))))) +;; build the main blog css (define compile-css (rule '("src/style.sass") "public/style.css" (lambda (in out) (define str (port->string (hash-ref in "src/style.sass"))) (write-string (sass-compile/string str #t) out)))) +;; collect all compiler rules (define compiler-rules (set-union (generate-post-render-rules) diff --git a/private/taskq.rkt b/private/taskq.rkt index cf208b0..07755ae 100644 --- a/private/taskq.rkt +++ b/private/taskq.rkt @@ -1,5 +1,10 @@ #lang racket +;; taskq: +;; infrastructure for a persistent task queue that guarantees each entry will execute to completion +;; at least once. entries are responsible for implementing idempotency in the case of interrupted +;; operations (due to a crash, for example) + (require db crypto racket/fasl) (provide make-taskq taskq-shutdown taskq-enqueue taskq-dequeue taskq-complete taskq-resched) diff --git a/scripts/init b/scripts/init index 4f53588..83d151f 100755 --- a/scripts/init +++ b/scripts/init @@ -55,6 +55,27 @@ (void))) (with-output-to-file "src/style.sass" (lambda () (write-string "// styles go here :P\n") (void))) +;; TODO index template +(with-output-to-file "src/template-post.html" + (lambda () + (write-string ;; TODO add more meta elements / semantic web type stuff + ;; add an embedded json-LD object maybe +" + + + + + + {{post.title}} &em; {{prefs.title}} + + +
+ {{post.content}} +
+ +" +) (void))) + (make-directory "src/posts") (make-directory "src/drafts") diff --git a/scripts/new-post b/scripts/new-post index 1e88c3b..080be18 100755 --- a/scripts/new-post +++ b/scripts/new-post @@ -24,6 +24,7 @@ (lambda () (pretty-write `((date (,(date-year now) ,(date-month now) ,(date-day now))) (title ,name) + (summary "a new post on this blog") (is-meow #t))) (printf "\n# ~a\n\nHello world\n" name)))) (void))