150 lines
4.1 KiB
Racket
150 lines
4.1 KiB
Racket
#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"))))
|