add the ability to embed masto posts

doc/extensions.md

@@ -55,3 +55,24 @@ user pages can be linked to either with a freestanding mention or a link
 
 [link to haskal](@haskal)
 ```
+
+## tech terms
+
+like scribble docs, technical terms can be defined and referenced. currently you need to stem
+manually using the `key` attribute
+
+```
+<deftech key="florp">florps</deftech> are like stars, but shaped like a floppy disk
+
+...
+
+i <tech key="florp">florped</tech> the post
+```
+
+## masto
+
+uwu
+
+```
+<masto>https://cybre.space/@haskal/106372557156109664</masto>
+```

fetch-util.rkt

@@ -0,0 +1,27 @@
+#lang racket/base
+
+(require racket/date racket/match racket/string
+         net/url-string)
+
+(provide get-date parse-url get-user-agent-header)
+
+(define (get-date)
+  (parameterize ([date-display-format 'rfc2822])
+    ;; aaaaaaaaaaaaaaaaaaaaa
+    (regexp-replace
+      #px"[^ ]+$"
+      (date->string (seconds->date (* 0.001 (current-inexact-milliseconds)) #f) #t)
+      "GMT")))
+
+(define (parse-url fetch-url)
+  (printf "fetching page: ~a\n" fetch-url)
+  (define parsed-url (if (string? fetch-url) (string->url fetch-url) fetch-url))
+  (match parsed-url
+    [(url scheme user host port path-absolute? path query fragment)
+     (define ssl? (string=? (string-downcase scheme) "https"))
+     (values parsed-url ssl? host
+             (or port (if ssl? 443 80))
+             (format "/~a" (string-join (map path/param-path path) "/")))]))
+
+(define (get-user-agent-header)
+  (format "User-Agent: Racket/~a (net/http-client) static-generator/0.1 trans/rights" (version)))

fetch.rkt

@@ -0,0 +1,130 @@
+#lang racket/base
+
+(require racket/function racket/list racket/match racket/port net/base64 net/http-client
+         net/url-string json
+         html-parsing crypto crypto/libcrypto threading
+         "fetch-util.rkt")
+
+(provide auth-fetch/ephem masto-fetch-json masto-fetch-embed)
+
+(define (auth-fetch/ephem fetch-url)
+  (parameterize ([crypto-factories (list libcrypto-factory)])
+    (define key (generate-private-key 'rsa '((nbits 4096))))
+
+    (define-values [parsed-url ssl? host port path]
+      (parse-url fetch-url))
+
+    (define date (get-date))
+    (define host-for-header
+      (cond
+        [(if ssl? (= port 443) (= port 80)) host]
+        [else (format "~a:~a" host port)]))
+
+    (define signed-header-spec "(request-target) host date content-length accept")
+    (define signed-content
+      (format "(request-target): get ~a\nhost: ~a\ndate: ~a\ncontent-length: 0\naccept: application/activity+json"
+              path host-for-header date))
+
+    (define signature (base64-encode
+                        (pk-sign key (digest 'sha256 signed-content)
+                                 #:pad 'pkcs1-v1.5 #:digest 'sha256)
+                        #""))
+    (define algorithm "rsa-sha256")
+    (define http-signature (format "keyId=\"~a\",algorithm=\"~a\",headers=\"~a\",signature=\"~a\""
+                                   "foo://example-key" algorithm signed-header-spec signature))
+
+    (displayln http-signature)
+
+    ;; GET /path HTTP/1.1
+    (define req-headers
+      (list
+        ;; host: the host with the port unless it's default
+        ;; accept-encoding: gzip,deflate
+        ;; content-length: (length of content) | transfer-encoding: chunked (if body is a proc)
+        ;; connection: close
+        (format "Date: ~a" date)
+        (format "Accept: application/activity+json")
+        (get-user-agent-header)
+        (format "Signature: ~a" http-signature)))
+
+    (define-values [status resp-headers body]
+      (http-sendrecv host path
+                     #:ssl? ssl?
+                     #:port port
+                     #:version #"1.1"
+                     #:method #"GET"
+                     #:headers req-headers
+                     #:data #f
+                     #:content-decode '(gzip deflate)))
+
+    (displayln status)
+    (displayln resp-headers)
+    (displayln (port->bytes body))
+
+    (void "TODO")))
+
+(define (masto-fetch-json fetch-url)
+  (define-values [parsed-url ssl? host port path]
+    (parse-url fetch-url))
+  (define-values [status resp-headers body]
+    (http-sendrecv host (format "~a.json" path)
+                   #:ssl? ssl?
+                   #:port port
+                   #:version #"1.1"
+                   #:method #"GET"
+                   #:headers (list (get-user-agent-header))
+                   #:data #f
+                   #:content-decode '(gzip deflate)))
+  (~> body port->string string->jsexpr))
+
+(define (masto-extract-embed-content html)
+  (match html
+    ['() #f]
+    [(? string?) #f]
+    [(list 'div (list '@ (list 'class "activity-stream activity-stream--headless")) body ...)
+     body]
+    [(list _ _ children ...) (ormap masto-extract-embed-content children)]))
+
+(define (sxml->xexpr sxml)
+  (match sxml
+    [(? string?) sxml]
+    ['(& nbsp) "\u00a0"]
+    [(list '& _) (error "unhandled &-code" sxml)]
+    [(list tag (cons '@ attrs) body ...)
+     (cons tag (cons attrs (map sxml->xexpr body)))]
+    [(list tag body ...)
+     (cons tag (cons '() (map sxml->xexpr body)))]))
+
+(define (transform-links base xexpr)
+  (match xexpr
+    [(list 'a attrs body ...)
+     (match (assoc 'href attrs)
+       [#f xexpr]
+       [(list _ href)
+        (define filtered (filter (λ (x) (not (eq? (first x) 'href))) attrs))
+        (apply list 'a (cons (list 'href (url->string (combine-url/relative base href))) filtered)
+               (map (curry transform-links base) body))])]
+    [(list tag attrs body ...)
+     (apply list tag attrs (map (curry transform-links base) body))]
+    [(? string?) xexpr]))
+
+(define (masto-fetch-embed fetch-url)
+  (define-values [parsed-url ssl? host port path]
+    (parse-url fetch-url))
+  (define-values [status resp-headers body]
+    (http-sendrecv host (format "~a/embed" path)
+                   #:ssl? ssl?
+                   #:port port
+                   #:version #"1.1"
+                   #:method #"GET"
+                   #:headers (list (get-user-agent-header))
+                   #:data #f
+                   #:content-decode '(gzip deflate)))
+  (~>>
+    (apply list 'article '([class "masto-embed"])
+           (~>> body html->xexp masto-extract-embed-content (map sxml->xexpr)))
+    (transform-links parsed-url)))
+
+(module+ main
+  (require markdown/display-xexpr racket/pretty)
+  (display-xexpr (masto-fetch-embed "https://types.pl/@haskal/106382760904406469")))

render.rkt

@@ -1,8 +1,9 @@
 #lang racket/base
 
 (require racket/list racket/match racket/port racket/pretty racket/set racket/string
+         racket/runtime-path
          markdown markdown/display-xexpr markdown/toc
-         "compiler.rkt" "defs.rkt"
+         "compiler.rkt" "defs.rkt" "fetch.rkt"
          threading
          (prefix-in sass: sass)
          (prefix-in mathml: "ext-mathml/main.rkt")
@@ -12,6 +13,8 @@
 (struct input-doc [metadata text] #:transparent)
 (struct ir-doc [metadata html] #:transparent)
 
+(define-runtime-path *render.scss* "render.scss")
+
 (define (read-input-doc [port (current-input-port)])
   (define metadata (read port))
   (unless (metadata? metadata)
@@ -28,8 +31,8 @@
   (define re (pregexp (string-append start-char "(\\p{L}|\\p{N})+")))
   (define (process+ xexpr)
     (match xexpr
-      ;; do not descend into code or math
+      ;; do not descend into other special tags
-      [(list (or 'code 'math) attrs children ...) (list xexpr)]
+      [(list (or 'code 'math 'tech 'deftech 'masto 'user 'xref) attrs children ...) (list xexpr)]
       ;; recursive
       [(list tag attrs children ...)
        (list (cons tag (cons attrs
@@ -85,16 +88,25 @@
     (match xexpr
       ;; hashtags
       [(list 'hashtag (list (list 'target target)) body ...)
-       `(a ([class "hashtag"] [href ,(string-append base-url "/hashtag/" target)])
+       `(a ([class "hashtag"] [href ,(format "~a/hashtag/~a" base-url target)])
            ,@(map lower-specials* body))]
       ;; xrefs
       [(list 'xref (list (list 'target target)) body ...)
-       `(a ([class "xref"] [href ,(string-append base-url "/xref/" target)])
+       `(a ([class "xref"] [href ,(format "~a/xref/~a" base-url target)])
            ,@(map lower-specials* body))]
       ;; users
       [(list 'user (list (list 'target target)) body ...)
-       `(a ([class "user"] [href ,(string-append base-url "/user/" target)])
+       `(a ([class "user"] [href ,(format "~a/user/~a" base-url target)])
            ,@(map lower-specials* body))]
+      ;; deftech and tech
+      [(list 'deftech (list (list 'key key)) (? string? body))
+       `(em ([class "deftech"] [id ,(format "tech-~a" key)]) ,body)]
+      [(list 'tech (list (list 'key key)) (? string? body))
+       `(a ([class "tech"] [href ,(format "~a/tech/~a" base-url key)]) ,body)]
+      ;; masto
+      ;; TODO
+      [(list 'p _ (list 'masto _ (? string? url)))
+       (masto-fetch-embed url)]
       ;; everything else
       [(list tag attrs children ...)
        (apply list tag attrs (map lower-specials* children))]
@@ -115,7 +127,7 @@
     (with-output-to-string (λ () (display "<!doctype html>") (display-xexpr document)))))
 
 (define (compile-index-scss index.scss)
-  (define scss-files (append mathml:scss-files syntax:scss-files))
+  (define scss-files (cons *render.scss* (append mathml:scss-files syntax:scss-files)))
   (define top-level-style
     (string-join
       (cons index.scss (map (λ (x) (format "@import \"~a\";" (path->string x))) scss-files))

render.scss

@@ -0,0 +1,94 @@
+html, body {
+    margin: 0;
+    padding: 0;
+    font-family: 'Noto Sans', sans-serif;
+    color: #eee;
+    background-color: #111;
+}
+
+a {
+    color: #fff;
+    text-decoration: underline;
+}
+
+article.masto-embed {
+    max-width: 500px;
+    border: 1px solid #aaa;
+    background-color: #222;
+    padding: 1em;
+    margin: 0.5em;
+
+    i.fa {
+        font-style: normal;
+    }
+
+    .fa.fa-globe::before {
+        content: "public";
+    }
+
+    .fa.fa-unlock::before {
+        content: "unlisted";
+    }
+
+    .fa.fa-reply::before {
+        content: "replies: ";
+    }
+
+    .fa.fa-retweet::before {
+        content: "boosts: ";
+    }
+
+    .fa.fa.fa-floppy-o::before {
+        content: "florps: ";
+    }
+
+    .detailed-status {
+        display: flex;
+        flex-direction: row;
+        flex-wrap: wrap;
+
+        div.p-author.h-card {
+            flex: 1;
+
+            a {
+                text-decoration: none;
+                display: flex;
+                flex-direction: row;
+                img.account__avatar {
+                    width: 48px;
+                    height: 48px;
+                    padding-right: 1em;
+                }
+                .display-name {
+                    flex: 1;
+                    display: flex;
+                    flex-direction: column;
+                    .display-name__account {
+                        font-size: 0.95em;
+                    }
+                }
+            }
+        }
+
+        .button.logo-button.modal-button {
+            svg { width: 1.1em; }
+        }
+
+        .emojione.custom-emoji {
+            max-width: 1.1em;
+            max-height: 1.1em;
+        }
+
+        .status__content {
+            width: 100%;
+        }
+        .detailed-status__meta {
+            font-size: 0.95em;
+            width: 100%;
+        }
+
+        .modal-button.detailed-status__link {
+            text-decoration: none;
+        }
+    }
+}