Compare commits

...

2 Commits

Author SHA1 Message Date
TakeV 8e48f8fedb
Remove coreutils as a dependency, as we are going through guix 2023-07-10 00:42:31 -07:00
TakeV 85aa9393c4
Fix permissions for downloaded source code.
Also switch to using guix build utils for checking and copying the directory of
t he source code.

Run summon through guix style
2023-07-10 00:32:08 -07:00
2 changed files with 65 additions and 39 deletions

View File

@ -79,8 +79,7 @@
(propagated-inputs (list guix
guile-config
tar
unzip
coreutils))
unzip))
(synopsis "")
(description "")
(home-page "")

View File

@ -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)))))