From a8848793e40ed3ccf638f565633cd36ad0a20d36 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 24 Apr 2015 22:52:13 +0900 Subject: [PATCH] Adding a preserve thunk to call-with-temp-file/dir. --- lib/chibi/net/http-server.scm | 2 +- lib/chibi/net/server-util.sld | 2 +- lib/chibi/snow/commands.scm | 7 +++-- lib/chibi/temp-file.scm | 58 ++++++++++++++++++++++++++--------- lib/chibi/zlib.scm | 2 +- 5 files changed, 50 insertions(+), 21 deletions(-) diff --git a/lib/chibi/net/http-server.scm b/lib/chibi/net/http-server.scm index 7a95e4ef..152edcf9 100644 --- a/lib/chibi/net/http-server.scm +++ b/lib/chibi/net/http-server.scm @@ -209,7 +209,7 @@ (define (http-cgi-bin-servlet request local-path next restart) (call-with-temp-file "cgi.out" - (lambda (temp-file out) + (lambda (temp-file out preserve) (let ((pid (fork))) (cond ((zero? pid) diff --git a/lib/chibi/net/server-util.sld b/lib/chibi/net/server-util.sld index 21e8c292..36d12e09 100644 --- a/lib/chibi/net/server-util.sld +++ b/lib/chibi/net/server-util.sld @@ -5,5 +5,5 @@ (chibi temp-file) (srfi 33) (srfi 69)) (export line-handler command-handler parse-command - get-host file-mime-type call-with-temp-file) + get-host file-mime-type) (include "server-util.scm")) diff --git a/lib/chibi/snow/commands.scm b/lib/chibi/snow/commands.scm index fa6890d4..20d91b9f 100644 --- a/lib/chibi/snow/commands.scm +++ b/lib/chibi/snow/commands.scm @@ -1365,7 +1365,7 @@ (define (install-sexp-file cfg obj dest) (if (install-with-sudo? cfg dest) (call-with-temp-file "sexp" - (lambda (tmp-path out) + (lambda (tmp-path out preserve) (write-simple-pretty obj out) (close-output-port out) (system "sudo" "cp" tmp-path dest))) @@ -1715,7 +1715,7 @@ (else (call-with-temp-dir "pkg" - (lambda (dir) + (lambda (dir preserve) (tar-extract snowball (lambda (f) (make-path dir (path-strip-top f)))) (let ((libs (filter-map (lambda (lib) (build-library impl cfg lib dir)) (package-libraries pkg)))) @@ -1745,7 +1745,8 @@ `(,@(remove (lambda (x) (and (pair? x) (eq? 'installed-files (car x)))) pkg) - (installed-files ,@installed-files))))))))))) + (installed-files ,@installed-files)))) + (preserve)))))))) (define (install-package-from-file repo impl cfg file) (let ((pkg (package-file-meta file)) diff --git a/lib/chibi/temp-file.scm b/lib/chibi/temp-file.scm index ca7d8bdc..df9ce97a 100644 --- a/lib/chibi/temp-file.scm +++ b/lib/chibi/temp-file.scm @@ -1,10 +1,23 @@ -(define (call-with-temp-file template proc) - (let ((base (string-append - "/tmp/" (path-strip-extension template) - "-" (number->string (current-process-id)) "-" - (number->string (exact (round (current-second)))) "-")) - (ext (or (path-extension template) "tmp"))) +;;> Runs a procedure on a temporary file. \var{proc} should be a +;;> procedure of three values: \scheme{(path out preserve)}, where +;;> \scheme{path} is the path to the temporary file, \scheme{out} is +;;> an output port opened on the file, and \scheme{preserve} is a +;;> thunk to disable deleting the file. The file name will be in a +;;> temp directory, based on \var{template} and having the same +;;> extension if present, with permissions from the optional +;;> \var{mode} which defaults to \scheme{#o700}. Returns the result +;;> of \var{proc}, after first deleting the file if the +;;> \scheme{preserve} thunk was not called. + +(define (call-with-temp-file template proc . o) + (let* ((mode (if (pair? o) (car o) #o700)) + (pid (current-process-id)) + (base (string-append + "/tmp/" (path-strip-extension template) + "-" (number->string pid) "-" + (number->string (exact (round (current-second)))) "-")) + (ext (or (path-extension template) "tmp"))) (let lp ((i 0)) (let ((path (string-append base (number->string i) "." ext))) (cond @@ -14,19 +27,33 @@ (lp (+ i 1))) (else (let ((fd (open path - (bitwise-ior open/write open/create open/exclusive)))) + (bitwise-ior open/write open/create open/exclusive) + mode))) (if (not fd) (if (file-exists? path) ;; created between test and open (lp (+ i 1)) (error "Couldn't generate temp file in /tmp " path)) - (let* ((out (open-output-file-descriptor fd #o700)) - (res (proc path out))) + (let* ((out (open-output-file-descriptor fd)) + (preserve? #f) + (res (proc path out (lambda () (set! preserve? #t))))) (close-output-port out) - (delete-file path) + (if (and (not preserve?) (equal? pid (current-process-id))) + (delete-file path)) res))))))))) -(define (call-with-temp-dir template proc) - (let* ((pid (current-process-id)) +;;> Runs a procedure on a temporary directory. \var{proc} should be a +;;> procedure of two values: \scheme{(path preserve)}, where +;;> \scheme{path} is the path to the temporary directory and +;;> \scheme{preserve} is a thunk to disable deleting the dir. The +;;> directory name will be in a temp directory, based on +;;> \var{template}, with permissions from the optional \var{mode} +;;> which defaults to \scheme{#o700}. Returns the result of +;;> \var{proc}, after first deleting the file hierarchy rooted at +;;> \scheme{path} if the \scheme{preserve} thunk was not called. + +(define (call-with-temp-dir template proc . o) + (let* ((mode (if (pair? o) (car o) #o700)) + (pid (current-process-id)) (base (string-append "/tmp/" template "-" (number->string pid) "-" (number->string (exact (round (current-second)))) "-"))) @@ -37,10 +64,11 @@ (error "Repeatedly failed to generate temp dir in /tmp " path)) ((file-exists? path) (lp (+ i 1))) - ((create-directory path #o700) - (let ((res (proc path))) + ((create-directory path mode) + (let* ((preserve? #f) + (res (proc path (lambda () (set! preserve? #t))))) ;; sanity check for host threading issues and broken forks - (if (equal? pid (current-process-id)) + (if (and (not preserve?) (equal? pid (current-process-id))) (delete-file-hierarchy path)) res)) (else diff --git a/lib/chibi/zlib.scm b/lib/chibi/zlib.scm index f4466b60..1f93d858 100644 --- a/lib/chibi/zlib.scm +++ b/lib/chibi/zlib.scm @@ -50,7 +50,7 @@ ;; Use a temp file to avoid dead-lock issues with pipes. (define (process-run-bytevector cmd bvec) (call-with-temp-file "bvec" - (lambda (path out) + (lambda (path out preserve) (write-bytevector bvec out) (close-output-port out) (process->bytevector (append cmd (list path))))))