Attention une mise à jour du service Gitlab va être effectuée le mardi 18 janvier (et non lundi 17 comme annoncé précédemment) entre 18h00 et 18h30. Cette mise à jour va générer une interruption du service dont nous ne maîtrisons pas complètement la durée mais qui ne devrait pas excéder quelques minutes.

Commit 1726ccb3 authored by Ludovic Courtès's avatar Ludovic Courtès
Browse files

Rewrite proxy to use 'serve-kernels'.

* jupyter/kernels.scm (generate-key): New procedure.
(relay-message): Remove.
* jupyter/messages.scm (<message>): Use 'define-immutable-record-type'
and define 'set-message-content'.
* guix-jupyter-container.scm (local-eval): Rewrite in terms of
'send-message'.
(reply-html-to-kernel): Remove.
(general-handler): Copy from *-kernel.scm.
(execute-request-sans-magic): New procedure.
(ignore-request, reply-execute-request, shutdown): Adjust to new calling
convention.
(%main-kernel, %main-kernel-id): New variables.
<top level>: Use 'serve-kernels'.
* guix-jupyter-kernel.scm (%main-kernel, %main-kernel-id): New
variables.
(general-handler): Check whether we're talking to %MAIN-KERNEL.
(reply-kernel-info-request, reply-execute-request, shutdown): Add 'kind'
parameter.
(new-container-connect): Remove.
(start-container): Return a <kernel>.
<top level>: Pass both the "default" container kernel and our client to
'server-kernels'.  Set %MAIN-KERNEL.
parent 82363869
......@@ -19,58 +19,39 @@
(use-modules (json)
(simple-zmq)
(srfi srfi-1)
(srfi srfi-11)
(srfi srfi-13)
(srfi srfi-71)
(rnrs bytevectors)
(gcrypt base16)
(ice-9 vlist)
(ice-9 futures)
(ice-9 match)
(sxml simple)
(jupyter messages)
(jupyter kernels)
(jupyter servers)
(guix jupyter logging)
(guix-kernel magic))
;;
;; Kernel information.
;;
(define name
(list-ref (command-line) (- (length (command-line)) 3)))
(define session-id
(list-ref (command-line) (- (length (command-line)) 2)))
(define full-name
(string-append name "-" session-id))
(define notebook-key
(car (last-pair (command-line))))
;;
;; ZeroMQ.
;;
;; ZeroMQ context.
(define context (zmq-create-context))
;; Adresses.
(define addr-shell
(string-append "ipc:///tmp/guix-kernel/ipc/"
full-name "/shell"))
;; Sockets.
(define socket-shell (zmq-create-socket context ZMQ_DEALER))
(define %context (zmq-create-context))
(zmq-set-socket-option socket-shell ZMQ_IDENTITY name)
(define %main-kernel
;; Our "main" client--i.e., the one that started us.
#f)
(zmq-connect socket-shell addr-shell)
(define %main-kernel-id
;; "Identity" of our client to be used as the routing prefix on shell
;; sockets.
#f)
;;
;; Kernel list.
;;
(define (register-kernel vhash kernel)
(vhash-cons (kernel-name kernel) kernel vhash))
(define (register-kernel vhash name kernel)
(format/log "registering kernel '~a' (aka. '~a', PID ~a)~%"
name (kernel-name kernel) (kernel-pid kernel))
(vhash-cons name kernel vhash))
(define (kernel-by-name vhash name)
(match (vhash-assoc name vhash)
......@@ -81,16 +62,7 @@
;; Execution.
;;
(define (socket->kernel socket key)
"Create a \"fake\" kernel that's reachable over SOCKET and uses the given
KEY for signing."
;; XXX: This is really a hack.
(kernel "fake-kernel" (getpid)
#:key key
#:shell socket
#:iosub socket))
(define (local-eval socket message count)
(define (local-eval kernel message count)
(let* ((scontent (json-string->scm (message-content message)))
(sender (header-sender (message-header message)))
(code (string-append "(begin "
......@@ -103,48 +75,52 @@ KEY for signing."
(stop-on-error (assoc-ref scontent "stop_on_error"))
(empty-object '())
(counter (+ count 1))) ;Execution counter
(let-values (((err err-key evalue stacktrace result)
(catch #t
;; Evaluate code.
(lambda ()
(let* ((err #f)
(err-key "No error")
(evalue "Success")
(stacktrace '())
(result (with-output-to-string
(lambda ()
(write
(eval (with-input-from-string code read)
(interaction-environment)))))))
(values err err-key evalue
stacktrace result)))
;; Get error message in case of an exception.
(lambda (key . parameters)
(let* ((err #t)
(err-key (with-output-to-string
(lambda () (display key))))
(evalue (with-output-to-string
(lambda () (display parameters))))
(stacktrace (vector err-key evalue))
(result ""))
(values err err-key evalue
stacktrace result))))))
(let ((send- (lambda (socket type content)
(let ((err err-key evalue stacktrace result
(catch #t
;; Evaluate code.
(lambda ()
(let* ((err #f)
(err-key "No error")
(evalue "Success")
(stacktrace '())
(result (with-output-to-string
(lambda ()
(write
(eval (with-input-from-string code read)
(interaction-environment)))))))
(values err err-key evalue
stacktrace result)))
;; Get error message in case of an exception.
(lambda (key . parameters)
(let* ((err #t)
(err-key (with-output-to-string
(lambda () (display key))))
(evalue (with-output-to-string
(lambda () (display parameters))))
(stacktrace (vector err-key evalue))
(result ""))
(values err err-key evalue
stacktrace result))))))
(let ((send- (lambda* (kernel type content
#:optional (socket kernel-shell))
(let* ((reply (reply message type
(scm->json-string content)))
(parts (message-parts reply notebook-key
#:recipient sender)))
(zmq-send-msg-parts-bytevector socket parts)))))
(send- socket
(scm->json-string content))))
(send-message kernel reply
#:kernel-socket socket
#:recipient sender)))))
(format/log "sending execution result for '~a'~%" code)
(send- kernel
"execute_input" `(("code" . ,code)
("execution_count" . ,counter)))
("execution_count" . ,counter))
kernel-iopub)
(when err
(send- socket
(send- kernel
"error" `(("ename" . ,err-key)
("evalue" . ,evalue)
("traceback" . ,stacktrace)))
(send- socket
("traceback" . ,stacktrace))
kernel-iopub)
(send- kernel
"execute_reply" `(("status" . "error")
("execution_count" . ,counter)
("ename" . ,err-key)
......@@ -153,31 +129,20 @@ KEY for signing."
("payload" . [])
("user_expressions" . ,empty-object))))
(unless err
(send- socket
(send- kernel
"execute_result" `(("data" . (("text/plain" . ,result)))
("metadata" . ,empty-object)
("execution_count" . ,counter)))
(send- socket
("execution_count" . ,counter))
kernel-iopub)
(send- kernel
"execute_reply" `(("status" . "ok")
("execution_count" . ,counter)
("payload" . [])
("user_expressions" . ,empty-object))))
(send- socket
"guix-end-of-eval" `(("status" . "ok")))
(display ".")
counter))))
(define (reply-html-to-kernel socket message html count)
;; XXX: Here we have to create a fake kernel. bah.
(let* ((kernel (socket->kernel socket notebook-key))
(count (reply-html kernel message html count)))
(send-message kernel
(reply message "guix-end-of-eval"
(scm->json-string `(("status" . "ok")))))
count))
(define (kernel-info->shtml code)
(match (and=> (get-magic-line code) string-tokenize)
((_ "environment" name separator specs ...)
......@@ -204,61 +169,91 @@ KEY for signing."
;; Handler.
;;
(define (general-handler socket kernels count)
(let* ((parts (zmq-get-msg-parts-bytevector socket))
(message (parts->message parts))
(handler (dispatch (message-type message))))
(let-values (((containers count)
(handler socket message kernels count)))
(general-handler socket containers count))))
(define (general-handler kernel kind message state)
"Handle MESSAGE, which was sent by KERNEL, a client of ours, on KIND (one
of 'kernel-shell', 'kernel-stdin', etc.)"
(match state
((containers count)
(if (eq? kernel %main-kernel)
(let ((handler (dispatch (message-type message))))
;; Record the socket identity of our client so we can forward
;; shell messages to it.
(set! %main-kernel-id (message-sender message))
(let ((containers count (handler kernel kind message
containers count)))
(list containers count)))
;; This message is coming from one of our proxied kernels, so
;; forward it to our client.
(let ((id %main-kernel-id))
(format/log "forwarding ~s from ~s, socket ~s to ~s~%"
(message-type message) (kernel-pid kernel)
kind (bytevector->base16-string id))
(send-message %main-kernel message
#:kernel-socket kind
#:recipient id)
(list containers count))))))
;; Unknown request type, ignore it.
(define (ignore-request socket message kernels count)
(define (ignore-request kernel kind message kernels count)
(values kernels count))
(define (reply-execute-request socket message kernels count)
(define (execute-request-sans-magic message)
"Return MESSAGE, an 'execute_request' message, with its \"%guix\" magic
stripped."
(let* ((content (json-string->scm (message-content message)))
(code (assoc-ref content "code")))
(set-message-content message
(scm->json-string
`(("code" . ,(delete-magic code))
,@(alist-delete "code" content))))))
(define (reply-execute-request kernel kind message kernels count)
(format/log "handling execute-request~%")
(let ((code (assoc-ref (json-string->scm (message-content message))
"code")))
(cond
((magic-env? code)
(values kernels
(reply-html-to-kernel socket message
(kernel-info->html code)
count)))
(format/log "replying HTML for new environment~%")
(let ((count (reply-html kernel message (kernel-info->html code)
count)))
(values kernels count)))
((magic-run? code)
(values kernels
(local-eval socket message count)))
(local-eval kernel message count)))
((magic-kernel? code)
(let* ((name (magic-get-kernel-name code))
(kernel (kernel-by-name kernels name)))
(if kernel
(proxied (kernel-by-name kernels name))
(message (execute-request-sans-magic message)))
(if proxied
(begin
(relay-message (kernel-shell kernel)
(socket->kernel kernel notebook-key)
(string->utf8 name) message)
(send-message proxied message)
(values kernels (+ count 1)))
(let* ((new-kernel (run-kernel context
(find-kernel-specs name)
notebook-key
#:identity
(string->utf8 name)))
(kernel (socket->kernel socket notebook-key))
(new-kernels (register-kernel kernels new-kernel)))
(relay-message (kernel-shell new-kernel) kernel
(string->utf8 name) message)
(values new-kernels (+ count 1))))))
(match (find-kernel-specs name)
((? kernel-specs? specs)
(let* ((new-kernel (run-kernel %context specs
(generate-key)))
(new-kernels (register-kernel kernels name
new-kernel)))
(monitor-client new-kernel)
(send-message new-kernel message)
(values new-kernels (+ count 1))))
(#f
(reply-html kernel message '(b "No such kernel.")
count))))))
((magic-html? code)
(values kernels
(reply-html-to-kernel socket message
(delete-magic code)
count)))
(reply-html kernel message (delete-magic code)
count)))
(else
(values kernels
(local-eval socket message count))))))
(local-eval kernel message count))))))
(define (shutdown socket message kernels count)
(zmq-close-socket socket-shell)
(exit #t))
(define (shutdown kernel kind message kernels count)
;; TODO: (for-each close-kernel KERNELS)
(format/log "shutting down~%")
(leave-server-loop (list kernels count)))
;;
;; Dispatch route.
......@@ -281,4 +276,12 @@ KEY for signing."
;; Run.
;;
(general-handler socket-shell (alist->vhash '()) 0)
(match (command-line)
((_ name session-id connection)
(let* ((connection (json->connection (json-string->scm connection)))
(kernel (connection->kernel connection
#:context %context)))
(set! %main-kernel kernel)
(format/log "started proxy as PID ~a~%" (getpid))
(serve-kernels (list kernel) general-handler
(list vlist-null 0)))))
......@@ -19,9 +19,9 @@
(use-modules (json)
(simple-zmq)
(srfi srfi-1)
(srfi srfi-11)
(srfi srfi-13)
(srfi srfi-19)
(srfi srfi-71)
(rnrs bytevectors)
(ice-9 vlist)
(ice-9 futures)
......@@ -31,12 +31,18 @@
(gnu system file-systems)
(guix build syscalls)
(guix build utils)
(gcrypt base16)
(jupyter messages)
(jupyter kernels)
(jupyter servers)
(guix jupyter logging)
(guix-kernel magic)
(guix-kernel environ))
(define %main-kernel
;; This is the "main kernel"--i.e., our client.
#f)
(define session-id (random (* 255 255)
(seed->random-state
(time-second (current-time time-utc)))))
......@@ -84,20 +90,39 @@ acts as a proxy to an actual kernel."
;; Handlers.
;;
(define %main-kernel-id
;; "Identity" of our client to be used as the routing prefix on shell
;; sockets.
#f)
(define (general-handler kernel kind message state)
"Handle MESSAGE, which was sent by KERNEL, a client of ours, on KIND (one
of 'kernel-shell', 'kernel-stdin', etc.)"
(match state
((containers count)
(let ((handler (dispatch (message-type message))))
(pub-busy kernel message)
(let-values (((containers count)
(handler kernel message containers count)))
(pub-idle kernel message)
(list containers count))))))
(if (eq? kernel %main-kernel)
(let ((handler (dispatch (message-type message))))
;; Record the socket identity of our client so we can forward
;; shell messages to it.
(set! %main-kernel-id (message-sender message))
(let ((containers count (handler kernel kind message
containers count)))
(list containers count)))
;; This message is coming from one of our proxied kernels, so
;; forward it to our client.
(let ((id %main-kernel-id))
(format/log "forwarding ~s from ~s, socket ~s to ~s~%"
(message-type message) (kernel-pid kernel)
kind (bytevector->base16-string id))
(send-message %main-kernel message
#:kernel-socket kind
#:recipient id)
(list containers count))))))
;; Unknown request type, ignore it.
(define (ignore-request kernel message containers count)
(define (ignore-request kernel kind message containers count)
(values containers count))
(define KERNEL-INFO
......@@ -117,12 +142,12 @@ of 'kernel-shell', 'kernel-stdin', etc.)"
"https://gitlab.inria.fr/guix-hpc/guix-kernel")))))
;; Send kernel-info.
(define (reply-kernel-info-request kernel message containers count)
(define (reply-kernel-info-request kernel kind message containers count)
(send-message kernel (reply message "kernel_info_reply"
(scm->json-string KERNEL-INFO)))
(values containers count))
(define (reply-execute-request kernel message containers count)
(define (reply-execute-request kernel kind message containers count)
(let* ((content (message-content message))
(code (assoc-ref (json-string->scm content) "code"))
(magic (get-magic-line code)))
......@@ -130,32 +155,32 @@ of 'kernel-shell', 'kernel-stdin', etc.)"
(λ ()
(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 (proxy-by-name containers env-name)
(#f
(let* ((id (start-container kernel env-name env))
(container (new-container-connect env-name id))
(format/log "spawning container ~s~%" env-name)
(let* ((container (start-container container-context
env-name env))
(new (register-proxy containers env-name
container)))
(relay-message (kernel-shell container) kernel
(string->utf8 env-name)
message)
(monitor-client container)
(pub-idle kernel message)
(send-message container message)
(values new (+ count 1))))
((? kernel? proxy)
(relay-message (kernel-shell proxy) kernel
(string->utf8 env-name)
message)
(send-message kernel message)
(values containers (+ count 1))))))
((or (magic-run? code)
(magic-kernel? code))
(let* ((list (string-split magic #\ ))
(env-name (list-ref list 2))
(proxy (proxy-by-name containers env-name)))
(relay-message (kernel-shell proxy) kernel
(string->utf8 env-name)
message)
(format/log "evaluating code in container ~s (PID ~s)~%"
env-name (kernel-pid proxy))
(send-message proxy message)
(values containers (+ count 1))))
((magic-html? code)
(values containers
......@@ -163,19 +188,22 @@ of 'kernel-shell', 'kernel-stdin', etc.)"
(delete-magic code)
count)))
(else
(relay-message (kernel-shell
(proxy-by-name containers "default"))
kernel (string->utf8 "default")
message)
(let ((proxied (proxy-by-name containers "default")))
(format/log "evaluating code in default container (PID ~s)~%"
(kernel-pid proxied))
(send-message proxied message
#:kernel-socket kind))
(values containers (+ count 1)))))
(λ error
(values containers
(reply-html kernel message
(error->html error) count))))))
(define (shutdown kernel message containers count)
(define (shutdown kernel kind message containers count)
(format/log "shutting down ~a containers~%"
(vlist-length containers))
(kill-containers containers kernel message)
(exit #t))
(leave-server-loop #t))
;;
;; Dispatch route.
......@@ -204,12 +232,12 @@ of 'kernel-shell', 'kernel-stdin', etc.)"
MESSAGE."
(vlist-for-each (match-lambda
((name . proxy)
(format (current-error-port)
"terminating proxy ~s (PID ~s)...~%"
name (kernel-pid proxy))
(relay-message (kernel-shell proxy) kernel
(string->utf8 name) message)
(zmq-close-socket (kernel-shell proxy))
(format/log "terminating proxy ~s (PID ~s)...~%"
name (kernel-pid proxy))
;; Shutdown messages are sent on the control socket.
(send-message proxy message
#:kernel-socket kernel-control)
(close-kernel proxy)
(false-if-exception (kill (kernel-pid proxy) SIGTERM))))
containers))
......@@ -217,25 +245,6 @@ MESSAGE."
;; Run.
;;
(define (new-container-connect name pid)
"Return a kernel object for process PID."
(let* ((ipc-dir (string-append "/tmp/guix-kernel/ipc/" name "-"
(number->string session-id) "/"))
(container-addr (string-append "ipc://" ipc-dir))
(container-addr-sock (string-append container-addr "shell")))
(mkdir-p ipc-dir)
(let ((container-socket (zmq-create-socket container-context ZMQ_DEALER)))
(zmq-set-socket-option container-socket ZMQ_IDENTITY name)
(zmq-bind-socket container-socket container-addr-sock)
(display "+")
(kernel name pid
#:shell container-socket
#:iosub container-socket))))
(define %network-file-systems
;; The list of <file-system> objects corresponding to bind-mounts required
;; for networking.
......@@ -245,7 +254,10 @@ MESSAGE."
fs)))
%network-file-mappings))
(define (start-container kernel name env)
(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"))
......@@ -255,8 +267,11 @@ MESSAGE."
(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
;; (set-network-interface-up "lo") ;up lo interface
(apply execle guile-version
new-env
......@@ -266,7 +281,8 @@ MESSAGE."
(list "--no-auto-compile" "-s"
container-path
name (number->string session-id)
(utf8->string (kernel-key kernel)))))))
(scm->json-string
(connection->json connection)))))))
(root (string-append "/tmp/guix-kernel/container/"
name "-" (number->string session-id)))
(fs (cons* %immutable-store
......@@ -279,9 +295,14 @@ MESSAGE."
(append %container-file-systems
%network-file-systems))))
(mkdir-p root)
(run-container root fs
%namespaces 1
exec)))
(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))))