diff --git a/guix-cantrips/summon.scm b/guix-cantrips/summon.scm index 2fcb178..e21a738 100644 --- a/guix-cantrips/summon.scm +++ b/guix-cantrips/summon.scm @@ -1,51 +1,78 @@ (define-module (guix-cantrips summon) - #:use-module (config) - #:use-module (ice-9 ftw) - #:use-module (ice-9 match) - #:use-module (ice-9 rdelim) - #:use-module (ice-9 regex) - #:use-module (os process) - #:export (summon)) - + #:use-module (config) + #:use-module (guix build utils) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (os process) + #:export (summon)) (define (summon opts) - "Options -> Void + "Options -> Void Downloads the source code of a package and extracts it to a directory" - (define proj-dir (option-ref opts 'project-dir)) + (define proj-dir + (option-ref opts + 'project-dir)) - (define package-name (option-ref opts '(package))) + (define package-name + (option-ref opts + '(package))) - (define (tarball? filename) - (string-match ".*[.]tar[.](gz|xz|bz2|lz|lzma|lzo|Z|zst)$" filename)) + (define (tarball? filename) + (string-match ".*[.]tar[.](gz|xz|bz2|lz|lzma|lzo|Z|zst)$" filename)) - (define (untar! tarball destination) - (run "tar" (format #f "--directory=~a" destination) "-xf" tarball)) + (define (untar! tarball destination) + (run "tar" + (format #f "--directory=~a" destination) "-xf" tarball)) - (define (zip? filename) - (string-match ".*[.]zip$" filename)) + (define (zip? filename) + (string-match ".*[.]zip$" filename)) - (define (unzip! zip destination) - (run "unzip" zip "-d" destination)) + (define (unzip! zip destination) + (run "unzip" zip "-d" destination)) - (define (directory? directory) - (eq? (stat:type (stat directory)) 'directory)) + (define (recursively-make-writable! top-level-dir) + "String -> List of Strings +Makes all files in dir writable for the user. +Returns a list of every filename which has been made writable. " + (define (make-writable name stat result) + (begin + (make-file-writable name) + (cons name result))) + (define (ignore name stat result) + result) + (define (warn name stat errno result) + (format (current-error-port) "warning:~a: ~a~%" name + (strerror errno)) result) - (define (copy-directory! directory destination) - (run "cp" "-r" "--no-clobber" "--preserve=timestamps,links" directory destination)) - ; TODO: Fix permissions when copying directory + (file-system-fold ignore ; Just go into every dir + make-writable ; Make files writable + ignore + ignore + ignore ; Ignore dirs + warn ; Show errors + '() ; AND THIS LIST SHALL BE FULL OF FILENAMES <- Magician voice + top-level-dir)) - (let* ((package-build-out (run-with-pipe "r" "guix" "build" "--source" package-name)) - (package-source-dir (read-line (cdr package-build-out)))) - (cond - ((tarball? package-source-dir) - (untar! package-source-dir proj-dir) - (format #t "Package ~a extracted to ~a~&" package-name proj-dir)) - ((zip? package-source-dir) - (unzip! package-source-dir proj-dir) - (format #t "Package ~a extracted to ~a~&" package-name proj-dir)) - ((directory? package-source-dir) - (copy-directory! package-source-dir (format #f "~a/~a" proj-dir package-name)) - (format #t "Package ~a extracted to ~a~&" package-name proj-dir)) - (else (format #t "Unknown format: ~a" package-source-dir))))) + ; Anyway, here is wonderwall + (let* ((package-build-out (run-with-pipe "r" "guix" "build" "--source" + package-name)) + (package-source-dir (read-line (cdr package-build-out)))) + (cond + ((tarball? package-source-dir) + (untar! package-source-dir proj-dir) + (format #t "Package ~a extracted to ~a~&" package-name proj-dir)) + ((zip? package-source-dir) + (unzip! package-source-dir proj-dir) + (format #t "Package ~a extracted to ~a~&" package-name proj-dir)) + ((directory-exists? package-source-dir) + (copy-recursively package-source-dir + (string-append proj-dir "/" package-name) + #:keep-permissions? #f) + (format #t "Fixing permissions:~&") + (recursively-make-writable! (string-append proj-dir "/" package-name)) + (format #t "Package ~a extracted to ~a~&" package-name proj-dir)) + (else (format #t "Unknown format: ~a" package-source-dir)))))