1
0
Fork 0
soloweb/soloweb

546 lines
19 KiB
Plaintext
Executable File

#! /usr/bin/env slope
(define c #f) ; Config
(define logo-file #f)
(define repo-name "")
(define repo-dir "")
(define css ":root{--dim:rgb(0,0,0,0.2);--dimmer:rgb(0,0,0,0.05);--bg:rgb(255, 245, 245);--txt:rgb(84, 97, 124);--black:black}@media (prefers-color-scheme: dark){:root{--dim:rgb(255,255,255,0.2);--dimmer:rgb(255,255,255,0.05);--bg:#222;--txt:rgb(255,245,245);--black:white;} a {color: cyan; a:visited{color:skyblue;}}}body{font-family:monospace;line-height:1.5rem;width:60rem;max-width:95vw;margin:auto;background-color:var(--bg);color:var(--txt)}footer,header,main{padding:2.5rem 0}header{padding-bottom:0}ol,table,ul{margin-bottom:2rem;width:100%}header h1{text-align:right}header img{border-radius:5px;width:6rem;height:6rem;object-fit:cover;object-position:contain;float:right;margin-left:2rem}header p{text-align:right}nav a{padding:0.3rem 0.5rem;display:inline-block;border:2px solid var(--black);border-bottom:0;border-radius:5px 5px 0 0;background:var(--txt);color:var(--bg);text-decoration:none}nav a:last-child{font-size:1.2em;border:none;font-weight:bold;color:var(--txt);background-color:var(--bg);}main{border-top:2px solid;border-bottom:2px solid;}nav{margin-left:0.25rem}article{border:1px solid var(--txt);margin:3rem auto;border-radius:6px}.readme{background-color:var(--txt);color:var(--bg);padding:0.5rem;border-radius:5px 5px 0 0;margin:0}.readmebody{padding:1rem;overflow:scroll;}.readmebody pre{white-space:pre-wrap;}ul{list-style:none;padding-left:0}ul > li{padding:0.2rem 0.5rem;display:inline-block;border:1px dashed var(--dim);border-radius:5px}.filetree{border-radius:5px;border:1px solid var(--txt)}.filetree li{border:none;border-bottom:1px dashed var(--dim);display:block;line-height:2rem}.filetree li span{float:right}.filetree li:nth-child(odd){background-color:var(--dimmer);max-width:100%;overflow:auto}table,table td,table th{border-collapse:collapse;border-bottom:2px solid var(--txt);padding:0.33em 0.66em;text-align:left;vertical-align:middle}table th{font-size:1.1em}#branch{text-align:right;}#branch span{padding:5px;border:1px dotted #000;border-radius: 0 5px 5px 0; background-color: var(--bg);}#branch span:first-child{user-select:none;background-color:var(--txt);color:var(--bg);border-radius:5px 0 0 5px;}")
(define page-head (lambda (title-extra)
(define b (string-make-buf))
(write "<!DOCTYPE html>\n" b)
(write "<html lang=\"en\">\n" b)
(write "\t<head>\n" b)
(write (append "\t\t<title>" repo-name " - " title-extra "</title>\n") b)
(write "\t\t<meta charset=\"UTF-8\">\n" b)
(write "\t\t<meta name=\"viewport\" content=\"width=device-width, initial-scale=1.0\">\n" b)
(write (append "\t\t<style>\n" css "\n\t\t</style>\n") b)
(write "\t</head>\n" b)
(write "\t<body>\n" b)
(read-all b)))
(define page-header (lambda (description level-from-root)
(define b (string-make-buf))
(define to-root
(if (zero? level-from-root)
"" (list->string (list-seed level-from-root "..") "/")))
(write "\t\t<header>\n" b)
(if logo-file
(write
(string-format
"\t\t\t<img src=\"%v\" alt=\"\">\n"
(path-join to-root logo-file))
b))
(write (append "\t\t\t<h1>" repo-name "</h1>\n") b)
(if (~bool description)
(write (append "\t\t\t<p>" description "</p>\n") b))
(write "\t\t\t<nav>\n" b)
(write
(string-format
"\t\t\t\t<a href=\"%v\">%v</a>\n"
(path-join to-root "index.html") ;; Contains a file list, as well as the README displayed
"Files") b)
(write
(string-format
"\t\t\t\t<a href=\"%v\">%v</a>\n"
(path-join to-root "history.html")
"History") b)
(write
(string-format
"\t\t\t\t<a href=\"%v\">%v</a>\n"
(path-join to-root "references.html")
"References") b)
(write
(string-format
"\t\t\t\t<a href=\"%v\">Download</a>\n"
(path-join to-root (append repo-name ".tar.gz")))
b)
(write "\t\t\t</nav>" b)
(write "\t\t</header>\n" b)
(write "\t\t<main>\n" b)
(read-all b)))
(define make-files-html (lambda ()
(define b (string-make-buf))
(write (page-head "Files") b)
(write (page-header (assoc c "description") 0) b)
(write "\t\t\t<h2>Files</h2>\n" b)
(write
(append
"\t\t\t<p id=branch><span>master</span><span>"
(assoc (assoc c "heads") "master")
"</span></p>\n") b)
(write "\t\t\t<ul class=filetree>\n" b)
(define repo-root
(path-join
repo-dir
".solo" "tree" "master"
(assoc (assoc c "heads") "master")
"data"))
(define files (path-glob (path-join repo-root "**")))
(for-each
(lambda (in)
(define from (car in))
(define to (car (cdr in)))
(define buf (string-make-buf))
(write (page-head to) buf)
(write (page-header (assoc c "description") (count-dirs to)) buf)
(write
(append
"\t\t\t<article>\n"
"\t\t\t\t<h2 class=readme>"
(string-replace to "files/" "")
"</h2>\n\t\t\t\t<div class=readmebody>\n")
buf)
(write "\t\t\t\t<pre><code>" buf)
(define filedata (open-read-close from))
(set! filedata (html-escape filedata))
(write filedata buf)
(write "</code></pre>\n\t\t\t\t</div>\n\t\t\t</article>" buf)
(write (page-footer) buf)
(mkdir (path-dir to) 0755 #t)
(define f (file-create (append to ".html")))
(if f
(close (write (read-all buf) f))))
(map
(lambda (p)
[p (string-replace p repo-root "files")])
(filter
(lambda (p)
(not (path-is-dir? p)))
files)))
(for-each
(lambda (p)
(define size (file-size (car (cdr p))))
(write
(append
"\t\t\t\t<li><a href=\""
(car p) ".html\">"
(string-replace (car p) "files/" "" 1) "</a>"
"<span>" (if size size "") "</span>" "</li>\n")
b))
(list-sort (map
(lambda (p)
[
(string-replace p repo-root "files" 1)
p])
(filter
(lambda (p)
(not (path-is-dir? p)))
files))))
(write "\t\t\t</ul>\n" b)
(define readme (has-readme?))
(if readme
(begin
(write "\t\t\t<article>\n" b)
(write
(append
"\t\t\t\t<h2 class=readme>"
(path-base readme)
"</h2>\n\t\t\t\t<div class=readmebody>\n")
b)
(write "\t\t\t\t<pre><code>" b)
(write (open-read-close (path-join readme)) b)
(write "</code></pre>\n\t\t\t\t</div>\n\t\t\t</article>" b)))
(write (page-footer) b)
(define f (file-create "index.html"))
(if f
(begin
(write (read-all b) f)
(close f))
(error-exit "Could not write 'index.html'"))))
(define transpile-gemtext (lambda (gt buf)
(define in-pre? #f)
(define in-list? #f)
(for-each
(lambda (l)
(if
(and
in-list?
(positive? (length l) (not (equal? "*" (ref l 0)))))
(begin
(write "\t\t\t\t</ul>\n" buf)
(set! in-list? #f)))
(cond
((and in-pre? (not (equal? (slice l 0 3) "```")))
(write l buf))
((and in-pre? (equal? (slice l 0 3) "```"))
(write "</pre>\n" buf))
((equal? (string-trim-space l) "") (write "\t\t\t\t<br>\n" buf))
((regex-match? "^###.+" l)
(write
(append
"\t\t\t\t<h3>"
(string-trim-space (slice l 3))
"</h3>\n") buf))
((regex-match? "^##.+" l)
(write (append "\t\t\t\t<h2>" (string-trim-space (slice l 2)) "</h2>\n") buf))
((regex-match? "^#.+" l)
(write (append "\t\t\t\t<h1>" (string-trim-space (slice l 1)) "</h1>\n") buf))
((equal? "*" (ref l 0))
(if in-list?
(write (append "\t\t\t\t\t<li>" l "</li>\n") buf)
(begin
(set! in-list? #t)
(write
(append "\t\t\t\t<ul>\n\t\t\t\t\t<li>" l "</li>\n") buf))))
((equal? "&gt;" (slice l 0 4))
(write (append "\t\t\t\t<blockquote>" l "</blockquote>\n") buf)
((regex-match? "^=&gt;\\s*\\S+" l)
(begin
(define parts
(string->list (string-trim-space (ref l 5)) " " 1))
(if (>= (length parts) 2)
(write
(append
"\t\t\t\t<a href=\""
(car parts)
"\" target=\"_blank\">"
(car (cdr parts))
"</a>\n")
buf)
(write
(append
"\t\t\t\t<a href=\""
(car parts)
"\" target=\"_blank\">"
(car parts)
"</a>\n")
buf))))
((equal? (slice l 0 3) "```")
(begin
(set! in-pre? #t)
(write "\t\t\t\t<pre>" buf)))
(else (write (append "\t\t\t\t" l "<br>\n") buf)))))
(string->list gt "\n"))))
(define make-references-html (lambda ()
(define b (string-make-buf))
(write (page-head "References") b)
(write (page-header (assoc c "description") 0) b)
(write "\t\t\t<h2>References</h2>\n" b)
(write "\t\t\t<h3>Branches</h3>\n" b)
(write "\t\t\t<ul>\n" b)
(for-each
(lambda (branch)
(write
(string-format
"\t\t\t\t<li>%v</li>\n"
branch)
b))
(list-sort (map car (assoc c "heads"))))
(write "\t\t\t</ul>\n" b)
(write "\t\t\t<h3>Tags</h3>\n" b)
(if (null? (assoc c "tags"))
(write "\t\t\t<p><i>None</i></p>\n" b)
(begin
(write "\t\t\t<table>\n\t\t\t\t<thead>\n" b)
(write "\t\t\t\t\t<tr>\n" b)
(write "\t\t\t\t\t\t<th>Tag Name</th>\n" b)
(write "\t\t\t\t\t\t<th>Branch</th>\n" b)
(write "\t\t\t\t\t\t<th>Snap</th>\n" b)
(write "\t\t\t\t\t\t<th>Message</th>\n" b)
(write "\t\t\t\t\t</tr>\n" b)
(write "\t\t\t\t</thead>\n\t\t\t\t<tbody>\n" b)))
(for-each
(lambda (t)
(write "\t\t\t\t\t<tr>\n" b)
(write
(string-format
"\t\t\t\t\t\t<td>%v</td>\n"
t)
b)
(define data
(eval (open-read-close (path-join repo-dir ".solo" "tags" t)) #t))
(if data
(begin
(write
(string-format
"\t\t\t\t\t\t<td>%v</td>\n"
(car data))
b)
(write
(string-format
"\t\t\t\t\t\t<td>%v</td>\n"
(car (cdr data)))
b)
(write
(string-format
"\t\t\t\t\t\t<td>%v</td>\n"
(car (reverse data)))
b))
(write "\t\t\t\t\t\t<td colspan=\"3\"><i>No Data</i></td>\n" b))
(write "\t\t\t\t\t</tr>\n" b))
(assoc c "tags"))
(write "\t\t\t\t</tbody>\n\t\t\t</table>\n" b)
;; Write history content
(write (page-footer) b)
(define f (file-create "references.html"))
(if f
(begin
(write (read-all b) f)
(close f))
(error-exit "Could not write 'references.html'"))))
(define page-file-body (lambda ()
#f))
(define page-footer (lambda ()
(define b (string-make-buf))
(write "\t\t</main>\n" b)
(write "\t\t<footer>\n" b)
(write "\t\t\t<p>This page was generated by soloweb, a static web compiler for solo repositories. Only files from the <i>master</i> branch are available through the web, but other branches (as listed in references) are available if the repository is downloaded</p>\n" b)
(write "\t\t</footer>\n" b)
(write "\t</body>\n" b)
(write "</html>\n" b)
(read-all b)))
(define has-readme? (lambda ()
(define files (path-glob (path-join repo-dir ".solo" "tree" "master" (assoc (assoc c "heads") "master") "data" "*")))
(define readme
(filter
(lambda (p)
(regex-match? "(?i)/readme(\\.(txt|md|gmi))?$" p))
files))
(if (null? readme)
#f
(car readme))))
(define ask/confirm (lambda (msg)
(define loop (lambda ()
(write (append "\033[1m" msg "\033[0m: "))
(define answer (read-line))
(write (append "Is \033[4m" (if (equal? anser "") "(NULL)" answer) "\033[0m correct? (y/n)"))
(if (not (equal? "y" (string-lower (get-char))))
(begin
(newline)
(loop))
answer)))
(loop)))
(define is-solo? (lambda (...)
(define root (if (null? ...) (pwd) (path-abs (car ...))))
(if
(and
(path-exists? (path-join root ".solo" "solo.conf"))
(path-exists? (path-join root ".solo" "tree" "master")))
#t
(error-exit "The given path does not lead to a solo root"))))
(define get-tags (lambda (...)
(define c (get-conf-from-root (if (null? ...) (pwd) (car ...))))
(if (not c)
(error-exit "'get-tags' encountered an invalid repo. solo.conf was not found/readable"))
(assoc c "tags")))
(define get-conf-from-root (lambda (root)
(define data (open-read-close (path-join root ".solo" "solo.conf")))
(if data
(eval data #t)
data)))
(define open-read-close (lambda (p)
(define f (file-open-read (path-abs p)))
(if f
(begin0
(read-all f)
(close f))
#f)))
(define error-exit (lambda (msg)
(write (append msg "\n") stderr)
(exit 1)))
(define move-files (lambda (head)
(define from-root (path-join repo-dir ".solo" "tree" "master" head "data"))
(define file-list
(filter
(lambda (p) (not (path-is-dir? p)))
(path-glob (path-join from-root "**"))))
(for-each
(lambda (p)
(cp
p
(string-replace p from-root (path-join (pwd) "files"))))
file-list)))
;; `cp` copies a file from one path to another
(define cp (lambda (from to)
(if (path-is-dir? from)
(mkdir (path-abs to) 0775 #t)
(begin
(define in (file-open-read from))
(define out (file-create to))
(if (and in out (not (assoc (file-stat from) "is-dir?")))
(begin
(write (read-all in) out)
(close in)
(close out)
(chmod to (assoc (file-stat from) "mode"))))))))
;; `conf` writes and reads to the solo.conf file inside of the .solo directory
;; If nothing is passed it will read the existing file. If data is passed, it will be
;; written to the file and clobber the old data
(define conf (lambda (repo-dir ...)
(define sf-path (path-join repo-dir ".solo" "solo.conf"))
(if (null? ...)
(begin
(define data (open-read-close sf-path))
(if data
(eval data #t)
(error-exit "Could not read solo configuration file. Are you in the repo root? Is the file corrupt?")))
(begin
(define sf (file-create sf-path))
(if sf
(close (write (car ...) sf))
(error-exit "Error writing solo configuration"))))))
(define make-history-html (lambda ()
(define b (string-make-buf))
(write (page-head "History") b)
(write (page-header (assoc c "description") 0) b)
(write "\t\t\t<h2>History</h2>\n" b)
(write "\t\t\t<table>\n\t\t\t\t<thead>\n" b)
(write "\t\t\t\t\t<tr>\n" b)
(write "\t\t\t\t\t\t<th>Date</th>\n" b)
(write "\t\t\t\t\t\t<th>Message</th>\n" b)
(write "\t\t\t\t\t\t<th>Snap</th>\n" b)
(write "\t\t\t\t\t\t<th>Author</th>\n" b)
(write "\t\t\t\t\t</tr>\n" b)
(write "\t\t\t\t</thead>\n\t\t\t\t<tbody>\n" b)
(define loop (lambda (buffer id head?)
(define p (path-join repo-dir ".solo" "tree" "master" id "meta"))
(define data (if (path-exists? p) (open-read-close p) p))
(if data
(set! data (eval data #t))
(error-exit "Loop issue while generating history"))
(define panic-mode? (exception-mode-panic?))
(if (pair? data)
(begin
(write "\t\t\t\t\t<tr>\n" buffer)
(if panic-mode? (exception-mode-pass))
(write
(string-format
"\t\t\t\t\t\t<td>%v</td>\n"
(date-format
(date-default-format)
(assoc data "time")
"%Y-%M-%D %H:%I%a"))
buffer)
(write
(string-format
"\t\t\t\t\t\t<td>%v</td>\n"
(assoc data "message"))
buffer)
(write
(string-format
"\t\t\t\t\t\t<td>%v %v</td>\n"
id
(if head? "<sup>[HEAD]</sup>" ""))
buffer)
(write
(string-format
"\t\t\t\t\t\t<td>%v</td>\n"
(assoc data "user"))
buffer)
(write "\t\t\t\t\t</tr>\n" buffer)))
(if (~bool (assoc data "parent-commit"))
(begin0
(loop buffer (assoc data "parent-commit") #f)
(if panic-mode? (exception-mode-panic)))
(if panic-mode? (exception-mode-panic)))))
(loop b (assoc (assoc c "heads") "master") #t)
(write "\t\t\t\t</tbody>\n\t\t\t</table>\n" b)
;; Write history content
(write (page-footer) b)
(define f (file-create "history.html"))
(if f
(begin
(write (read-all b) f)
(close f))
(error-exit "Could not write 'history.html'"))))
(define file-size (lambda (path)
(define stat (file-stat path))
(define size (if stat (assoc stat "size") #f))
(if size
(cond
((>= size 1000000000) (append (round (/ (/ (/ 1000 size) 1000) 1000) 2) " gb")) ; GB
((>= size 1000000) (append (round (/ (/ 1000 size) 1000) 2) " mb")) ; MB
((>= size 1000) (append (round (/ size 1000) 2) " kb")) ;KB
(else (append size "&nbsp; b")))
#f)))
(define html-escape (lambda (str)
(list->string
(map
(lambda (c)
(case c
("&" "&amp;")
(">" "&gt;")
("<" "&lt;")
("'" "&apos;")
("\"" "&quot;")
(else c)))
(string->list str)))))
(define count-dirs (lambda (p)
(length (filter (lambda (c) (equal? c "/")) (string->list p)))))
(define init (lambda (solo-path)
(is-solo? solo-path)
(if (equal? (path-dir solo-path) (pwd))
(error-exit "soloweb error: the site cannot be generated in the same directory as the repository, as the folders will share a name"))
(set! repo-dir solo-path)
(set! c (conf solo-path))
(set! repo-name (path-base solo-path))
(define new-base (path-join (pwd) repo-name))
(mkdir new-base 0755)
(chdir new-base)
(display-lines "soloweb: archiving and compressing")
(chdir (path-dir repo-dir))
(subprocess ["tar" "-czf" (append repo-name ".tar.gz") repo-name] devnull devnull) ; Get a tarball of the repo
(mv (append repo-name ".tar.gz") (path-join new-base (append repo-name ".tar.gz")))
(chdir new-base)
(mkdir "files" 0755)
(define logo-list (path-glob (path-join repo-dir ".solo" "logo.*")))
(if (not (null? logo-list))
(begin
(set! logo-file (path-base (car logo-list)))
(cp (car logo-list) logo-file))
(display-lines "No logo file was found, skipping"))
(display-lines "soloweb: generating html")
(make-history-html)
(make-files-html)
(make-references-html)
(write "soloweb: done!\n")))
(define main (lambda ()
(set! sys-args (cdr sys-args))
(case (length sys-args)
(0 (error-exit "No solo repo path was given"))
(1 (init (path-abs (car sys-args))))
(else
(error-exit "Too many arguments. Expected only a path to a solo repo.")))))
(main)
; vim: ts=2 sw=2 expandtab ft=slope