make relative xrefs work

render.rkt

@@ -1,7 +1,7 @@
 #lang racket/base
 
 (require racket/fasl racket/list racket/match racket/port racket/path racket/set racket/string
-         racket/runtime-path
+         racket/runtime-path net/url-string
          markdown markdown/display-xexpr markdown/toc
          "compiler.rkt" "defs.rkt" "fetch.rkt"
          threading
@@ -17,6 +17,8 @@
 
 (define *index.md* (build-path "index.md"))
 
+(define *reserved-slugs* (set (build-path "hashtag") (build-path "user") (build-path "tech")))
+
 (define (read-input-doc xref-name [port (current-input-port)])
   (define metadata (read port))
   (unless (metadata? metadata)
@@ -74,19 +76,25 @@
 (define (extract-prefixed-links/many xexprs start-char tag-name)
   (map (λ (xexpr) (extract-prefixed-links xexpr start-char tag-name)) xexprs))
 
-(define (check-xrefs xexprs xrefs-repo)
+(define (check-xrefs xexprs xrefs-repo base-xref)
   (define (check-xrefs-help xexpr)
     (match xexpr
       [(list 'xref (list (list 'target target)) body ...)
-       (define target-path (explode-path (build-path "/" target)))
-       (unless (set-member? xrefs-repo target-path)
+       (define abs-target
+         (simplify-path
+           (url->path
+             (combine-url/relative
+               (path->url base-xref)
+               target))
+           #f))
+       (unless (set-member? xrefs-repo (explode-path abs-target))
          (error "invalid xref!" target))
-       (map check-xrefs-help body)]
+       (apply list 'xref (list (list 'target (path->string abs-target)))
+              (map check-xrefs-help body))]
       [(list tag attrs body ...)
-       (map check-xrefs-help body)]
-      [(? string?) (void)]))
-  (map check-xrefs-help xexprs)
-  xexprs)
+       (cons tag (cons attrs (map check-xrefs-help body)))]
+      [(? string?) xexpr]))
+  (map check-xrefs-help xexprs))
 
 (define (input-doc->ir-doc doc xrefs-repo)
   (match-define (input-doc md xref-name text) doc)
@@ -97,7 +105,7 @@
         (extract-text-starting-with/many *user-char* 'user)
         (extract-prefixed-links/many *xref-char* 'xref)
         (extract-prefixed-links/many *user-char* 'user)
-        (check-xrefs xrefs-repo)))
+        (check-xrefs xrefs-repo xref-name)))
   (ir-doc md xref-name output-cooked))
 
 ;; lowers pseudo-tags into their final form
@@ -110,7 +118,7 @@
            ,@(map lower-specials* body))]
       ;; xrefs
       [(list 'xref (list (list 'target target)) body ...)
-       `(a ([class "xref"] [href ,(format "~a/xref/~a" base-url target)])
+       `(a ([class "xref"] [href ,(format "~a~a" base-url target)])
            ,@(map lower-specials* body))]
       ;; users
       [(list 'user (list (list 'target target)) body ...)
@@ -182,7 +190,10 @@
 
   (define xrefs-repo
     (for/set ([spec (in-list rule-specs)])
-      (explode-path (rule-spec-xref-name spec))))
+      (define exploded (explode-path (rule-spec-xref-name spec)))
+      (when (and (> (length exploded) 1)
+                 (set-member? *reserved-slugs* (second exploded)))
+        (error "file is using a reserved slug" (rule-spec-src spec)))))
 
   (define intermediate-rules
     (for/list ([spec (in-list rule-specs)])