Initial import

main.rkt

@@ -0,0 +1,149 @@
+#lang racket/base
+
+(require file/zip
+         racket/file
+         racket/list
+         racket/path
+         racket/string
+         setup/getinfo)
+
+(provide zip-package)
+
+(define scribble-directory-names
+  '("scribblings" "scribbles" "scrbl"))
+
+(define scribble-generated-extensions
+  '(".html" ".js" ".css"))
+
+(define (path-component-strings path)
+  (for/list ([part (in-list (explode-path path))]
+             #:when (path? part))
+    (string-downcase (path-element->string part))))
+
+(define (string-in? value strings)
+  (for/or ([candidate (in-list strings)])
+    (string=? value candidate)))
+
+(define (excluded-path? path)
+  (define components (path-component-strings path))
+  (define name
+    (if (null? components)
+        ""
+        (last components)))
+  (define extension
+    (let ([ext (path-get-extension path)])
+      (and ext
+           (string-downcase
+            (bytes->string/utf-8 ext)))))
+
+  (or
+   ;; Git administration directory or file.
+   (string-in? ".git" components)
+
+   ;; Common editor and manual backup files.
+   (string-suffix? name "~")
+   (string-suffix? name ".bak")
+
+   ;; Generated Scribble web output.
+   (and extension
+        (for/or ([component (in-list components)])
+          (string-in? component scribble-directory-names))
+        (string-in? extension scribble-generated-extensions))))
+
+(define (package-paths source-directory)
+  (parameterize ([current-directory source-directory])
+    (find-files (lambda (path)
+                  (not (excluded-path? path)))
+                #f
+                #:skip-filtered-directory? #t
+                #:follow-links? #f)))
+
+(define (directory-name+parent directory)
+  (define-values (parent name _must-be-directory?)
+    (split-path (path->directory-path directory)))
+
+  (unless (and (path? parent) (path? name))
+    (raise-arguments-error
+     'zip-package
+     "cannot determine a package name and parent directory"
+     "directory" directory))
+
+  (values (path-element->string name) parent))
+
+(define (package-version source-directory)
+  (define get-info (get-info/full source-directory))
+
+  (unless get-info
+    (raise-arguments-error
+     'zip-package
+     "the package directory has no info.rkt"
+     "directory" source-directory))
+
+  (define version
+    (get-info 'version (lambda () #f)))
+
+  (unless (and (string? version)
+               (not (string=? version "")))
+    (raise-arguments-error
+     'zip-package
+     "info.rkt has no non-empty string value for version"
+     "directory" source-directory
+     "version" version))
+
+  version)
+
+(define (zip-package [directory (current-directory)])
+  (define source-directory
+    (simplify-path
+     (path->complete-path directory)
+     #t))
+
+  (unless (directory-exists? source-directory)
+    (raise-argument-error
+     'zip-package
+     "directory-exists?"
+     directory))
+
+  (define-values (package-name parent-directory)
+    (directory-name+parent source-directory))
+  (define version
+    (package-version source-directory))
+  (define output-path
+    (build-path parent-directory
+                (format "~a-~a.zip"
+                        package-name
+                        version)))
+  (define paths
+    (package-paths source-directory))
+
+  (when (file-exists? output-path)
+    (delete-file output-path))
+
+  (parameterize ([current-directory source-directory])
+    (call-with-output-file output-path
+      (lambda (out)
+        ;; Keep package files at the archive root, as expected for a
+        ;; directly installable Racket package archive.
+        (zip->output paths out))
+      #:mode 'binary))
+
+  (printf "Created ~a\n" (path->string output-path))
+  output-path)
+
+(module+ test
+  (require rackunit)
+
+  (check-true
+   (excluded-path? (string->path ".git/config")))
+  (check-true
+   (excluded-path? (string->path "private/source.rkt~")))
+  (check-true
+   (excluded-path? (string->path "private/source.BAK")))
+  (check-true
+   (excluded-path? (string->path "scribblings/index.html")))
+  (check-true
+   (excluded-path? (string->path "scribbles/manual.JS")))
+  (check-false
+   (excluded-path? (string->path "web/index.html")))
+  (check-false
+   (excluded-path? (string->path "scribblings/package.scrbl"))))