repo2html/main.scm

167 lines
5.6 KiB
Scheme
Raw Normal View History

2022-12-02 16:41:55 -05:00
(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"))
2022-12-02 16:41:55 -05:00
(define REPOSITORY-NAME (pathname-strip-directory (current-directory)))
(define REPOSITORY-DIRECTORY (make-pathname WEB-DIRECTORY REPOSITORY-NAME))
(define (populate-html-template body)
#<#string-block
2022-12-02 16:41:55 -05:00
<!DOCTYPE html>
<html lang="en">
<head>
<title>#{TITLE}</title>
2022-12-02 16:41:55 -05:00
<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}"/>
2022-12-02 16:41:55 -05:00
<style>
body {
margin: 0 auto;
max-width: 700px;
}
2022-12-03 00:47:48 -05:00
pre, code {
background-color: ##ffd9df;
2022-12-03 00:47:48 -05:00
}
pre {
2022-12-02 16:41:55 -05:00
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 {
2022-12-02 16:41:55 -05:00
/* change this to your liking */
}
</style>
</head>
<body>
<h1>#{H1}</h1>
<h2>#{REPOSITORY-NAME}</h2>
<p>clone url: #{CLONE-URL}/#{REPOSITORY-NAME}</p>
2022-12-02 16:41:55 -05:00
<nav>
<a href="/#{REPOSITORY-NAME}/index.html">about</a>
<a href="/#{REPOSITORY-NAME}/files.html">files</a>
2022-12-02 16:41:55 -05:00
</nav>
<hr>
#{body}
2022-12-02 16:41:55 -05:00
</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 '(("&" . "&amp;")
("<" . "&lt;")
(">" . "&gt;")
("\"" . "&quot;")
("'" . "&#39;"))))
(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>
2022-12-02 16:41:55 -05:00
;; 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-page files-list-page-path source-files-list)
2022-12-02 16:41:55 -05:00
(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-page index-page-path)
2022-12-02 16:41:55 -05:00
(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)))
2022-12-02 16:41:55 -05:00
(define (generate-html-files)
(let ((source-files-list (git-repository->paths-list)))
(generate-repository-directory)
(generate-readme-page (make-pathname REPOSITORY-DIRECTORY "index.html"))
(generate-files-page (make-pathname REPOSITORY-DIRECTORY "files.html") source-files-list)
2022-12-02 16:41:55 -05:00
(generate-source-files source-files-list)))
(define (if-git-directory-generate-html-files)
(if (in-git-directory?)
(generate-html-files)
2022-12-02 16:41:55 -05:00
(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))