Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Initial commit.

  • Loading branch information...
commit 7819dfbdbfd356fb025fd8f69dda6f8f70c79ee9 0 parents
@orivej authored
Showing with 252 additions and 0 deletions.
  1. +83 −0 README.md
  2. +12 −0 package.lisp
  3. +8 −0 quickdist.asd
  4. +149 −0 quickdist.lisp
83 README.md
@@ -0,0 +1,83 @@
+# Overview
+
+Quickdist creates and updates Quicklisp distributions from a directory of local projects. It maintains distinfo.txt, releases.txt, systems.txt and source archive - all that is needed for a distribution. Currently it requires external utilities to work: /bin/tar, /bin/sh, /usr/bin/md5sum, sha1sum.
+
+# API
+
+A few dynamic variables and one function are exported.
+
+Dynamic variables determine the layout of files on disk and on the web server. Such are the defaults:
+
+```lisp
+(defparameter *distinfo-template*
+ "name: {name}
+version: {version}
+distinfo-subscription-url: {base-url}/{name}.txt
+release-index-url: {base-url}/{name}/{version}/releases.txt
+system-index-url: {base-url}/{name}/{version}/systems.txt
+")
+(defparameter *distinfo-file-template* "{dists-dir}/{name}.txt")
+(defparameter *dist-dir-template* "{dists-dir}/{name}/{version}")
+(defparameter *archive-dir-template* "{dists-dir}/{name}/archive")
+(defparameter *archive-url-template* "{base-url}/{name}/archive")
+```
+
+The only exported function is `quickdist`.
+
+```lisp
+quickdist (&key name (version :today) base-url projects-dir dists-dir)
+```
+
+`name`, `version`, `base-url` and `dists-dir` provide values for the templates. A special default version `:today` is resolved to the current date in `YYYYMMDD` format. `projects-dir` is the directory each subdirectory of which is treated as a separate project to be included in the distribution.
+
+# Example
+
+Suppose you have some projects in `~/projects/`, you want to publish them from `~/dists/` and you name the distribution `quickdist`. Then after loading quickdist and hunchentoot:
+
+```lisp
+cl-user> (quickdist:quickdist :name "quickdist" :base-url "http://localhost:4242/" :projects-dir "~/projects" :dists-dir "~/dists")
+Processing {project1}...
+Processing {project2}...
+...
+nil
+cl-user> (push (hunchentoot:create-folder-dispatcher-and-handler "/" "~/dists/") hunchentoot:*dispatch-table*)
+(#<CLOSURE (lambda # :in hunchentoot:create-prefix-dispatcher) {100A30DEAB}> hunchentoot:dispatch-easy-handlers)
+cl-user> (hunchentoot:start (make-instance 'hunchentoot:easy-acceptor :port 4242))
+#<hunchentoot:easy-acceptor (host *, port 4242)>
+cl-user> (ql-dist:install-dist "http://localhost:4242/quickdist.txt")
+127.0.0.1 - [2012-11-30 10:46:29] "get /quickdist.txt http/1.1" 200 241 "-" "quicklisp-client/2012112500 SBCL/1.1.0"
+; Fetching #<url "http://localhost:4242/quickdist.txt">
+; 0.24KB
+==================================================
+241 bytes in 0.00 seconds (0.00KB/sec)
+Installing dist "quickdist" version "20121130".
+Press Enter to continue.
+
+127.0.0.1 - [2012-11-30 10:46:31] "get /quickdist/20121130/releases.txt http/1.1" 200 295 "-" "quicklisp-client/2012112500 SBCL/1.1.0"
+; Fetching #<url "http://localhost:4242/quickdist/20121130/releases.txt">
+; 0.29KB
+==================================================
+295 bytes in 0.00 seconds (0.00KB/sec)
+127.0.0.1 - [2012-11-30 10:46:31] "get /quickdist/20121130/systems.txt http/1.1" 200 132 "-" "quicklisp-client/2012112500 SBCL/1.1.0"
+; Fetching #<url "http://localhost:4242/quickdist/20121130/systems.txt">
+; 0.13KB
+==================================================
+132 bytes in 0.00 seconds (128.91KB/sec)
+#<ql-dist:dist quickdist 20121130>
+cl-user> (ql:quickload :symbol-namestring) ; for example
+To load "symbol-namestring":
+ Load 1 ASDF system:
+ named-readtables
+ Install 1 Quicklisp release:
+ symbol-namestring
+127.0.0.1 - [2012-11-30 10:47:23] "get /quickdist/archive/symbol-namestring-20120812.tgz http/1.1" 200 14842 "-" "quicklisp-client/2012112500 SBCL/1.1.0"
+; Fetching #<url "http://localhost:4242/quickdist/archive/symbol-namestring-20120812.tgz">
+; 14.49KB
+==================================================
+14,842 bytes in 0.00 seconds (14494.14KB/sec)
+; Loading "symbol-namestring"
+[package symbol-namestring]
+(:symbol-namestring)
+cl-user> (ql-dist:uninstall (ql-dist:find-dist "quickdist")) ; no longer want this dist
+t
+```
12 package.lisp
@@ -0,0 +1,12 @@
+(defpackage #:quickdist
+ (:use #:cl #:alexandria)
+ (:import-from #:quicklisp
+ #:file-size)
+ (:import-from #:asdf
+ #:load-sysdef)
+ (:export #:quickdist
+ #:*distinfo-template*
+ #:*distinfo-file-template*
+ #:*dist-dir-template*
+ #:*archive-dir-template*
+ #:*archive-url-template*))
8 quickdist.asd
@@ -0,0 +1,8 @@
+(asdf:defsystem quickdist
+ :depends-on (alexandria
+ cl-fad
+ external-program
+ quicklisp)
+ :serial t
+ :components ((:file "package")
+ (:file "quickdist")))
149 quickdist.lisp
@@ -0,0 +1,149 @@
+(in-package #:quickdist)
+
+(defparameter *distinfo-template*
+ "name: {name}
+version: {version}
+distinfo-subscription-url: {base-url}/{name}.txt
+release-index-url: {base-url}/{name}/{version}/releases.txt
+system-index-url: {base-url}/{name}/{version}/systems.txt
+")
+(defparameter *distinfo-file-template* "{dists-dir}/{name}.txt")
+(defparameter *dist-dir-template* "{dists-dir}/{name}/{version}")
+(defparameter *archive-dir-template* "{dists-dir}/{name}/archive")
+(defparameter *archive-url-template* "{base-url}/{name}/archive")
+
+(defvar *template-readtable*
+ (let ((readtable (copy-readtable)))
+ (set-syntax-from-char #\} #\) readtable)
+ readtable))
+
+(defun read-template-form (stream)
+ (let ((*readtable* *template-readtable*)
+ (*package* (symbol-package :keyword)))
+ (read-delimited-list #\} stream)))
+
+(defmacro do-character-stream ((var stream &optional result) &body body)
+ `(loop for ,var = (read-char ,stream nil)
+ while ,var do ,@body
+ finally (return ,result)))
+
+(defun render-template (template data)
+ (with-output-to-string (out)
+ (with-input-from-string (in template)
+ (do-character-stream (c in)
+ (if (not (char= c #\{))
+ (write-char c out)
+ (let ((form (read-template-form in)))
+ (princ (or (getf data (car form))
+ (error "The value of {~a} is undefined." (car form)))
+ out)))))))
+
+(defun effective-mtime (path)
+ (if (not (fad:directory-pathname-p path))
+ (file-write-date path)
+ (apply #'max 0 (mapcar #'effective-mtime (fad:list-directory path)))))
+
+(defun format-date (universal-time)
+ (let* ((time (multiple-value-list (decode-universal-time universal-time)))
+ (date (reverse (subseq time 3 6))))
+ (format nil "~{~2,'0d~}" date)))
+
+(defun external-program-word (&rest run-args)
+ (let* ((s (with-output-to-string (out)
+ (apply #'external-program:run (append run-args `(:output ,out))))))
+ (subseq s 0 (position #\Space s))))
+
+(defun md5sum (path)
+ (external-program-word "/usr/bin/md5sum" `(,(princ-to-string path))))
+
+(defun tar-content-sha1 (path)
+ (external-program-word "/bin/sh" `("-c" ,(format nil "tar xOf \"~a\" | sha1sum" path))))
+
+(defun last-directory (path)
+ (first (last (pathname-directory path))))
+
+(defun archive (destdir-path source-path)
+ (let* ((mtime (format-date (effective-mtime source-path)))
+ (name (format nil "~a-~a" (last-directory source-path) mtime))
+ (out-path (make-pathname :name name :type "tgz" :defaults (truename destdir-path))))
+ (multiple-value-list (external-program:run "/bin/tar" (list "-C" (princ-to-string source-path) "."
+ "-czf" (princ-to-string out-path)
+ "--transform" (format nil "s#^.#~a#" name))
+ :output *standard-output*
+ :error *error-output*))
+ out-path))
+
+(defun find-system-files (path)
+ (sort
+ (loop for file in (fad:list-directory path)
+ if (string= "asd" (pathname-type file)) collect file)
+ #'string< :key #'pathname-name))
+
+(defun get-systems (path)
+ (with-open-file (s path)
+ (let* ((package (make-package (symbol-name (gensym "TMPPKG"))))
+ (*package* package))
+ (unwind-protect
+ (sort
+ (loop for form = (read s nil)
+ while form
+ when (and (symbolp (car form))
+ (equalp "defsystem" (symbol-name (car form))))
+ collect (string-downcase (string (cadr form))))
+ #'string<)
+ (delete-package package)))))
+
+(defun system-dependencies (system-designator)
+ (sort
+ (let ((system (asdf:find-system system-designator)))
+ (flatten (rest (assoc 'asdf:load-op (asdf:component-depends-on 'asdf:load-op system)))))
+ 'string<))
+
+(defun unix-filename (path)
+ (format nil "~a.~a" (pathname-name path) (pathname-type path)))
+
+(defun create-dist (projects-path dist-path archive-path archive-url)
+ (with-open-file (release-index (make-pathname :name "releases" :type "txt" :defaults dist-path)
+ :direction :output :if-exists :supersede)
+ (write-line "# project url size file-md5 content-sha1 prefix [system-file1..system-fileN]" release-index)
+ (with-open-file (system-index (make-pathname :name "systems" :type "txt" :defaults dist-path)
+ :direction :output :if-exists :supersede)
+ (write-line "# project system-file system-name [dependency1..dependencyN]" system-index)
+ (dolist (project-path (fad:list-directory projects-path))
+ (when (fad:directory-pathname-p project-path)
+ (let ((system-files (find-system-files project-path)))
+ (if (not system-files)
+ (warn "No .asd files found in ~a, skipping." project-path)
+ (let* ((tgz-path (archive archive-path project-path))
+ (project-name (last-directory project-path))
+ (project-prefix (pathname-name tgz-path))
+ (project-url (format nil "~a/~a" archive-url (unix-filename tgz-path))))
+ (format *error-output* "Processing ~a...~%" project-name)
+ (format release-index "~a ~a ~a ~a ~a ~a~{ ~a~}~%"
+ project-name project-url (file-size tgz-path) (md5sum tgz-path) (tar-content-sha1 tgz-path) project-prefix
+ (mapcar #'unix-filename system-files))
+ (dolist (system-file system-files)
+ (asdf::load-sysdef (pathname-name system-file) system-file)
+ (dolist (system-name (get-systems system-file))
+ (format system-index "~a ~a ~a~{ ~a~}~%"
+ project-name (pathname-name system-file) system-name
+ (system-dependencies system-name))))))))))))
+
+(defun quickdist (&key name (version :today) base-url projects-dir dists-dir)
+ (let* ((version (if (not (eq version :today)) version (format-date (get-universal-time))))
+ (projects-path (fad:pathname-as-directory projects-dir))
+ (template-data (list :name name :version version
+ :base-url (string-right-trim "/" base-url)
+ :dists-dir (string-right-trim "/" (princ-to-string dists-dir))))
+ (distinfo-path (fad:pathname-as-file (render-template *distinfo-file-template* template-data)))
+ (dist-path (fad:pathname-as-directory (render-template *dist-dir-template* template-data)))
+ (archive-path (fad:pathname-as-directory (render-template *archive-dir-template* template-data)))
+ (archive-url (render-template *archive-url-template* template-data)))
+ (assert (fad:directory-exists-p projects-path))
+ (ensure-directories-exist dist-path :verbose t)
+ (ensure-directories-exist archive-path :verbose t)
+ (let ((distinfo (render-template *distinfo-template* template-data)))
+ (dolist (path (list distinfo-path
+ (make-pathname :name "distinfo" :type "txt" :defaults dist-path)))
+ (write-string-into-file distinfo path :if-exists :supersede)))
+ (create-dist projects-path dist-path archive-path archive-url)))
Please sign in to comment.
Something went wrong with that request. Please try again.