Ensure relative md links resolve and add nofollow

Julien LepillerMon Mar 08 00:13:24+0100 2021

b2dea6c

Ensure relative md links resolve and add nofollow

gitile/pages.scm

2727 
  #:use-module (srfi srfi-1); fold
2828 
  #:use-module (srfi srfi-19); date/time
2929 
  #:use-module (system foreign)
30+
  #:use-module (web uri)
3031 
  #:export (not-yet-page
3132 
            project-file-raw
3233 
            project-files

…

5455 
     path))
5556 
5657 
(define (file-content repo path ref repository-name)
58+
  (define (ensure-relative-link link)
59+
    "If link is relative, ensure it resolves relative to `path`"
60+
    (if (string->uri link)
61+
        link
62+
        (string-append "/" repository-name "/tree/" (or ref "-") "/" (dirname path)
63+
                       "/" link)))
64+
65+
  (define check-links
66+
    (match-lambda
67+
      ((? string? s) s)
68+
      (('a ('@ arg ...) content ...)
69+
       `(a (@ (rel "nofollow")
70+
              ,@(map
71+
                  (match-lambda
72+
                    (('href link)
73+
                     `(href ,(ensure-relative-link link)))
74+
                    (('rel _)
75+
                     `(rel "nofollow"))
76+
                    (arg arg))
77+
                  arg))
78+
           ,@content))
79+
      ((tag ('@ arg ...) content ...)
80+
       `(,tag (@ ,@arg) ,@(map check-links content)))
81+
      ((tag content ...)
82+
       `(,tag ,@(map check-links content)))))
83+
5784 
  `((div (@ (class "content"))
5885 
     (p ,(basename path))
5986 
     (p (@ (class "button-row"))
…
6390 
    ,(let ((content (utf8->string (get-file-content repo path #:ref ref))))
6491 
       (if (string-suffix? ".md" path)
6592 
         `(article (@ (class "file-content"))
66-
            ,(commonmark->sxml content))
93+
            ,(check-links (commonmark->sxml content)))
6794 
         `(pre ,content)))))
6895 
6996 
(define* (project-files repository-name repo #:key (ref "-") (path '()))