From 4fe95783b2ff373914d0dccb9b46cb24996f8724 Mon Sep 17 00:00:00 2001
From: haskal <haskal@bepis.xyz>
Date: Tue, 5 May 2020 00:16:46 -0400
Subject: [PATCH] Render bio

---
 private/prefs.rkt |  1 +
 private/rules.rkt | 45 ++++++++++++++++++++++++++++++++++++++++-----
 2 files changed, 41 insertions(+), 5 deletions(-)

diff --git a/private/prefs.rkt b/private/prefs.rkt
index 055e783..5fc5e3f 100644
--- a/private/prefs.rkt
+++ b/private/prefs.rkt
@@ -6,6 +6,7 @@
 
 (define (instance-url? x)
   (and (string? x)
+       (char=? (last (string->list x)) #\/)
        (with-handlers ([exn? (lambda (e) #f)])
           (let ([u (string->url x)])
             (string=? "https" (url-scheme u))))))
diff --git a/private/rules.rkt b/private/rules.rkt
index 9baeca3..f17e9b2 100644
--- a/private/rules.rkt
+++ b/private/rules.rkt
@@ -4,6 +4,8 @@
 
 (require json
          net/url-string
+         markdown
+         markdown/toc
          "compile.rkt"
          "prefs.rkt")
 
@@ -36,18 +38,49 @@
               ;; 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 bio (port->string (hash-ref in "src/bio.md")))
+          (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 instance-url (prefs-get prefs 'instance-url))
           (define actor (hash
                           '@context ACTOR-CONTEXT
                           'Type "Person"
@@ -63,9 +96,11 @@
                           'image (hash 'type "Image"
                                        'url "something"
                                        'sensitive #f)
-                          'tag (list (hash 'type "Hashtag"
-                                           'href (string-append instance-url "tags/blahaj")
-                                           'name "#blahaj"))
+                          '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"