Commit 24c8abfd authored by Ludovic Courtès's avatar Ludovic Courtès
Browse files

environment: Rewrite to use a profile manifest and 'eval/container*'.

* guix/jupyter/environ.scm: Remove.
* guix/jupyter/environment.scm, guix/jupyter/containers.scm: New files.
* tests/environ.scm: Remove.
* Makefile.am (SOURCES): Adjust accordingly.
(SCM_TESTS): Remove tests/environ.scm.
* guix-jupyter-container.scm <top level>: Turn into...
(run-inner-proxy): ... this.  New procedure.
* guix-jupyter-kernel.scm (%inferior): New variable.
(reply-execute-request): Use 'string-tokenize' and
'specifications->manifest'.  Pass the manifest to 'start-container'.
(module-to-import?): New procedure.
(start-container): Rewrite to take a manifest and to evaluate code with
'eval/container*'.  Set the 'GUIX_ENVIRONMENT' and 'JUPYTER_PATH'
environment variables.
* jupyter/kernels.scm (jupyter-kernel-path): Remove "GUIX_PROFILE"
hack.
parent 0aa6acf6
......@@ -21,7 +21,8 @@ moddir=@guilemoduledir@
godir=@guileobjectdir@
SOURCES = \
guix/jupyter/environ.scm \
guix/jupyter/containers.scm \
guix/jupyter/environment.scm \
guix/jupyter/kernel.scm \
guix/jupyter/logging.scm \
guix/jupyter/magic.scm \
......@@ -43,8 +44,7 @@ SCM_TESTS = \
tests/magic.scm \
tests/hmac.scm \
tests/kernels.scm \
tests/servers.scm \
tests/environ.scm
tests/servers.scm
TESTS = $(SCM_TESTS)
......
......@@ -217,13 +217,12 @@ stripped."
;; Run.
;;
(match (command-line)
((_ name session-id connection)
(let* ((connection (json->connection (json-string->scm connection)))
(kernel (connection->kernel connection
#:context %context))
(state (proxy-state kernel)))
(format/log "started proxy as PID ~a~%" (getpid))
(serve-kernels (list kernel)
(proxy-request-handler dispatch-route)
state))))
(define (run-inner-proxy name session-id connection)
(let* ((connection (json->connection (json-string->scm connection)))
(kernel (connection->kernel connection
#:context %context))
(state (proxy-state kernel)))
(format/log "started proxy as PID ~a~%" (getpid))
(serve-kernels (list kernel)
(proxy-request-handler dispatch-route)
state)))
......@@ -25,19 +25,26 @@
(rnrs bytevectors)
(ice-9 match)
(sxml simple)
((gnu packages) #:select (specification->package))
(gnu build linux-container)
(gnu system file-systems)
(guix build syscalls)
(guix build utils)
(guix gexp)
(guix store)
(guix monads)
(guix modules)
(guix profiles)
(gcrypt base16)
(jupyter messages)
(jupyter kernels)
(jupyter servers)
(guix jupyter containers)
(guix jupyter logging)
(guix jupyter proxy)
(guix jupyter kernel)
(guix jupyter magic)
(guix jupyter environ))
(guix jupyter environment))
(define session-id (random (* 255 255)
(seed->random-state
......@@ -55,9 +62,14 @@
;;
;; Html.
;; HTML.
;;
(define (sxml->html-string sxml)
(call-with-output-string
(lambda (port)
(sxml->xml sxml port))))
(define (error->shtml error)
(match error
(('guix-kernel msg errno)
......@@ -68,9 +80,7 @@
"Error !"))))
(define (error->html error)
(call-with-output-string
(lambda (port)
(sxml->xml (error->shtml error) port))))
(sxml->html-string (error->shtml error)))
;;
;; Handlers.
......@@ -88,6 +98,10 @@
(kernel-info-reply->json %kernel-info-reply))))
state)
(define %inferior
;; FIXME: This could be expensive!
(delay (open-default-inferior)))
(define (reply-execute-request kernel kind message state)
(let* ((content (message-content message))
(code (assoc-ref (json-string->scm content) "code"))
......@@ -98,23 +112,32 @@
(cond
((magic-env? code)
(pub-busy kernel message)
(let* ((list (string-split magic #\ ))
(env-name (list-ref list 2))
(env (list-cdr-ref list 4)))
(match (lookup-proxied env-name state)
(#f
(format/log "spawning container ~s~%" env-name)
(let* ((container (start-container container-context
env-name env))
(state (register-proxied env-name container
state)))
(monitor-client container)
(pub-idle kernel message)
(send-message container message)
(increment-execution-count state)))
((? kernel? proxy)
(send-message kernel message)
(increment-execution-count state)))))
(match (string-tokenize magic)
((_ "environment" name "<-" specs ...)
(match (lookup-proxied name state)
(#f
(format/log "spawning container ~s~%" name)
(let* ((manifest (specifications->manifest (force %inferior)
specs))
(container (with-store store ;FIXME: not nice
(run-with-store store
(start-container container-context
name manifest))))
(state (register-proxied name container state)))
(monitor-client container)
(pub-idle kernel message)
(send-message container message)
(increment-execution-count state)))
((? kernel? proxy)
(send-message kernel message)
(increment-execution-count state))))
((lst ...)
(reply-html kernel message
(sxml->html-string
`(bold "Invalid " (code "guix environment")
" magic."))
count)
(increment-execution-count state))))
((or (magic-run? code)
(magic-kernel? code))
(let* ((list (string-split magic #\ ))
......@@ -166,55 +189,99 @@
fs)))
%network-file-mappings))
(define (start-container context name env)
"Start a container with the given NAME and environment ENV, where ENV is a
list of package specs. Return a <kernel> connected to the process in that
container."
(let* ((guile-version (if (null? env)
(guile-current-version->path)
(if (not (package-in-list->path env "guile"))
(guile-current-version->path)
(guile->bin-path
(package-in-list->path env "guile")))))
(new-env (if (null? env)
(environ)
(make-new-environment (environ) name env)))
(connection kernel (allocate-connection context "tcp"
"127.0.0.1"
(generate-key)))
(exec (lambda ()
;; (set-network-interface-up "lo") ;up lo interface
(apply execle guile-version
new-env
(append (list "guile")
(guile-current-load-path->args-list)
(guile-current-load-compiled-path->args-list)
(list "--no-auto-compile" "-s"
container-path
name (number->string session-id)
(scm->json-string
(connection->json connection)))))))
(root (string-append "/tmp/guix-kernel/container/"
name "-" (number->string session-id)))
(fs (cons* %immutable-store
(file-system
(device "/tmp/guix-kernel")
(mount-point "/tmp/guix-kernel")
(type "none")
(check? #f)
(flags '(bind-mount)))
(append %container-file-systems
%network-file-systems))))
(mkdir-p root)
(set-kernel-pid kernel
;; XXX: Since we'll talk to KERNEL over TCP/IP (due to
;; the fact that we use a "connection file" above), this
;; process must live in the global network namespace.
;; TODO: Arrange to use Unix-domain sockets instead.
(run-container root fs
(delq 'net %namespaces)
1 exec))))
(define (module-to-import? name)
"Return true if NAME (a list of symbols) denotes a module that should be
imported."
(match name
(('guix _ ...) #t)
(('gnu _ ...) #t)
(('jupyter _ ...) #t)
(_ #f)))
(define (start-container context name manifest)
"Start a container with the given NAME and with a profile built from
MANIFEST. Return, as a monadic value, a <kernel> connected to the process in
that container."
(define guile-gcrypt
(specification->package "guile-gcrypt"))
(define guile-json
(specification->package "guile-json"))
(define guile-simple-zmq
(specification->package "guile-simple-zmq"))
(define (spawn profile)
(with-extensions (list guile-gcrypt guile-json guile-simple-zmq)
(with-imported-modules (source-module-closure
'((guix profiles)
(guix search-paths)
(guix jupyter proxy)
(guix jupyter magic)
(guix jupyter logging)
(jupyter messages)
(jupyter kernels)
(jupyter servers))
#:select? module-to-import?)
#~(begin
(use-modules (guix profiles)
(guix search-paths)
(ice-9 match))
(format (current-error-port)
"starting inner proxy with profile '~a'...~%"
#$profile)
;; (set-network-interface-up "lo") ;up lo interface
;; Do like 'guix environment'.
(setenv "GUIX_ENVIRONMENT" #$profile)
;; Make sure kernels can always be found.
(setenv "JUPYTER_PATH"
#$(file-append profile "/share/jupyter"))
;; Set the environment variables that apply to PROFILE.
(for-each (match-lambda
((spec . value)
(setenv (search-path-specification-variable spec)
value)))
(profile-search-paths #$profile))
(load #$(local-file container-path))
(run-inner-proxy #$name
#$(number->string session-id)
#$(scm->json-string
(connection->json connection)))))))
(define-values (connection kernel)
(allocate-connection context "tcp" "127.0.0.1"
(generate-key)))
(define root
(string-append "/tmp/guix-kernel/container/"
name "-" (number->string session-id)))
(define fs
(cons (file-system
(device "/tmp/guix-kernel")
(mount-point "/tmp/guix-kernel")
(type "none")
(check? #f)
(flags '(bind-mount)))
(append %container-file-systems %network-file-systems)))
(define namespaces
;; XXX: Since we'll talk to KERNEL over TCP/IP (due to the fact that we
;; use a "connection file" above), this process must live in the global
;; network namespace. TODO: Arrange to use Unix-domain sockets instead.
(delq 'net %namespaces))
(mlet* %store-monad ((_ ((lift1 mkdir-p %store-monad) root))
(profile (profile-derivation manifest))
(pid (eval/container* (spawn profile) root
#:mounts fs
#:namespaces namespaces
#:guest-uid 1000
#:guest-gid 1000)))
(return (set-kernel-pid kernel pid))))
(define (exit-handler kernel)
......@@ -228,7 +295,10 @@ container."
(sigaction SIGTERM (exit-handler kernel))
(sigaction SIGINT (exit-handler kernel))
(let* ((sub-kernel (start-container container-context "default" '()))
(let* ((sub-kernel (with-store store ;FIXME: not nice
(run-with-store store
(start-container container-context "default"
(manifest '())))))
(state (register-proxied "default" sub-kernel
(proxy-state kernel))))
(serve-kernels (list kernel sub-kernel)
......
;;; Guix-kernel -- Guix kernel for Jupyter
;;; Copyright (C) 2019 Ludovic Courtès <ludovic.courtes@inria.fr>
;;;
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
(define-module (guix jupyter containers)
#:use-module (guix gexp)
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix derivations)
#:use-module (gnu system file-systems)
#:use-module (gnu system linux-container)
#:use-module (gnu build linux-container)
#:use-module (gnu build accounts)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (eval/container*))
(define (bind-mount item)
(file-system
(mount-point item)
(device item)
(type "none")
(flags '(bind-mount read-only))
(check? #f)))
;; Variant of 'eval/container' in (gnu system linux-container).
(define* (eval/container* exp root
#:key
(guest-uid 1000) (guest-gid 1000)
(mounts '())
(namespaces %namespaces))
"Evaluate EXP, a gexp, in a new process executing in separate namespaces as
listed in NAMESPACES, using ROOT as its root directory. Add MOUNTS, a list
of <file-system>, to the set of directories to mount in the process's mount
namespace. Return the process' PID."
(mlet %store-monad ((lowered (lower-gexp exp)))
(define inputs
(cons (lowered-gexp-guile lowered)
(lowered-gexp-inputs lowered)))
(define items
(append (append-map derivation-input-output-paths inputs)
(lowered-gexp-sources lowered)))
(define (run-guile)
;; Run Guile to evaluate EXP.
;; There's code out there such as (guix profiles) that looks up
;; /etc/passwd right from the top level. Thus, create it upfront.
(let ((users (list (password-entry
(name "jupyter")
(real-name "Jupyter User")
(uid guest-uid) (gid guest-gid)
(directory "/home/jupyter"))))
(groups (list (group-entry (name "users")
(gid guest-gid))
(group-entry (gid 65534) ;the overflow GID
(name "overflow")))))
(write-passwd users)
(write-group groups))
(apply execl (string-append (derivation-input-output-path
(lowered-gexp-guile lowered))
"/bin/guile")
"guile"
(append (append-map (lambda (directory)
`("-L" ,directory))
(lowered-gexp-load-path lowered))
(append-map (lambda (directory)
`("-C" ,directory))
(lowered-gexp-load-compiled-path
lowered))
(list "-c"
(object->string
(lowered-gexp-sexp lowered))))))
(mbegin %store-monad
(built-derivations inputs)
(mlet* %store-monad ((closure ((store-lift requisites) items))
(mounts -> (append (map bind-mount closure)
mounts)))
(return (run-container root mounts namespaces 1
run-guile
#:guest-uid guest-uid
#:guest-gid guest-gid))))))
;;; Guix-kernel -- Guix kernel for Jupyter
;;; Copyright (C) 2018 Pierre-Antoine Rouby <pierre-antoine.rouby@inria.fr>
;;;
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
(define-module (guix jupyter environ)
#:use-module (gnu packages)
#:use-module (guix licenses)
#:use-module (guix packages)
#:use-module (guix records)
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix monads)
#:use-module (guix profiles)
#:use-module (guix derivations)
#:use-module (guix build utils)
#:use-module (guix search-paths)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:export (guile->bin-path
guile-current-version->path
guile-current-load-path->args-list
guile-current-load-compiled-path->args-list
package-in-list->path
make-new-environment
env->str)) ;Export for tests.
(define (store) (open-connection))
;;
;; Guix package.
;;
(define (m-package-by-name->package-path name)
(mlet %store-monad ((drv (package->derivation
(specification->package name))))
(mbegin %store-monad
(built-derivations (list drv))
(return (derivation->output-path drv)))))
(define (package-name->path name)
"Return store path for package coresponding to NAME."
(run-with-store (store) (m-package-by-name->package-path name)))
;;
;; Profile.
;;
(define (m-build-profile->path lst)
(mlet* %store-monad ((man -> (specifications->manifest lst))
(drv (profile-derivation man)))
(mbegin %store-monad
(built-derivations (list drv))
(return (derivation->output-path drv)))))
(define (new-profile->path packages)
(run-with-store (store) (m-build-profile->path packages)))
;;
;; Guile.
;;
(define (guile->bin-path guile)
"Return path to guile executable file. GUILE is package specification."
(string-append guile "/bin/guile"))
(define (guile-current-version->path)
"Return path to current guile executable file."
(guile->bin-path (package-name->path "guile")))
(define (guile-current-load-path->args-list)
"Return list of load path with '-L' prefix for each path."
(append-map (cut list "-L" <>)
%load-path))
(define (guile-current-load-compiled-path->args-list)
"Return list of load compiled path with '-C' prefix for each path."
(append-map (cut list "-C" <>)
%load-compiled-path))
;;
;; Create environment.
;;
(define (package-in-list->path packages name)
"Return path for package NAME in PACKAGES list."
(cond
((null? packages) #f)
((equal? (car (string-split (car packages) #\@)) name)
(package-name->path (car packages)))
(else (package-in-list->path (cdr packages) name))))
(define (make-profile packages)
"Create profile with all PACKAGES, and return profile path."
(catch #t
(λ ()
(new-profile->path packages))
(λ error
(throw 'guix-kernel "Package not found !" error))))
(define (env->str name value)
(string-append (string-upcase name) "="
(if (not value) "" value)))
(define (make-new-environment environ name packages)
(let* ((home (env->str "HOME" (getenv "HOME")))
(user (env->str "USER" (getenv "USER")))
(logname (env->str "LOGNAME" (getenv "LOGNAME")))
(term (env->str "TERM" (getenv "TERM")))
(pwd (env->str "PWD" (getenv "PWD")))
(pager (env->str "PAGER" (getenv "PAGER")))
(shell (env->str "SHELL" (getenv "SHELL")))
;; Modified variables.
(ps1 (env->str "PS1" (string-append "'Jupyter Guix Kernel ["
name "] -> '")))
(jenv (env->str "JUPYTER_ENV" name)) ;Environment name.
;; Paths.
(profile (make-profile packages))
(paths (profile-search-paths profile)))
;; List of environment variables.
(cons* home user logname term pwd pager shell ps1 jenv
(string-append "GUIX_PROFILE=" profile)
(map (match-lambda
((spec . value)
(env->str (search-path-specification-variable spec)
value)))
paths))))
;;; Guix-kernel -- Guix kernel for Jupyter
;;; Copyright (C) 2019 Ludovic Courtès <ludovic.courtes@inria.fr>
;;;
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
(define-module (guix jupyter environment)
#:use-module ((guix ui) #:select (package-specification->name+version+output))
#:use-module (guix gexp)
#:use-module (guix channels)
#:use-module (guix inferior)
#:use-module (guix profiles)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-71)
#:use-module (ice-9 match)
#:export (open-default-inferior
specifications->manifest))
(define %user-profile
(string-append %profile-directory "/current-guix"))
(define (open-default-inferior)
(open-inferior (if (file-exists? %user-profile)
%user-profile
(inferior-for-channels %default-channels))))
(define-condition-type &environment-error &error
environment-error?)
(define-condition-type &package-not-found-error &environment-error
package-not-found-error?
(name package-not-found-error-name) ;string
(version package-not-found-error-version)) ;string | #f
(define-condition-type &output-not-found-error &environment-error
output-not-found-error?
(package output-not-found-error-package) ;<inferior-package>
(output output-not-found-error-output)) ;string
(define (specification->manifest-entry inferior spec)
"Lookup package SPEC in INFERIOR. On success, return a <manifest-entry>
for it; on failure, raise an error."
(define-values (name version output)
(package-specification->name+version+output spec))