unofficial mirror of gwl-devel@gnu.org
 help / color / mirror / Atom feed
* support for containers
@ 2019-01-28 23:03 Ricardo Wurmus
  2019-01-29  9:38 ` Ricardo Wurmus
  2019-01-29 10:22 ` zimoun
  0 siblings, 2 replies; 12+ messages in thread
From: Ricardo Wurmus @ 2019-01-28 23:03 UTC (permalink / raw)
  To: gwl-devel

Hi,

the GWL could already support execution in containers with this patch:

--8<---------------cut here---------------start------------->8---
diff --git a/gwl/processes.scm b/gwl/processes.scm
index b7251db..9ec5925 100644
--- a/gwl/processes.scm
+++ b/gwl/processes.scm
@@ -19,13 +19,20 @@
   #:use-module ((guix derivations)
                 #:select (derivation->output-path
                           build-derivations))
+  #:use-module ((guix packages)
+                #:select (package-file))
   #:use-module (guix gexp)
-  #:use-module ((guix monads) #:select (mlet return))
+  #:use-module ((guix monads) #:select (mlet mapm return))
   #:use-module (guix records)
   #:use-module ((guix store)
                 #:select (open-connection
                           run-with-store
+                          with-store
                           %store-monad))
+  #:use-module ((guix modules)
+                #:select (source-module-closure))
+  #:use-module (gnu system file-systems)
+  #:use-module (gnu build linux-container)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
@@ -232,34 +239,82 @@ of PROCESS."
   (arguments code-snippet-arguments)
   (code      code-snippet-code))

-(define (procedure->gexp process)
+(define* (procedure->gexp process #:key (container? #t))
   "Transform the procedure of PROCESS to a G-expression or return the
 plain S-expression."
   (define (sanitize-path path)
     (string-join (delete ".." (string-split path #\/))
                  "/"))
-  (match (process-procedure process)
-    ((? gexp? g) g)
-    ((? list? s) s)
-    (($ <code-snippet> name arguments code)
-     (let ((call (or (and=> (find (lambda (lang)
-                                    (eq? name (language-name lang)))
-                                  languages)
-                            language-call)
-                     ;; There is no pre-defined way to execute the
-                     ;; snippet.  Use generic approach.
-                     (lambda (process code)
-                       #~(begin
-                           (for-each (lambda (pair)
-                                       (setenv (car pair) (cdr pair)))
-                                     '#$(process->env process))
-                           (apply system*
-                                  (string-append (getenv "_GWL_PROFILE")
-                                                 #$(sanitize-path (symbol->string name)))
-                                  '#$(append arguments
-                                             (list code))))))))
-       (call process code)))
-    (whatever (error (format #f "unsupported procedure: ~a\n" whatever)))))
+  (define contents
+    (match (process-procedure process)
+      ((? gexp? g) g)
+      ((? list? s) s)
+      (($ <code-snippet> name arguments code)
+       (let ((call (or (and=> (find (lambda (lang)
+                                      (eq? name (language-name lang)))
+                                    languages)
+                              language-call)
+                       ;; There is no pre-defined way to execute the
+                       ;; snippet.  Use generic approach.
+                       (lambda (process code)
+                         #~(begin
+                             (for-each (lambda (pair)
+                                         (setenv (car pair) (cdr pair)))
+                                       '#$(process->env process))
+                             (apply system*
+                                    (string-append (getenv "_GWL_PROFILE")
+                                                   #$(sanitize-path (symbol->string name)))
+                                    '#$(append arguments
+                                               (list code))))))))
+         (call process code)))
+      (whatever (error (format #f "unsupported procedure: ~a\n" whatever)))))
+
+  (if container?
+      (let* ((package-dirs
+              (with-store store
+                (run-with-store store
+                  (mapm %store-monad package-file
+                        (process-package-inputs process)))))
+             (data-input-dirs
+              (delete-duplicates
+               (map dirname (process-data-inputs process))))
+             (output-dirs
+              (delete-duplicates
+               (map dirname (process-outputs process))))
+             (input-mappings
+              (map (lambda (dir)
+                     (file-system-mapping
+                      (source dir)
+                      (target dir)
+                      (writable? #f)))
+                   (lset-difference string=?
+                                    (append package-dirs
+                                            data-input-dirs)
+                                    output-dirs)))
+             (output-mappings
+              (map (lambda (dir)
+                     (file-system-mapping
+                      (source dir)
+                      (target dir)
+                      (writable? #t)))
+                   output-dirs))
+             (specs
+              (map (compose file-system->spec
+                            file-system-mapping->bind-mount)
+                   (append input-mappings
+                           output-mappings))))
+        (with-imported-modules (source-module-closure
+                                '((gnu build linux-container)
+                                  (gnu system file-systems)))
+          #~(begin
+              (use-modules (gnu build linux-container)
+                           (gnu system file-systems))
+              (call-with-container (append %container-file-systems
+                                           (map spec->file-system
+                                                '#$specs))
+                (lambda ()
+                  #$contents)))))
+      contents))

 ;;; ---------------------------------------------------------------------------
 ;;; ADDITIONAL FUNCTIONS
--8<---------------cut here---------------end--------------->8---

The directories to be mounted in the container are derived from the
declared inputs and outputs.  The only problem is that inputs are
read-only in this implementation.  I like it this way, actually, but it
means that the extended example workflow won’t work as it tries to
delete its inputs.

Should data inputs be declared as (mutable-file …) or (file …) instead
of being plain strings?

--
Ricardo

^ permalink raw reply related	[flat|nested] 12+ messages in thread

end of thread, other threads:[~2019-01-30 13:33 UTC | newest]

Thread overview: 12+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2019-01-28 23:03 support for containers Ricardo Wurmus
2019-01-29  9:38 ` Ricardo Wurmus
2019-01-29 10:39   ` zimoun
2019-01-29 11:46     ` Ricardo Wurmus
2019-01-29 14:29       ` zimoun
2019-01-29 17:19         ` Ricardo Wurmus
2019-01-29 21:52           ` zimoun
2019-01-29 23:16             ` Ricardo Wurmus
2019-01-30 10:17               ` zimoun
2019-01-30 12:46                 ` Ricardo Wurmus
2019-01-29 10:22 ` zimoun
2019-01-29 11:44   ` Ricardo Wurmus

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).