file/[un]tar: add support for [un]packing without using the filesystem

Closes #2549

pkgs/racket-doc/file/scribblings/tar.scrbl

@@ -15,7 +15,7 @@ Symbolic links (on Unix and Mac OS) are not followed by default.}
 
 
 @defproc[(tar [tar-file path-string?]
-              [path path-string?] ...
+              [path-or-entry (or/c path-string? tar-entry?)] ...
               [#:follow-links? follow-links? any/c #f]
               [#:exists-ok? exists-ok? any/c #f]
               [#:format format (or/c 'pax 'gnu 'ustar) 'pax]
@@ -30,10 +30,15 @@ Symbolic links (on Unix and Mac OS) are not followed by default.}
          exact-nonnegative-integer?]{
 
 Creates @racket[tar-file], which holds the complete content of all
-@racket[path]s.  The given @racket[path]s are all expected to be
+@racket[path-or-entry]s. Each @racket[path-or-entry] is either a path
+that refers to a file, directory, or link on the filesystem, or it is
+a @racket[tar-entry] that describes such an entity without requiring
+it to exist on the filesystem.
+
+The given paths among @racket[path-or-entry]s are all expected to be
 relative paths for existing directories and files (i.e., relative
-to the current directory).  If a nested path is provided as a
+to the current directory for a @racket[path-or-entry] is a path).  If a nested path is provided in a
-@racket[path], its ancestor directories are also added to the
+@racket[path-or-entry], its ancestor directories are also added to the
 resulting tar file, up to the current directory (using
 @racket[pathlist-closure]). If @racket[follow-links?] is false, then
 symbolic links are included in the resulting tar file as links.
@@ -62,10 +67,11 @@ date to record in the archive for each file or directory.
          #:changed "6.7.0.4" @elem{Added the @racket[#:format] argument and
                                    effectively changed its default from @racket['ustar]
                                    to @racket['pax].}
-         #:changed "7.3.0.3" @elem{Added the @racket[#:timestamp] argument.}]}
+         #:changed "7.3.0.3" @elem{Added the @racket[#:timestamp] argument.}
+         #:changed "8.1.0.5" @elem{Added support for @racket[tar-entry] arguments.}]}
 
 
-@defproc[(tar->output [paths (listof path?)]
+@defproc[(tar->output [paths-and-entries (listof (or/c path? tar-entry?))]
                       [out output-port? (current-output-port)]
                       [#:follow-links? follow-links? any/c #f]
                       [#:format format (or/c 'pax 'gnu 'ustar) 'pax]
@@ -79,9 +85,9 @@ date to record in the archive for each file or directory.
                                            file-or-directory-modify-seconds)])
          exact-nonnegative-integer?]{
 
-Like @racket[tar], but packages each of the given @racket[paths] in a @exec{tar} format
+Like @racket[tar], but packages each element of the given @racket[paths-and-entries] in a @exec{tar} format
 archive that is written directly to the @racket[out].  The specified
-@racket[paths] are included as-is (except for adding @racket[path-prefix], if any); if a directory is specified, its
+@racket[paths-and-entries] are included as-is (except for adding @racket[path-prefix], if any); if a directory is specified, its
 content is not automatically added, and nested directories are added
 without parent directories.
 
@@ -91,11 +97,12 @@ without parent directories.
          #:changed "6.7.0.4" @elem{Added the @racket[#:format] argument and
                                    effectively changed its default from @racket['ustar]
                                    to @racket['pax].}
-         #:changed "7.3.0.3" @elem{Added the @racket[#:timestamp] argument.}]}
+         #:changed "7.3.0.3" @elem{Added the @racket[#:timestamp] argument.}
+         #:changed "8.1.0.5" @elem{Added support for @racket[tar-entry] arguments.}]}
 
 
 @defproc[(tar-gzip [tar-file path-string?]
-                   [paths path-string?] ...
+                   [paths-and-entries (and/c path-string? tar-entry?)] ...
                    [#:follow-links? follow-links? any/c #f]
                    [#:exists-ok? exists-ok? any/c #f]
                    [#:format format (or/c 'pax 'gnu 'ustar) 'pax]
@@ -116,4 +123,53 @@ Like @racket[tar], but compresses the resulting file with @racket[gzip].
          #:changed "6.7.0.4" @elem{Added the @racket[#:format] argument and
                                    effectively changed its default from @racket['ustar]
                                    to @racket['pax].}
-         #:changed "7.3.0.3" @elem{Added the @racket[#:timestamp] argument.}]}
+         #:changed "7.3.0.3" @elem{Added the @racket[#:timestamp] argument.}
+         #:changed "8.1.0.5" @elem{Added support for @racket[tar-entry] arguments.}]}
+
+
+@defstruct[tar-entry ([kind (or/c 'file 'directory 'link)]
+                      [path (and/c path-string? relative-path?)]
+                      [content (or/c input-port? (-> input-port?) #f path-string?)]
+                      [size exact-nonnegative-integer?]
+                      [attribs (hash/c symbol? any/c)])]{
+
+Represents a file, directory, or link to be included in a USTAR file
+or stream.
+
+If @racket[kind] is @racket['file], then @racket[content] must be an
+input port or a thunk that produces an input port, and it must provide
+exactly @racket[size] bytes. If @racket[kind] is @racket['directory],
+then @racket[content] and @racket[size] are expected to be @racket[#f]
+and @racket[0]. If @racket[kind] is @racket['link], then
+@racket[content] must be a path, and @racket[size] is expected to be
+@racket[0].
+
+The @racket[attribs] field contains a hash table providing additional
+properties of the entry. The following keys are currently used when
+writing a USTAR file or stream:
+
+       @itemlist[
+
+        @item{@racket['permissions] --- an integer representing read,
+              write, and execute permissions in the form accepted by
+              @racket[file-or-directory-permissions].}
+
+        @item{@racket['modify-seconds] --- an integer representing a
+              modification time, which is consistent with
+              @racket[file-or-directory-modify-seconds].}
+
+        @item{@racket['owner] --- an exact integer presenting a file
+             owner ID.}
+
+        @item{@racket['owner-bytes] --- a byte string representing a
+             file owner name.}
+
+        @item{@racket['group] --- an exact integer presenting a file
+             group ID.}
+
+        @item{@racket['group-bytes] --- a byte string representing a
+             file group name.}
+
+       ]
+
+@history[#:added "8.1.0.5"]}

pkgs/racket-doc/file/scribblings/untar.scrbl

@@ -1,5 +1,6 @@
 #lang scribble/doc
-@(require "common.rkt" (for-label file/untar))
+@(require "common.rkt" (for-label file/untar
+                                  (only-in file/tar tar-entry)))
 
 @title[#:tag "untar"]{@exec{tar} File Extraction}
 
@@ -17,7 +18,15 @@ pax extensions to support long pathnames.}
                                      exact-nonnegative-integer?
                                      exact-nonnegative-integer?
                                      . -> . any/c)
-                                    (lambda args #t)])
+                                    (lambda args #t)]
+                          [#:handle-entry handle-entry
+                                          ((or/c 'file 'directory 'link)
+                                           (and path? relative-path?)
+                                           (or/c input-port? #f path?)
+                                           exact-nonnegative-integer?
+                                           (hash/c symbol? any/c)
+                                           . -> . (listof (-> any)))
+                                          handle-tar-entry])
          void?]{
 
 Extracts TAR/USTAR content from @racket[in], recognizing
@@ -72,7 +81,58 @@ For each item in the archive, @racket[filter-proc] is applied to
 If the result of @racket[filter-proc] is @racket[#f], then the item is
 not unpacked.
 
+The @racket[handle-entry] function is called to unpack one entry, and
+the default @racket[handle-tar-entry] function for
+@racket[handle-entry] creates a directory, file, or link on the
+filesystem. The @racket[handle-entry] function must accept five
+arguments:
+@;
+@itemlist[
+
+ @item{@racket[_kind] --- one of @racket['file], @racket['directory],
+       or @racket['link].}
+
+ @item{@racket[_path] --- the relative path recorded in the TAR file.}
+
+ @item{@racket[_content] --- an input port that provides the content
+       for a @racket['file] entry, where exactly @racket[_size] bytes
+       must be read from the port before @racket[handle-entry]
+       returns. For a @racket['directory] entry, @racket[_content] is
+       @racket[#f]. For a @racket['link] entry, @racket[_content] is
+       a path for the link target.}
+
+ @item{@racket[_size] --- the number of bytes for a @racket['file]
+       entry, and @racket[0] for other entries.}
+
+ @item{@racket[_attribs] --- an immutable hash table mapping symbols
+       to attribute values. The available keys may change, but the
+       currently included keys are the same ones as recognized in
+       @racket[tar-entry].}
+
+]
+
+The result of @racket[handle-entry] is a list of thunks that are
+called in order after the TAR input is fully unpacked. A result thunk
+from @racket[handle-entry] is useful, for example, to set a
+directory's modification time after all files have been written to it.
+
 @history[#:changed "6.3" @elem{Added the @racket[#:permissive?] argument.}
          #:changed "6.7.0.4" @elem{Support long paths and long symbolic-link
                                    targets using POSIX.1-2001/pax and GNU
-                                   extensions.}]}
+                                   extensions.}
+         #:changed "8.1.0.5" @elem{Added the @racket[#:handle-entry] argument.}]}
+
+
+@defproc[(handle-tar-entry [kind (or/c 'file 'directory 'link)]
+                           [path (and path? relative-path?)]
+                           [content (or/c input-port? #f path?)]
+                           [size exact-nonnegative-integer?]
+                           [attribs (hash/c symbol? any/c)])
+         (listof (-> any))]{
+
+As the default entry handler for @racket[untar],
+@racket[handle-tar-entry] creates directories and files and returns a
+list of thunks that complete unpacking by setting directory
+permissions and modification times.
+
+@history[#:added "8.1.0.5"]}

pkgs/racket-test/tests/file/tar-long-paths.rkt

@@ -93,10 +93,14 @@
        "four")
 
 (unless (eq? 'windows (system-type))
+  (define (sanitize bstr)
+    (if (eq? 'macosx (system-type)) ; paths are always UTF-8 encodings
+        (string->bytes/utf-8 (bytes->string/utf-8 bstr #\?))
+        bstr))
   (check "encoding"
-         (bytes->path #"one\xF0")
+         (bytes->path (sanitize #"one\xF0"))
          "two\u3BB"
-         (bytes->path (bytes-append #"sub/three\xF1-" (make-bytes 93 (char->integer #\x))))
+         (bytes->path (bytes-append (sanitize #"sub/three\xF1-") (make-bytes 93 (char->integer #\x))))
          (string-append "sub/four\u3BB-" (make-string 93 #\x)))
   
   (check "long link"

pkgs/racket-test/tests/file/unpackers.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
 (require file/untar file/untgz file/unzip racket/file racket/system racket/set
+         (except-in file/tar tar)
          tests/eli-tester)
 
 (provide tests)
@@ -70,6 +71,24 @@
                  (begin (file-or-directory-permissions* dest "rwx") #t))))]
     [else #t]))
 
+(define (tar->entries a.tar)
+  (define got '())
+  (untar a.tar
+         #:handle-entry (lambda (kind path content len attribs)
+                          (set! got
+                                (cons (tar-entry kind
+                                                 path
+                                                 (if (input-port? content)
+                                                     (let ([bstr (read-bytes len content)])
+                                                       (lambda ()
+                                                         (open-input-bytes bstr)))
+                                                     content)
+                                                 len
+                                                 attribs)
+                                      got))
+                          null))
+  (reverse got))
+  
 (define (untar-tests*)
   (make-directory* "ex1")
   (make-file (build-path "ex1" "f1") (- (current-seconds) 12) "rw")
@@ -80,6 +99,35 @@
   (make-file (build-path more-dir "f4") (current-seconds) "rw")
   (file-or-directory-permissions* more-dir "rx") ; not "w"
   (tar "ex1" a.tar)
+  (let ([got1 (tar->entries a.tar)])
+    (define (check-find path)
+      (unless (for/or ([e (in-list got1)])
+                (equal? path (tar-entry-path e)))
+        (error "missing in entries" path)))
+    (check-find (build-path "ex1" "f1"))
+    (check-find (build-path "ex1" "f2"))
+    (check-find (build-path "ex1" "f3"))
+    (check-find (build-path "ex1" "f4"))
+    (check-find (build-path "ex1" "more" "f4"))
+    (define-values (i o) (make-pipe))
+    (tar->output got1 o)
+    (close-output-port o)
+    (let ([got2 (tar->entries i)])
+      (unless (= (length got1) (length got2))
+        (error "entries lists not the same length"))
+      (define (check what same?)
+        (unless same?
+          (error "entries differ at" what)))
+      (for ([e1 (in-list got1)]
+            [e2 (in-list got2)])
+        (check 'kind (eq? (tar-entry-kind e1)
+                          (tar-entry-kind e2)))
+        (check 'path (equal? (tar-entry-path e1)
+                             (tar-entry-path e2)))
+        (check 'len (equal? (tar-entry-size e1)
+                            (tar-entry-size e2)))
+        (check 'attribs (equal? (tar-entry-attribs e1)
+                                (tar-entry-attribs e2))))))
   (make-directory* "sub")
   (parameterize ([current-directory "sub"]) (untar a.tar))
   (test (diff "ex1" (build-path "sub" "ex1") #t))

racket/collects/file/tar.rkt

@@ -46,10 +46,22 @@
 
 (define 0-byte (char->integer #\0))
 
-(define ((tar-one-entry buf prefix get-timestamp follow-links? format) path)
+(provide (struct-out tar-entry))
-  (let* ([link?   (and (not follow-links?) (link-exists? path))]
+(struct tar-entry (kind path content size attribs))
-         [dir?    (and (not link?) (directory-exists? path))]
+
-         [size    (if (or dir? link?) 0 (file-size path))]
+(define ((tar-one-entry buf prefix get-timestamp follow-links? format) path-or-entry)
+  (define entry (and (tar-entry? path-or-entry) path-or-entry))
+  (define path (if entry (tar-entry-path entry) path-or-entry))
+  (let* ([link?   (if entry
+                      (eq? 'link (tar-entry-kind entry))
+                      (and (not follow-links?) (link-exists? path)))]
+         [dir?    (if entry
+                      (eq? 'directory (tar-entry-kind entry))
+                      (and (not link?) (directory-exists? path)))]
+         [size    (if (or dir? link?) 0 (if entry
+                                            (tar-entry-size entry)
+                                            (file-size path)))]
+         [attribs (and entry (tar-entry-attribs entry))]
          [p       0] ; write pointer
          [cksum   0]
          [cksum-p #f])
@@ -88,26 +100,37 @@
       (unless (zero? (modulo len tar-block-size))
         (write-bytes buf (current-output-port) (modulo len tar-block-size))))
     (define attrib-path
-      (if link?
+      (and (not entry)
-          ;; For a link, use attributes of the containing directory:
+           (if link?
-          (let-values ([(base name dir?) (split-path path)])
+               ;; For a link, use attributes of the containing directory:
-            (or (and (path? base)
+               (let-values ([(base name dir?) (split-path path)])
-                     base)
+                 (or (and (path? base)
-                (current-directory)))
+                          base)
-          path))
+                     (current-directory)))
+               path)))
     (define link-path-bytes (and link?
-                                 (path->bytes (resolve-path path))))
+                                 (if entry
+                                     (path->bytes (tar-entry-content entry))
+                                     (path->bytes (resolve-path path)))))
     ;; see http://www.mkssoftware.com/docs/man4/tar.4.asp for format spec
     (define (write-a-block file-name-bytes file-prefix size type link-path-bytes)
       (set! p 0)
       (set! cksum 0)
       (set! cksum-p #f)
       (write-block tar-name-length file-name-bytes)
-      (write-octal   8 (path-attributes attrib-path dir?))
+      (write-octal   8 (if attribs
-      (write-octal   8 0)          ; always root (uid)
+                           (hash-ref attribs 'permissions #o644)
-      (write-octal   8 0)          ; always root (gid)
+                           (path-attributes attrib-path dir?)))
+      (write-octal   8 (if attribs
+                           (hash-ref attribs 'owner 0)
+                           0))
+      (write-octal   8 (if attribs
+                           (hash-ref attribs 'group 0)
+                           0))
       (write-octal  12 size)
-      (write-octal  12 (get-timestamp attrib-path))
+      (write-octal  12 (if attribs
+                           (hash-ref attribs 'modify-seconds 0)
+                           (get-timestamp attrib-path)))
       ;; set checksum later, consider it "all blanks" for cksum
       (set! cksum-p p) (set! cksum (+ cksum (* 8 32))) (advance 8)
       (write-block*  1 type) ; type-flag
@@ -118,8 +141,12 @@
           (advance tar-link-name-length))        ; no link-name
       (write-block   6 #"ustar")   ; magic
       (write-block*  2 #"00")      ; version
-      (write-block  32 #"root")    ; always root (user-name)
+      (write-block  32 (if attribs
-      (write-block  32 #"root")    ; always root (group-name)
+                           (hash-ref attribs 'owner-bytes #"root")
+                           #"root"))
+      (write-block  32 (if attribs
+                           (hash-ref attribs 'group-bytes #"root")
+                           #"root"))
       (write-octal   8 0)          ; device-major
       (write-octal   8 0)          ; device-minor
       (write-block tar-prefix-length file-prefix)
@@ -175,23 +202,29 @@
     (if (or dir? link?)
       (zero-block! buf) ; must clean buffer for re-use
       ;; write the file
-      (with-input-from-file path
+      (let ([copy
-        (lambda ()
+             (lambda (in)
-          (let loop ([n size])
+               (let loop ([n size])
-            (let ([l (read-bytes! buf)])
+                 (let ([l (read-bytes! buf in)])
-              (cond
+                   (cond
-                [(eq? l tar-block-size) (write-bytes buf) (loop (- n l))]
+                     [(eq? l tar-block-size) (write-bytes buf) (loop (- n l))]
-                [(number? l) ; shouldn't happen
+                     [(number? l) ; shouldn't happen
-                 (write-bytes buf (current-output-port) 0 l) (loop (- n l))]
+                      (write-bytes buf (current-output-port) 0 l) (loop (- n l))]
-                [(not (eq? eof l)) (error 'tar "internal error")]
+                     [(not (eq? eof l)) (error 'tar "internal error")]
-                [(not (zero? n))
+                     [(not (zero? n))
-                 (error 'tar "file changed while packing: ~e" path)]
+                      (error 'tar "file changed while packing: ~e" path)]
-                [else (zero-block! buf) ; must clean buffer for re-use
+                     [else (zero-block! buf) ; must clean buffer for re-use
-                      (let ([l (modulo size tar-block-size)])
+                           (let ([l (modulo size tar-block-size)])
-                        (unless (zero? l)
+                             (unless (zero? l)
-                          ;; complete block (buf is now zeroed)
+                               ;; complete block (buf is now zeroed)
-                          (write-bytes buf (current-output-port)
+                               (write-bytes buf (current-output-port)
-                                       0 (- tar-block-size l))))]))))))))
+                                            0 (- tar-block-size l))))]))))])
+        (if entry
+            (let ([content (tar-entry-content entry)])
+              (if (input-port? content)
+                  (copy content)
+                  (copy (content))))
+            (call-with-input-file* path copy))))))
 
 ;; tar-write : (listof relative-path) ->
 ;; writes a tar file to current-output-port

racket/collects/file/untar.rkt

@@ -15,8 +15,18 @@
                #:filter (path? (or/c path? #f)
                                symbol? exact-integer? (or/c path? #f)
                                exact-nonnegative-integer? exact-nonnegative-integer?
-                               . -> . any/c))
+                               . -> . any/c)
-              void?)]))
+               #:handle-entry ((or/c 'file 'directory 'link)
+                               (and path? relative-path?)
+                               (or/c input-port? #f path?) exact-nonnegative-integer?
+                               (hash/c symbol? any/c)
+                               . -> . (listof (procedure-arity-includes/c 0))))
+              void?)]
+  [handle-tar-entry ((or/c 'file 'directory 'link)
+                     (and path? relative-path?)
+                     (or/c input-port? #f path?) exact-nonnegative-integer?
+                     (hash/c symbol? any/c)
+                     . -> . (listof (procedure-arity-includes/c 0)))]))
 
 (define-logger untar)
 
@@ -24,7 +34,8 @@
                #:dest [dest #f]
                #:strip-count [strip-count 0]
                #:permissive? [permissive? #f]
-               #:filter [filter void])
+               #:filter [filter void]
+               #:handle-entry [handle-entry handle-tar-entry])
   ((if (input-port? in)
        (lambda (in f) (f in))
        call-with-input-file*)
@@ -35,7 +46,7 @@
        (if (for/and ([b (in-bytes bstr)]) (zero? b))
            (for ([delay (in-list (reverse delays))])
              (delay))
-           (loop (untar-one-from-port in delays
+           (loop (untar-one-from-port in handle-entry delays
                                       dest strip-count filter
                                       permissive?
                                       #f
@@ -48,7 +59,14 @@
     (error 'untar "unexpected EOF"))
   s)
 
-(define (untar-one-from-port in delays
+(define (trim-terminator bstr)
+  (let loop ([i 0])
+    (cond
+      [(= i (bytes-length bstr)) bstr]
+      [(zero? (bytes-ref bstr i)) (subbytes bstr 0 i)]
+      [else (loop (add1 i))])))
+
+(define (untar-one-from-port in handle-entry delays
                              dest strip-count filter
                              permissive?
                              path-from-extended-attributes
@@ -77,8 +95,8 @@
                  [else 'unknown]))
   (define link-target-bytes (read-bytes* 100 in))
   (define ustar? (bytes=? #"ustar\00000" (read-bytes* 8 in)))
-  (define owner-bytes (read-bytes* 32 in))
+  (define owner-bytes (trim-terminator (read-bytes* 32 in)))
-  (define group-bytes (read-bytes* 32 in))
+  (define group-bytes (trim-terminator (read-bytes* 32 in)))
   (define device-major-bytes (read-bytes* 8 in))
   (define device-minor-bytes (read-bytes* 8 in))
   (define filename-prefix-bytes (read-bytes* 155 in))
@@ -106,52 +124,44 @@
   (define create?
     (filter base-filename filename type size link-target mod-time mode))
   (define total-len (* (ceiling (/ size 512)) 512))
+  (define attribs (hasheq 'permissions mode
+                          'modify-seconds mod-time
+                          'owner owner
+                          'group group
+                          'owner-bytes owner-bytes
+                          'group-bytes group-bytes))
+  (define (accum delays new-delays) (append (reverse new-delays) delays))
   (cond
    [(and filename create?)
     (case type
       [(dir)
        (log-untar-info "directory: ~a" filename)
-       (make-directory* filename)
+       (accum delays
-       (cons
+              (handle-entry 'directory
-        ;; delay directory meta-data updates until after any contained
+                            filename
-        ;; files are written
+                            #f 0
-        (lambda ()
+                            attribs))]
-          (try-file-op
-           (lambda ()
-             (file-or-directory-permissions* filename mode #t)))
-          (try-file-op
-           (lambda ()
-             (file-or-directory-modify-seconds* filename mod-time #t))))
-        delays)]
       [(file)
        (log-untar-info "file: ~a" filename)
-       (define-values (base name dir?) (split-path filename))
+       (begin0
-       (when (path? base) (make-directory* base))
+         (accum delays
-       (call-with-output-file*
+                (handle-entry 'file
-        filename
+                              filename
-        #:exists 'truncate
+                              in size ; expect `size` bytes read from `in`
-        (lambda (out)
+                              attribs))
-          (copy-bytes size in out)))
+         (copy-bytes (- total-len size) in #f))]
-       (try-file-op
-        (lambda ()
-          (file-or-directory-permissions* filename mode #f)))
-       (try-file-op
-        (lambda ()
-          (file-or-directory-modify-seconds* filename mod-time #f)))
-       (copy-bytes (- total-len size) in #f)
-       delays]
       [(link)
        (log-untar-info "link: ~a" filename)
-       (define-values (base name dir?) (split-path filename))
+       (accum delays
-       (when (path? base) (make-directory* base))
+              (handle-entry 'link
-       (when (file-exists? filename) (delete-file filename))
+                            filename
-       (make-file-or-directory-link link-target filename)
+                            link-target 0
-       delays]
+                            attribs))]
       [(extended-header-for-next)
        ;; pax record to support long namesand other attributes
        (define extended-header (read-pax in total-len))
        ;; Recur to use given paths, if any:
-       (untar-one-from-port in delays
+       (untar-one-from-port in handle-entry delays
                             dest strip-count filter
                             permissive?
                             (or (let ([v (hash-ref extended-header 'path #f)])
@@ -165,7 +175,7 @@
        (define o (open-output-bytes))
        (copy-bytes total-len in o)
        ;; Recur to use given path:
-       (untar-one-from-port in delays
+       (untar-one-from-port in handle-entry delays
                             dest strip-count filter
                             permissive?
                             (bytes->path (nul-terminated (get-output-bytes o)))
@@ -175,7 +185,7 @@
        (define o (open-output-bytes))
        (copy-bytes total-len in o)
        ;; Recur to use given link target:
-       (untar-one-from-port in delays
+       (untar-one-from-port in handle-entry delays
                             dest strip-count filter
                             permissive?
                             path-from-extended-attributes
@@ -188,6 +198,51 @@
     (copy-bytes total-len in #f)
     delays]))
 
+(define (handle-tar-entry kind
+                          filename
+                          content size
+                          attribs)
+  (define mode (hash-ref attribs 'permissions))
+  (define mod-time (hash-ref attribs 'modify-seconds))
+  (case kind
+    [(directory)
+     (make-directory* filename)
+     (list
+      ;; delay directory meta-data updates until after any contained
+      ;; files are written
+      (lambda ()
+        (try-file-op
+         (lambda ()
+           (file-or-directory-modify-seconds* filename mod-time #t)))
+        (try-file-op
+         (lambda ()
+           (file-or-directory-permissions* filename mode #t)))))]
+    [(file)
+     (define in content)
+     (define-values (base name dir?) (split-path filename))
+     (when (path? base) (make-directory* base))
+     (call-with-output-file*
+      filename
+      #:exists 'truncate
+      (lambda (out)
+        (copy-bytes size in out)))
+     (try-file-op
+      (lambda ()
+        (file-or-directory-permissions* filename mode #f)))
+     (try-file-op
+      (lambda ()
+        (file-or-directory-modify-seconds* filename mod-time #f)))
+     null]
+    [(link)
+     (define link-target content)
+     (define-values (base name dir?) (split-path filename))
+     (when (path? base) (make-directory* base))
+     (when (file-exists? filename) (delete-file filename))
+     (make-file-or-directory-link link-target filename)
+     null]
+    [else
+     null]))
+
 (define (copy-bytes amt in out)
   (let ([bstr (make-bytes (min amt 4096))])
     (let loop ([amt amt])