diff options
Diffstat (limited to 'henrietta-cache.scm')
| -rw-r--r-- | henrietta-cache.scm | 59 |
1 files changed, 34 insertions, 25 deletions
diff --git a/henrietta-cache.scm b/henrietta-cache.scm index ce2ed93..58d7f90 100644 --- a/henrietta-cache.scm +++ b/henrietta-cache.scm @@ -80,34 +80,43 @@ EOF uri (get-condition-property e 'exn 'message)))))) (define (download-files-from-list base-uri files cache-dir) - (let ((add-to-uri + (let ((tmp-dir (create-temporary-directory)) + (add-to-uri (lambda (f) (let* ((components (string-split f "/")) (rel (update-uri (uri-reference "") path: components))) (uri-relative-to rel base-uri))))) - (create-directory cache-dir #t) ; TODO: Download to tmpdir, then move - (for-each - (lambda (file) - (printf "\t\t~A...\n" file) - (flush-output) - (and-let* ((dirname (pathname-directory file)) - (directory (make-pathname cache-dir dirname))) - (unless (file-exists? directory) - (create-directory directory #t))) - (condition-case - (call-with-input-request - (add-to-uri file) #f - (lambda (i) - (call-with-output-file - (make-pathname cache-dir file) - (lambda (o) (copy-port i o))))) - (e (exn http) - (error (sprintf - (conc "Could not download file \"~A\", " - "listed in meta-file/files-list (full URI: ~A) -- ~A") - file (uri->string (add-to-uri file)) - (get-condition-property e 'exn 'message)))))) - files))) + (handle-exceptions exn + (begin (system (sprintf "rm -rf ~A" (qs tmp-dir))) + (signal exn)) + (for-each + (lambda (file) + (printf "\t\t~A...\n" file) + (flush-output) + (and-let* ((dirname (pathname-directory file)) + (directory (make-pathname tmp-dir dirname))) + (unless (file-exists? directory) + (create-directory directory #t))) + (condition-case + (call-with-input-request + (add-to-uri file) #f + (lambda (i) + (call-with-output-file + (make-pathname tmp-dir file) + (lambda (o) (copy-port i o))))) + (e (exn http) + (error (sprintf + (conc "Could not download file \"~A\", " + "listed in meta-file/files-list (full URI: ~A) -- ~A") + file (uri->string (add-to-uri file)) + (get-condition-property e 'exn 'message)))))) + files) + (create-directory cache-dir #t) + (let* ((cmd (sprintf "mv ~A/* ~A" (qs tmp-dir) (qs cache-dir))) + (status (system cmd))) + (unless (zero? status) + (error "Got an error executing command" cmd)) + (system (sprintf "rm -rf ~A" (qs tmp-dir))))))) ;; Make-cmd is a lambda which accepts the temporary file- and dirname ;; and returns a suitable command to execute using SYSTEM @@ -212,7 +221,7 @@ EOF (flush-output) (handle-exceptions exn (begin - (system (sprintf "rm -rf ~A" cache-dir)) + (system (sprintf "rm -rf ~A" (qs cache-dir))) (fprintf (current-error-port) "Error downloading or extracting egg '~A' release ~A: " egg-name egg-release) |