diff options
Diffstat (limited to 'desmoctl.scm')
| -rw-r--r-- | desmoctl.scm | 47 |
1 files changed, 34 insertions, 13 deletions
diff --git a/desmoctl.scm b/desmoctl.scm index edbd4c3..98ccdf4 100644 --- a/desmoctl.scm +++ b/desmoctl.scm @@ -7,6 +7,8 @@ (chicken port) (chicken io) (chicken file) + (chicken file posix) + (chicken string) srfi-13 medea matchable @@ -15,6 +17,7 @@ intarweb uri-common shell + filepath ) ;;;;;;;;;;;;;;; @@ -67,7 +70,7 @@ (define default-cfg `((user-cfg-path - . ,(string-append (get-environment-variable "HOME") "/" ".desmorc")) + . ,(filepath:combine (get-environment-variable "HOME") ".desmorc")) (mgmt-api-url . "http://localhost:9939") (mgmt-api-key @@ -430,15 +433,34 @@ (begin (debug-print "manifest content:") (pretty-print content))) - (define files-list - (let ((pair (assoc 'files content))) - (if pair - (vector->list (cdr pair)) - '()))) + (define filespec-list + (match (assoc 'files content) + [#f '()] + [pair (vector->list (cdr pair))])) - (define desmometa-path "__desmometa") + (define work-area-path "__desmowork") + (define desmometa-path (filepath:combine work-area-path "__desmometa")) + (create-directory work-area-path) (create-directory desmometa-path) + + (define pwd (get-environment-variable "PWD")) + + (define (symlink-to-work-area filespec) + (match-let (((from to-jail-abs) (string-split filespec ":"))) + (define to (string-append work-area-path to-jail-abs)) + (define to-dir (filepath:take-directory to)) + + (create-directory to-dir #t) + + (define symlink-from (filepath:combine pwd from)) + (define symlink-to (filepath:combine pwd to)) + + (debug-print (format "from: ~A" symlink-from)) + (debug-print (format "to: ~A" symlink-to)) + (create-symbolic-link symlink-from symlink-to))) + + (for-each symlink-to-work-area filespec-list) (define manifest-json (to-json-string content)) @@ -448,11 +470,11 @@ (debug-print (format "manifest-json: ~A" manifest-json)) (define meta-json-path - (string-append desmometa-path "/manifest.json")) + (filepath:combine desmometa-path "manifest.json")) (define meta-scm-path - (string-append desmometa-path "/manifest.scm")) + (filepath:combine desmometa-path "manifest.scm")) (define meta-version-path - (string-append desmometa-path "/version")) + (filepath:combine desmometa-path "version")) ;; https://stackoverflow.com/a/10441464 (define (write-to-a-file path txt) @@ -468,7 +490,7 @@ (define archive-path (cdr (assoc 'build-archive-path cfg))) (define tar-cmd - (apply string-append "2>&1 tar cvf " archive-path " " desmometa-path " " files-list)) + (format "2>&1 tar cvhf ~A -C ~A ." archive-path work-area-path)) (debug-print "tar-cmd:") (debug-print tar-cmd) @@ -482,8 +504,7 @@ [other (print (format "Failed to build archive ~A." archive-path)) (exit 1)]) - (delete-directory desmometa-path #t) ; recursive - ) + (delete-directory work-area-path #t)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Parse flags and subcommand ;; |