(module unzip mzscheme
  ;(require (planet "io.ss" ("dherman" "io.plt" 1)))
  (require "../../../io/collects/io/io.ss")
  (require (lib "list.ss" "srfi" "1"))
  (require (lib "contract.ss"))
  (require (lib "etc.ss"))
  (require (lib "inflate.ss"))
  (require (lib "port.ss"))
  (require "private/zip-constants.ss")

  ;; TODO: what kinds of errors to raise?

  ;; (zip-file a) = (listof bytes) * (bytes -> a)
  (define-struct zip-file (entries inflater))

  ;; unzip-one-entry : input-port (bytes -> output-port) -> any
  ;; unzips a single file and positions the input port at the next section
  (define (unzip-one-entry in build-out)
    (let ([read-int (lambda (count) (read-integer count #f in #f))])
      (let* ([signature            (read-int 4)]
             ;[_ (fprintf (current-error-port) "signature: 0x~x~n" signature)]
             [version              (read-bytes 2 in)]
             [bits                 (read-int 2)]
             [compression          (read-int 2)]
             [time                 (read-int 2)]
             [date                 (read-int 2)]
             [crc-32               (read-int 4)]
             [compressed           (read-int 4)]
             ;[_ (fprintf (current-error-port) "compressed: ~a~n" compressed)]
             [uncompressed         (read-int 4)]
             [filename-length      (read-int 2)]
             [extra-length         (read-int 2)]
             [filename             (read-bytes filename-length in)]
             ;[_ (fprintf (current-error-port) "filename: ~a~n" filename)]
             ;[_ (fprintf (current-error-port) "extra-length: ~a~n" extra-length)]
             [extra                (read-bytes extra-length in)])
        (let ([out (build-out filename)]
              [in0 (if (bit-set? 3 bits)
                       in
                       (make-limited-input-port in compressed #f))])
          (if (zero? compression)
              (copy-port in0 out)
              (inflate in0 out))
          (when (bit-set? 3 bits)
            ;; it seems the EXT header here is optional (weird)
            (when (bytes=? (peek-bytes 2 0 in) #"PK")
              (skip-bytes 4 in))
            (skip-bytes 12 in))))))

  ;; unzip : input-port (bytes -> output-port) -> any
  (define (unzip in build-out)
    (when (= (peek-integer 4 #f in #f) *local-file-header*)
      (unzip-one-entry in build-out)
      (unzip in build-out)))

  ;; find-central-directory : input-port -> nat nat nat
  (define (find-central-directory in size)
    (let loop ([pos (- size 18)])
      (unless (positive? pos)
        (error 'unzip in "no central directory"))
      (file-position in pos)
      (let* ([read-int (lambda (count) (read-integer count #f in #f))]
             [signature (read-int 4)])
        (if (= signature *end-of-central-directory-record*)
            (let ([disk-number       (read-int 2)]
                  [directory-disk    (read-int 2)]
                  [disk-entries      (read-int 2)]
                  [entry-count       (read-int 2)]
                  [directory-length  (read-int 4)]
                  [directory-offset  (read-int 4)]
                  [comment-length    (read-int 2)])
              (if (= (- size (file-position in)) comment-length)
                  (values directory-offset directory-length entry-count)
                  (loop (sub1 pos))))
            (loop (sub1 pos))))))

  ;; read-central-directory : input-port nat -> (listof (cons bytes nat))
  (define (read-central-directory in size)
    (let-values ([(offset length count)
                  (find-central-directory in size)])
      (file-position in offset)
      (build-list count
                  (lambda (i)
                    (let* ([read-int (lambda (count)
                                       (read-integer count #f in #f))]
                           [signature (read-int 4)])
                      (unless (= signature *central-file-header*)
                        (error
                         'unzip
                         "bad central file header signature: ~a"
                         signature))
                      (let ([version             (read-int 2)]
                            [required            (read-int 2)]
                            [bits                (read-int 2)]
                            [compression         (read-int 2)]
                            [time                (read-int 2)]
                            [date                (read-int 2)]
                            [crc-32              (read-int 4)]
                            [compressed          (read-int 4)]
                            [uncompressed        (read-int 4)]
                            [filename-length     (read-int 2)]
                            [extra-length        (read-int 2)]
                            [comment-length      (read-int 2)]
                            [disk-number         (read-int 2)]
                            [internal-attributes (read-int 2)]
                            [external-attributes (read-int 4)]
                            [relative-offset     (read-int 4)])
                        (let ([filename (read-bytes filename-length)])
                          (skip-bytes (+ extra-length comment-length) in)
                          (cons filename relative-offset))))))))

  ;; save-zip-entry : [symbol] -> (path input-port -> void)
  (define save-zip-entry
    (opt-lambda ([flag 'error])
      (lambda (file in)
        (with-output-to-file file
          (lambda ()
            (copy-port in (current-output-port)))
          flag))))

  ;; pipe-zip-entry : output-port -> (path input-port -> void)
  (define (pipe-zip-entry out)
    (lambda (file in)
      (copy-port in out)))

  ;; read-zip-file : (union string path) [(bytes input-port -> a)] -> (zip-file a)
  (define read-zip-file
    (opt-lambda (path [parse-entry save-zip-entry])
      (let ([directory (with-input-from-file path
                         (lambda ()
                           (read-central-directory (current-input-port)
                                                   (file-size path))))])
        (make-zip-file
         (map car directory)
         (lambda (entry-name)
           (cond
             [(s:assoc entry-name directory bytes=?)
              => (lambda (pair)
                   (let ([offset (cdr pair)])
                     (let-values ([(entry-in entry-out) (make-pipe)])
                       (thread
                        (lambda ()
                          (dynamic-wind
                           void
                           (lambda ()
                             (with-input-from-file path
                               (lambda ()
                                 (file-position (current-input-port) offset)
                                 (unzip-one-entry (current-input-port)
                                                  (lambda (n) entry-out)))))
                           (lambda ()
                             (close-output-port entry-out)))))
                       (parse-entry entry-name entry-in))))]
             [else
              (error 'read-zip-file "no such entry: \"~a\"" entry-name)]))))))

  ;; zip-file-inflate : (zip-file a) bytes -> a
  (define (zip-file-inflate zf entry)
    ((zip-file-inflater zf) entry))

  (provide/contract
   [zip-file? (any/c . -> . boolean?)]
   [zip-file-entries (zip-file? . -> . (listof bytes?))]
   [zip-file-inflate (zip-file? bytes? . -> . any/c)])

  (provide/contract
   [unzip (input-port? (bytes? . -> . output-port?) . -> . any/c)]
   [read-zip-file (((union string? path?))
                   ((bytes? input-port? . -> . any/c))
                   . opt-> .
                   zip-file?)]
   [save-zip-entry (() (symbol?) . opt-> . (bytes? input-port? . -> . any/c))]
   [pipe-zip-entry (output-port? . -> . (bytes? input-port? . -> . any/c))]))