79 lines
2.7 KiB
Scheme
79 lines
2.7 KiB
Scheme
(define-module (guix-cantrips 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
|
|
Downloads the source code of a package and extracts it to a directory"
|
|
|
|
(define proj-dir
|
|
(option-ref opts
|
|
'project-dir))
|
|
|
|
(define package-name
|
|
(option-ref opts
|
|
'(package)))
|
|
|
|
(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 (zip? filename)
|
|
(string-match ".*[.]zip$" filename))
|
|
|
|
(define (unzip! zip destination)
|
|
(run "unzip" zip "-d" destination))
|
|
|
|
(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)
|
|
|
|
(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))
|
|
|
|
; 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)))))
|
|
|