;;; Gash --- Guile As SHell
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; The initial ustar.scm was taken from the Guile100 challenge
;;; https://github.com/spk121/guile100 from a contribution by Mark H
;;; Weaver.

;;; Code:

(define-module (gash ustar)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:use-module (ice-9 receive)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (gash shell-utils)
  #:export (read-ustar-archive
            read-ustar-port
            write-ustar-archive
            write-ustar-port
            list-ustar-archive
            list-ustar-port))

(define (fmt-error fmt . args)
  (error (apply format #f fmt args)))

;; Like 'string-pad-right', but for bytevectors.  However, unlike
;; 'string-pad-right', truncation is not allowed here.
(define* (bytevector-pad
          bv len #:optional (byte 0) (start 0) (end (bytevector-length bv)))
  (when (< len (- end start))
    (fmt-error
     "bytevector-pad: truncation would occur: len ~a, start ~a, end ~a, bv ~s"
     len start end bv))
  (let ((result (make-bytevector len byte)))
    (bytevector-copy! bv start result 0 (- end start))
    result))

(define (bytevector-append . bvs)
  (let* ((lengths (map bytevector-length bvs))
         (total (fold + 0 lengths))
         (result (make-bytevector total)))
    (fold (lambda (bv len pos)
            (bytevector-copy! bv 0 result pos len)
            (+ pos len))
          0 bvs lengths)
    result))

(define ustar-charset
  #;
  (char-set-union (ucs-range->char-set #x20 #x23)
  (ucs-range->char-set #x25 #x40)
  (ucs-range->char-set #x41 #x5B)
  (ucs-range->char-set #x5F #x60)
  (ucs-range->char-set #x61 #x7B))
  char-set:ascii)

(define (valid-ustar-char? c)
  (char-set-contains? ustar-charset c))

(define (ustar-string n str name)
  (unless (>= n (string-length str))
    (fmt-error "~a is too long (max ~a): ~a" name n str))
  (unless (string-every valid-ustar-char? str)
    (fmt-error "~a contains unsupported character(s): ~s in ~s"
               name
               (string-filter (negate valid-ustar-char?) str)
               str))
  (bytevector-pad (string->bytevector str (make-transcoder (latin-1-codec))) n))

(define (ustar-0string n str name)
  (bytevector-pad (ustar-string (- n 1) str name)
                  n))

(define (ustar-number n num name)
  (unless (and (integer? num)
               (exact? num)
               (not (negative? num)))
    (fmt-error "~a is not a non-negative exact integer: ~a" name num))
  (unless (< num (expt 8 (- n 1)))
    (fmt-error "~a is too large (max ~a): ~a" name (expt 8 (- n 1)) num))
  (bytevector-pad (string->bytevector (string-pad (number->string num 8)
                                            (- n 1)
                                            #\0)
                                      (make-transcoder (latin-1-codec)))
                  n))

(define (checksum-bv bv)
  (let ((len (bytevector-length bv)))
    (let loop ((i 0) (sum 0))
      (if (= i len) sum
          (loop (+ i 1) (+ sum (bytevector-u8-ref bv i)))))))

(define (checksum . bvs)
  (fold + 0 (map checksum-bv bvs)))

(define nuls (make-bytevector 512 0))

;; read a ustar record of exactly 512 bytes.
(define (read-ustar-record port)
  (get-bytevector-n port 512))

;; write a ustar record of exactly 512 bytes, starting with the
;; segment of BV between START (inclusive) and END (exclusive), and
;; padded at the end with nuls as needed.
(define* (write-ustar-record
          port bv #:optional (start 0) (end (bytevector-length bv)))
  (when (< 512 (- end start))
    (fmt-error "write-ustar-record: record too long: start ~s, end ~s, bv ~s"
               start end bv))
  ;; We could have used 'bytevector-pad' here,
  ;; but instead use a method that avoids allocation.
  (put-bytevector port bv start end)
  (put-bytevector port nuls 0 (- 512 (- end start))))

;; write 1024 zero bytes, which indicates the end of a ustar archive.
(define (write-ustar-footer port)
  (put-bytevector port nuls)
  (put-bytevector port nuls))

(define (compose-path-name dir name)
  (if (or (string-null? dir)
          (file-name-separator? (string-ref dir (- (string-length dir) 1))))
      (string-append dir name)
      (string-append dir "/" name)))

;; Like 'call-with-port', but also closes PORT if an error occurs.
(define (call-with-port* port proc)
  (dynamic-wind
    (lambda () #f)
    (lambda () (proc port))
    (lambda () (close port))))

(define (call-with-dirstream* dirstream proc)
  (dynamic-wind
    (lambda () #f)
    (lambda () (proc dirstream))
    (lambda () (closedir dirstream))))

(define (files-in-directory dir)
  (call-with-dirstream* (opendir dir)
    (lambda (dirstream)
      (let loop ((files '()))
        (let ((name (readdir dirstream)))
          (cond ((eof-object? name)
                 (reverse files))
                ((member name '("." ".."))
                 (loop files))
                (else
                 (loop (cons (compose-path-name dir name) files)))))))))

;; split the path into prefix and name fields for purposes of the
;; ustar header.  If the entire path fits in the name field (100 chars
;; max), then leave the prefix empty.  Otherwise, try to put the last
;; component into the name field and everything else into the prefix
;; field (155 chars max).  If that fails, put as much as possible into
;; the prefix and the rest into the name field.  This follows the
;; behavior of GNU tar when creating a ustar archive.
(define (ustar-path-name-split path orig-path)
  (define (too-long)
    (fmt-error "~a: file name too long" orig-path))
  (let ((len (string-length path)))
    (cond ((<= len 100) (values "" path))
          ((> len 256) (too-long))
          ((string-rindex path
                          file-name-separator?
                          (- len 101)
                          (min (- len 1) 156))
           => (lambda (i)
                (values (substring path 0 i)
                        (substring path (+ i 1) len))))
          (else (too-long)))))

(define (bv->ustar-string bv name)
  (string-trim-right (bv->ustar-0string bv name) (compose zero? char->integer)))

(define (bv->ustar-number bv name)
  (let ((string (bv->ustar-string bv name)))
    (or (string->number string 8) 0)))

(define (bv->ustar-0string bv name)
  (bytevector->string bv (make-transcoder (latin-1-codec))))

(define-immutable-record-type <ustar-header>
  (make-ustar-header name
                     mode
                     uid
                     gid
                     size
                     mtime
                     checksum
                     ;; space
                     type-flag
                     link-name
                     magic
                     version
                     uname
                     gname
                     dev-major
                     dev-minor
                     prefix)
  ustar-header?
  (name      ustar-header-name     )
  (mode      ustar-header-mode     )
  (uid       ustar-header-uid      )
  (gid       ustar-header-gid      )
  (size      ustar-header-size     )
  (mtime     ustar-header-mtime    )
  (checksum  ustar-header-checksum )
  ;;(space     ustar-header-space    )
  (type-flag ustar-header-type-flag)
  (link-name ustar-header-link-name)
  (magic     ustar-header-magic    )
  (version   ustar-header-version  )
  (uname     ustar-header-uname    )
  (gname     ustar-header-gname    )
  (dev-major ustar-header-dev-major)
  (dev-minor ustar-header-dev-minor)
  (prefix    ustar-header-prefix   ))

(define (ustar-header-type header)
  (let ((file-types #(regular - symlink char-special block-special directory fifo))
        (type (string->number (ustar-header-type-flag header))))
    (when (or (not type)
              (< type 0)
              (>= type (vector-length file-types)))
      (fmt-error "~a: unsupported file type ~a"
                 (ustar-header-file-name header) type))
    (vector-ref file-types (string->number (ustar-header-type-flag header)))))

(define ustar-header-field-size-alist
  '((name           . 100)
    (mode           .   8)
    (uid            .   8)
    (gid            .   8)
    (size           .  12)
    (mtime          .  12)
    (checksum       .   7)
    (space          .   1)
    (type-flag      .   1)
    (link-name      . 100)
    (magic          .   6)
    (version        .   2)
    (uname          .  32)
    (gname          .  32)
    (dev-major      .   8)
    (dev-minor      .   8)
    (prefix         . 155)))

(define (ustar-footer? bv)
  (every zero? (array->list bv)))

(define (sub-bytevector bv offset size)
  (let ((sub (make-bytevector size)))
    (bytevector-copy! bv offset sub 0 size)
    sub))

(define (read-ustar-header port)
  (define offset
    (let ((offset 0))
      (lambda (. args)
        (if (null? args) offset
            (let ((n (car args)))
              (set! offset (+ offset n))
              n)))))
  (let ((%record (read-ustar-record port)))
    (and (not (eof-object? %record))
         (not (ustar-footer? %record))
         (let* ((field-bv-alist
                 `((dummy-checksum . ,(string->utf8 "        "))
                   ,@(map
                      (match-lambda ((field . size)
                                     (cons field (sub-bytevector %record (offset) (offset size)))))
                      ustar-header-field-size-alist)))
                (checksum-fields '(name mode uid gid size mtime
                                        dummy-checksum
                                        type-flag link-name magic version
                                        uname gname dev-major dev-minor
                                        prefix))
                (checksum (apply checksum (map (cut assoc-ref field-bv-alist <>)
                                               checksum-fields)))
                (header
                 (make-ustar-header
                  (bv->ustar-string (assoc-ref field-bv-alist 'name     ) "file name"        )
                  (bv->ustar-number (assoc-ref field-bv-alist 'mode     ) "file mode"        )
                  (bv->ustar-number (assoc-ref field-bv-alist 'uid      ) "user id"          )
                  (bv->ustar-number (assoc-ref field-bv-alist 'gid      ) "group id"         )
                  (bv->ustar-number (assoc-ref field-bv-alist 'size     ) "file size"        )
                  (bv->ustar-number (assoc-ref field-bv-alist 'mtime    ) "modification time")
                  (bv->ustar-number (assoc-ref field-bv-alist 'checksum ) "checksum"         )
                  ;; (bv->ustar-string (assoc-ref field-bv-alist 'space    ) "space"            )
                  (bv->ustar-string (assoc-ref field-bv-alist 'type-flag) "type flag"        )
                  (bv->ustar-string (assoc-ref field-bv-alist 'link-name) "link name"        )
                  (bv->ustar-string (assoc-ref field-bv-alist 'magic    ) "magic field"      )
                  (bv->ustar-string (assoc-ref field-bv-alist 'version  ) "version number"   )
                  (bv->ustar-string (assoc-ref field-bv-alist 'uname    ) "user name"        )
                  (bv->ustar-string (assoc-ref field-bv-alist 'gname    ) "group name"       )
                  (bv->ustar-number (assoc-ref field-bv-alist 'dev-major) "dev major"        )
                  (bv->ustar-number (assoc-ref field-bv-alist 'dev-minor) "dev minor"        )
                  (bv->ustar-string (assoc-ref field-bv-alist 'prefix   ) "directory name"   ))))
           (when (not (= (ustar-header-checksum header) checksum))
             (error "checksum mismatch, expected: ~s, got: ~s\n"
                    (ustar-header-checksum header)
                    checksum))
           header))))

(define* (write-ustar-header port path st #:key group mtime numeric-owner? owner)
  (let* ((type  (stat:type st))
         (perms  (stat:perms st))
         (mtime  (or mtime (stat:mtime st)))
         (uid    (or owner (stat:uid st)))
         (gid    (or group (stat:gid st)))
         (uname  (or (false-if-exception (passwd:name (getpwuid uid)))
                     ""))
         (gname  (or (false-if-exception (group:name (getgrgid gid)))
                     ""))

         (size  (case type
                  ((regular) (stat:size st))
                  (else 0)))

         (type-flag (case type
                      ((regular)       "0")
                      ((symlink)       "2")
                      ((char-special)  "3")
                      ((block-special) "4")
                      ((directory)     "5")
                      ((fifo)          "6")
                      (else (fmt-error "~a: unsupported file type ~a"
                                       path type))))

         (link-name (case type
                      ((symlink) (readlink path))
                      (else "")))

         (dev-major (case type
                      ((char-special block-special)
                       (quotient (stat:rdev st) 256))
                      (else 0)))
         (dev-minor (case type
                      ((char-special block-special)
                       (remainder (stat:rdev st) 256))
                      (else 0)))

         ;; Convert file name separators to slashes.
         (slash-path (string-map (lambda (c)
                                   (if (file-name-separator? c) #\/ c))
                                 path))

         ;; Make the path name relative.
         ;; TODO: handle drive letters on windows.
         (relative-path (if (string-every #\/ slash-path)
                            "."
                            (string-trim slash-path #\/)))

         ;; If it's a directory, add a trailing slash,
         ;; otherwise remove trailing slashes.
         (full-path (case type
                      ((directory) (string-append relative-path "/"))
                      (else (string-trim-right relative-path #\/)))))

    (receive (prefix name) (ustar-path-name-split full-path path)

      (let* ((%name      (ustar-string  100 name      "file name"))
             (%mode      (ustar-number    8 perms     "file mode"))
             (%uid       (ustar-number    8 uid       "user id"))
             (%gid       (ustar-number    8 gid       "group id"))
             (%size      (ustar-number   12 size      "file size"))
             (%mtime     (ustar-number   12 mtime     "modification time"))
             (%type-flag (ustar-string    1 type-flag "type flag"))
             (%link-name (ustar-string  100 link-name "link name"))
             (%magic     (ustar-0string   6 "ustar"   "magic field"))
             (%version   (ustar-string    2 "00"      "version number"))
             (%uname     (ustar-0string  32 uname     "user name"))
             (%gname     (ustar-0string  32 gname     "group name"))
             (%dev-major (ustar-number    8 dev-major "dev major"))
             (%dev-minor (ustar-number    8 dev-minor "dev minor"))
             (%prefix    (ustar-string  155 prefix    "directory name"))

             (%dummy-checksum (string->utf8 "        "))

             (%checksum
              (bytevector-append
               (ustar-number
                7
                (checksum %name %mode %uid %gid %size %mtime
                          %dummy-checksum
                          %type-flag %link-name %magic %version
                          %uname %gname %dev-major %dev-minor
                          %prefix)
                "checksum")
               (string->utf8 " "))))

        (write-ustar-record port
                            (bytevector-append
                             %name %mode %uid %gid %size %mtime
                             %checksum
                             %type-flag %link-name %magic %version
                             %uname %gname %dev-major %dev-minor
                             %prefix))))))

(define* (write-ustar-file port file-name #:key group mtime numeric-owner? owner sort-order verbosity)
  (let* ((file-name (if (string-every file-name-separator? file-name)
                        file-name-separator-string
                        (string-trim-right file-name file-name-separator?)))
         (st  (lstat file-name))
         (type (stat:type st))
         (size (stat:size st)))
    (unless (zero? verbosity)
      (if (> verbosity 1) (display-file file-name st)
          (display file-name))
      (newline))
    (write-ustar-header port file-name st #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner)
    (case type
      ((regular)
       (call-with-port* (open-file file-name "rb")
         (lambda (in)
           (let ((buf (make-bytevector 512)))
             (let loop ((left size))
               (when (positive? left)
                 (let* ((asked (min left 512))
                        (obtained (get-bytevector-n! in buf 0 asked)))
                   (when (or (eof-object? obtained)
                             (< obtained asked))
                     (fmt-error "~a: file appears to have shrunk" file-name))
                   (write-ustar-record port buf 0 obtained)
                   (loop (- left obtained)))))))))
      ((directory)
       (let* ((files (files-in-directory file-name))
              (files (if (eq? sort-order 'name) (sort files string<)
                         files)))
         (for-each (lambda (file-name) (write-ustar-file port file-name
                                                         #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity))
                   files))))))

(define* (ustar-header-file-name header #:key (strip 0))
  (let* ((name (ustar-header-name header))
         (prefix (ustar-header-prefix header))
         (file-name (if (string-null? prefix) name
                        (string-append prefix "/" name))))
    (if (zero? strip) file-name
        (string-join (list-tail (string-split file-name #\/) strip) "/"))))

(define* (read-ustar-file port header #:key (extract? #t) (strip 0))
  (let* ((size (ustar-header-size header))
         (file-name (ustar-header-file-name header #:strip strip))
         (dir (dirname file-name))
         (extract? (and extract? (not (string-null? file-name))))
         (thunk (lambda _
                  (set-port-encoding! (current-output-port) "ISO-8859-1") ; bootstrap-guile uses default UTF-8
                  (let loop ((read 0))
                    (and (< read size)
                         (let ((record (read-ustar-record port)))
                           (and record
                                (let* ((read (+ read 512))
                                       (block (if (< read size) record
                                                  (sub-bytevector record 0 (- size -512 read)))))
                                  (when extract?
                                    (display (bv->ustar-0string block "block")))
                                  (loop read)))))))))
    (when extract?
      (mkdir-p dir))
    (if extract?
        (let ((mtime (ustar-header-mtime header)))
          (case (ustar-header-type header)
            ((regular)
             (if (file-exists? file-name) (delete-file file-name))
             (with-output-to-file file-name thunk #:binary #t)
             (utime file-name mtime mtime)
             (chmod file-name (ustar-header-mode header)))
            ((directory)
             (mkdir-p file-name)
             (utime file-name mtime mtime))
            ((symlink) (symlink (ustar-header-link-name header) file-name ))))
        (thunk))))

(define (ustar-header->stat header)
  (let* ((stat-size 17)
         (si (list->vector (iota stat-size)))
         (st (make-vector stat-size 0)))
    (vector-set! st (stat:mode si) (ustar-header-mode header))
    (vector-set! st (stat:uid si) (ustar-header-uid header))
    (vector-set! st (stat:gid si) (ustar-header-gid header))
    (vector-set! st (stat:size si) (ustar-header-size header))
    (vector-set! st (stat:mtime si) (ustar-header-mtime header))
    (vector-set! st (stat:type si) (ustar-header-type header))
    st))

(define* (display-header header #:key verbose?)
  (let ((file-name (ustar-header-file-name header)))
    (if verbose? (display-file (ustar-header-file-name header) (ustar-header->stat header))
        (display file-name))
    (newline)))

(define* (write-ustar-port out files #:key group mtime numeric-owner? owner sort-order verbosity)
  (for-each
   (cut write-ustar-file out <>
        #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:sort-order sort-order #:verbosity verbosity)
   files)
  (write-ustar-footer out))

(define* (write-ustar-archive file-name files #:key group mtime numeric-owner? owner sort-order verbosity)
  (catch #t
    (lambda _
      (call-with-port* (open-file file-name "wb")
        (cut write-ustar-port <> files
             #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:sort-order sort-order #:verbosity verbosity)))
    (lambda (key subr message args . rest)
      (false-if-exception (delete-file file-name))
      (format (current-error-port) "ERROR: ~a\n"
              (apply format #f message args))
      (exit 1))))

(define* (read-ustar-port in files #:key (extract? #t) (strip 0) verbosity)
  (let ((dirs
         (let loop ((header (read-ustar-header in)) (dirs '()))
           (if (not (and header (not (eof-object? header)))) dirs
               (begin
                 (unless (zero? verbosity)
                   (display-header header #:verbose? (> verbosity 1)))
                 (read-ustar-file in header #:extract? extract? #:strip strip)
                 (loop (read-ustar-header in)
                       (if (eq? (ustar-header-type header) 'directory) (cons header dirs)
                           dirs)))))))
    (define (chmod-header header)
      (chmod (ustar-header-file-name header #:strip strip)
             (ustar-header-mode header)))
    (for-each chmod-header dirs)))

(define* (read-ustar-archive file-name files #:key (extract? #t) (strip 0) verbosity)
  (catch #t
    (lambda _
      (call-with-port* (open-file file-name "rb")
        (cut read-ustar-port <> files #:extract? extract? #:strip strip #:verbosity verbosity)))
    (lambda (key subr message args . rest)
      (format (current-error-port) "ERROR: ~a\n"
              (apply format #f message args))
      (exit 1))))

(define* (list-ustar-archive file-name files #:key (strip 0) verbosity)
  (read-ustar-archive file-name files #:extract? #f #:strip strip #:verbosity verbosity))

(define* (list-ustar-port in files #:key (strip 0) verbosity)
  (read-ustar-port in files #:extract? #f #:strip strip #:verbosity verbosity))

;;; Local Variables:
;;; mode: scheme
;;; eval: (put 'call-with-port* 'scheme-indent-function 1)
;;; eval: (put 'call-with-dirstream* 'scheme-indent-function 1)
;;; End: