0216eacef6
- removed old comments - moved todos and nice-to-haves into the README.md's todos and hopes - changed gobally mutated variables to be global constants. originally these were mutated because the code was structured differently, and allowed an option argument, specifying which bare git repo to use, but i removed that, and forgot to remove and change the cruft
164 lines
5.6 KiB
Scheme
164 lines
5.6 KiB
Scheme
(import utf8
|
|
lowdown
|
|
(chicken string)
|
|
(chicken port)
|
|
(chicken io)
|
|
(chicken process)
|
|
(chicken process-context)
|
|
(chicken format)
|
|
(chicken pathname)
|
|
(chicken file))
|
|
|
|
(define WEB-DIRECTORY (or (get-environment-variable "GIT_WWW") "/var/www/git"))
|
|
(define CLONE-URL (or (get-environment-variable "GIT_WWW_CLONE_URL") "git://git.example.com"))
|
|
(define TITLE (or (get-environment-variable "GIT_WWW_TITLE") "my git repositories"))
|
|
(define DESCRIPTION (or (get-environment-variable "GIT_WWW_DESCRIPTION") "my git repositories"))
|
|
(define H1 (or (get-environment-variable "GIT_WWW_H1") "git.example.com"))
|
|
|
|
(define REPOSITORY-NAME (pathname-strip-directory (current-directory)))
|
|
(define REPOSITORY-DIRECTORY (make-pathname WEB-DIRECTORY REPOSITORY-NAME))
|
|
|
|
(define (populate-html-template body)
|
|
#<#string-block
|
|
<!DOCTYPE html>
|
|
<html lang="en">
|
|
<head>
|
|
<title>#{TITLE}</title>
|
|
<meta charset="utf-8" />
|
|
<meta name="viewport" content="width=device-width, initial-scale=1.0, user-scalable=yes" />
|
|
<link rel="icon" href="data:,">
|
|
<meta name="description" content="#{DESCRIPTION}"/>
|
|
<style>
|
|
body {
|
|
margin: 0 auto;
|
|
max-width: 700px;
|
|
}
|
|
pre {
|
|
background-color: ##ffd9df;
|
|
padding: 15px 20px;
|
|
white-space: pre;
|
|
overflow: scroll;
|
|
}
|
|
a { color: blue; }
|
|
nav a { margin-right: 10px; }
|
|
hr {
|
|
border:0;
|
|
border-bottom: 1px solid black;
|
|
margin-top: 16px;
|
|
}
|
|
##file-path {
|
|
/* change this to your liking */
|
|
}
|
|
</style>
|
|
</head>
|
|
<body>
|
|
<h1>#{H1}</h1>
|
|
<h2>#{REPOSITORY-NAME}</h2>
|
|
<p>clone url: #{CLONE-URL}/#{REPOSITORY-NAME}</p>
|
|
<nav>
|
|
<a href="/#{REPOSITORY-NAME}/index.html">about</a>
|
|
<a href="/#{REPOSITORY-NAME}/files.html">files</a>
|
|
</nav>
|
|
<hr>
|
|
#{body}
|
|
</body>
|
|
</html>
|
|
string-block
|
|
)
|
|
|
|
(define (write-file file contents)
|
|
(with-output-to-file file (lambda () (display contents))))
|
|
|
|
(define (in-git-directory?)
|
|
(if (equal? (call-with-input-pipe "git rev-parse --is-bare-repository 2> /dev/null" read-line) "true")
|
|
#t
|
|
#f))
|
|
|
|
(define (git-repository->paths-list)
|
|
(call-with-input-pipe "git ls-tree -r --name-only HEAD" read-lines))
|
|
|
|
(define (git-file->string path)
|
|
(string-intersperse
|
|
(call-with-input-pipe (format "git show HEAD:~a" path) read-lines)
|
|
"\n"))
|
|
|
|
|
|
(define (clean-html str)
|
|
(string-translate* str '(("&" . "&")
|
|
("<" . "<")
|
|
(">" . ">")
|
|
("\"" . """)
|
|
("'" . "'"))))
|
|
|
|
(define (md->html markdown-string)
|
|
(with-output-to-string
|
|
(lambda ()
|
|
(markdown->html markdown-string))))
|
|
|
|
(define (generate-list-of-files source-files-list)
|
|
(if (null? source-files-list)
|
|
""
|
|
(let* ((source-file (car source-files-list))
|
|
(link-url (string-append source-file ".html"))) ;; src/main.scm.html
|
|
(string-append (format "<li><a href=\"~a\">~a</a></li>\n" link-url source-file)
|
|
(generate-list-of-files (cdr source-files-list))))))
|
|
|
|
(define (generate-source-file source-file) ;; src/main.scm
|
|
(let* ((source-file-directory (pathname-directory source-file)) ;; src or #f
|
|
(output-directory (if source-file-directory
|
|
(make-pathname REPOSITORY-DIRECTORY source-file-directory) ;; <WEB-DIRECTORY>/<repository-name>/src
|
|
REPOSITORY-DIRECTORY))) ;; <WEB-DIRECTORY>/<repository-name>
|
|
;; create directories that mimic the path of the source file, so when
|
|
;; someone clicks a link to view the contents of a source file, the URL
|
|
;; matches up with the path of the source file.
|
|
;; i guess another reason to do this is to avoid conflicts with files that
|
|
;; have the same name, but exist in different directories.
|
|
(create-directory output-directory #t)
|
|
(write-file
|
|
(make-pathname output-directory (pathname-strip-directory source-file) "html")
|
|
(populate-html-template (string-append "<p id=\"file-path\">" source-file "</p>"
|
|
"<pre>\n"
|
|
(clean-html (git-file->string source-file))
|
|
"</pre>")))))
|
|
|
|
(define (generate-source-files source-files-list)
|
|
(for-each (lambda (source-file) (generate-source-file source-file))
|
|
source-files-list))
|
|
|
|
(define (generate-files-file files-list-page-path source-files-list)
|
|
(write-file
|
|
files-list-page-path
|
|
(populate-html-template (string-append "<ul>\n"
|
|
(generate-list-of-files source-files-list)
|
|
"</ul>\n"))))
|
|
|
|
(define (generate-readme-file index-page-path)
|
|
(write-file
|
|
index-page-path
|
|
(populate-html-template (md->html (git-file->string "README.md")))))
|
|
|
|
(define (generate-repository-directory)
|
|
(if (directory-exists? REPOSITORY-DIRECTORY)
|
|
(begin (delete-directory REPOSITORY-DIRECTORY #t)
|
|
(create-directory REPOSITORY-DIRECTORY #t))
|
|
(create-directory REPOSITORY-DIRECTORY #t)))
|
|
|
|
(define (generate-html-files)
|
|
(let ((source-files-list (git-repository->paths-list)))
|
|
(generate-repository-directory)
|
|
(generate-readme-file (make-pathname REPOSITORY-DIRECTORY "index.html"))
|
|
(generate-files-file (make-pathname REPOSITORY-DIRECTORY "files.html") source-files-list)
|
|
(generate-source-files source-files-list)))
|
|
|
|
(define (if-git-directory-generate-html-files)
|
|
(if (in-git-directory?)
|
|
(generate-html-files)
|
|
(print "woops that's not a git directory")))
|
|
|
|
(define (main args)
|
|
(if (null? args)
|
|
(if-git-directory-generate-html-files)
|
|
(print "woops, i dont take args")))
|
|
|
|
(main (command-line-arguments))
|
|
|