#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"))))