package-zipper/main.rkt

#lang racket/base

(require file/zip
         racket/file
         racket/list
         racket/path
         racket/string
         setup/getinfo)

(provide zip-package)

(define excluded-directory-names
  '(".git" "compiled"))

(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))
    (path-element->string part)))

(define (string-in? value strings)
  (for/or ([candidate (in-list strings)])
    (string=? value candidate)))

(define (path-prefix? prefix components)
  (and (<= (length prefix) (length components))
       (equal? prefix (take components (length prefix)))))

(define (relative-path-string components)
  (string-join components "/"))

(define (regexp-matches? rx value)
  (if (byte-regexp? rx)
      (regexp-match? rx (string->bytes/utf-8 value))
      (regexp-match? rx value)))

(define (custom-excluded-path? path exclude)
  (define components (path-component-strings path))
  (define path-string (relative-path-string components))

  (for/or ([entry (in-list exclude)])
    (cond
      ;; A string matches a file or directory name anywhere in the path.
      [(string? entry)
       (string-in? entry components)]

      ;; A path matches that relative path and everything below it.
      [(path? entry)
       (path-prefix?
        (path-component-strings (simplify-path entry #f))
        components)]

      ;; A regexp is applied to a platform-independent relative path.
      [else
       (regexp-matches? entry path-string)])))

(define (excluded-path? path exclude)
  (define components (path-component-strings path))
  (define lower-components
    (map string-downcase components))
  (define name
    (if (null? lower-components)
        ""
        (last lower-components)))
  (define extension
    (let ([ext (path-get-extension path)])
      (and ext
           (string-downcase
            (bytes->string/utf-8 ext)))))

  (or
   ;; Git administration and generated Racket bytecode directories.
   (for/or ([component (in-list lower-components)])
     (string-in? component excluded-directory-names))

   ;; Common editor and manual backup files.
   (string-suffix? name "~")
   (string-suffix? name ".bak")

   ;; Generated Scribble web output.
   (and extension
        (for/or ([component (in-list lower-components)])
          (string-in? component scribble-directory-names))
        (string-in? extension scribble-generated-extensions))

   ;; Additional exclusions supplied by the caller.
   (custom-excluded-path? path exclude)))

(define (validate-exclude exclude)
  (unless (list? exclude)
    (raise-argument-error
     'zip-package
     "list?"
     exclude))

  (for ([entry (in-list exclude)])
    (unless (or (string? entry)
                (path? entry)
                (regexp? entry)
                (byte-regexp? entry))
      (raise-arguments-error
       'zip-package
       "an exclude entry is not a string, path, or regular expression"
       "entry" entry
       "exclude" exclude))

    (when (path? entry)
      (define simplified-entry
        (simplify-path entry #f))
      (define parts
        (explode-path simplified-entry))

      (when (or (complete-path? simplified-entry)
                (null? (path-component-strings simplified-entry))
                (for/or ([part (in-list parts)])
                  (not (path? part))))
        (raise-arguments-error
         'zip-package
         "an exclude path must be a non-empty relative subpath without '..'"
         "entry" entry
         "exclude" exclude))))

  exclude)

(define (package-paths source-directory exclude)
  (parameterize ([current-directory source-directory])
    (find-files (lambda (path)
                  (not (excluded-path? path exclude)))
                #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)]
                     #:exclude [exclude null])
  (define source-directory
    (simplify-path
     (path->complete-path directory)
     #t))
  (define checked-exclude
    (validate-exclude exclude))

  (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 checked-exclude))

  (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)

  (define no-custom-exclude null)

  (check-true
   (excluded-path? (string->path ".git/config") no-custom-exclude))
  (check-true
   (excluded-path? (string->path "compiled/main_rkt.zo") no-custom-exclude))
  (check-true
   (excluded-path? (string->path "private/compiled/helper_rkt.zo")
                   no-custom-exclude))
  (check-true
   (excluded-path? (string->path "private/source.rkt~") no-custom-exclude))
  (check-true
   (excluded-path? (string->path "private/source.BAK") no-custom-exclude))
  (check-true
   (excluded-path? (string->path "scribblings/index.html") no-custom-exclude))
  (check-true
   (excluded-path? (string->path "scribbles/manual.JS") no-custom-exclude))
  (check-false
   (excluded-path? (string->path "web/index.html") no-custom-exclude))
  (check-false
   (excluded-path? (string->path "scribblings/package.scrbl")
                   no-custom-exclude))

  (check-true
   (excluded-path? (string->path "private/generated/result.txt")
                   '("generated")))
  (check-false
   (excluded-path? (string->path "private/generated-result.txt")
                   '("generated")))
  (check-true
   (excluded-path? (string->path "examples/generated/result.txt")
                   (list (string->path "examples/generated"))))
  (check-false
   (excluded-path? (string->path "private/generated/result.txt")
                   (list (string->path "examples/generated"))))
  (check-true
   (excluded-path? (string->path "tests/data/example.json")
                   (list #rx"^tests/data/")))
  (check-false
   (excluded-path? (string->path "tests/example.json")
                   (list #rx"^tests/data/"))))