guix-jupyter-kernel.scm 10.4 KB
Newer Older
1
;;; Guix-kernel -- Guix kernel for Jupyter
2
3
4
;;; Copyright (C) 2018 Evgeny Panfilov <epanfilov@gmail.com>
;;; Copyright (C) 2018 Pierre-Antoine Rouby <pierre-antoine.rouby@inria.fr>
;;; Copyright (C) 2018 Inria
5
6
7
8
9
10
11
12
13
14
15
16
17
18
;;;
;;; 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/>.

19
20
(use-modules (json)
             (simple-zmq)
jerry40's avatar
jerry40 committed
21
	     (srfi srfi-1)
22
             (srfi srfi-11)
23
             (srfi srfi-13)
24
             (srfi srfi-19)
25
             (rnrs bytevectors)
26
             (ice-9 vlist)
27
28
             (ice-9 futures)
             (ice-9 match)
29
             (sxml simple)
30
31
32
             (gnu build linux-container)
             (gnu system file-systems)
             (guix build syscalls)
33
             (guix build utils)
34
             (jupyter messages)
35
             (jupyter kernels)
36
             (guix-kernel magic)
37
38
             (guix-kernel environ)
             (guix-kernel jupyter-client))
jerry40's avatar
jerry40 committed
39

40
41
42
(define session-id (random (* 255 255)
                           (seed->random-state
                            (time-second (current-time time-utc)))))
43

44
;;
45
;; Container tools.
46
47
;;

48
(define container-context (zmq-create-context))
49

50
(define container-path
51
52
  (string-replace (car (command-line)) "guix-jupyter-container.scm"
                  (+ (string-rindex (car (command-line)) #\/) 1)))
53

54
(define (register-proxy vhash name proxy)
55
56
  "Register PROXY, a kernel object for a process running in a container that
acts as a proxy to an actual kernel."
57
  (vhash-cons name proxy vhash))
58

59
60
61
62
(define (proxy-by-name vhash name)
  (match (vhash-assoc name vhash)
    ((_ . proxy) proxy)
    (#f #f)))
63

64

65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
;;
;; Html.
;;

(define (error->shtml error)
  (match error
    (('guix-kernel msg errno)
     `(h3 (@ (style "color: red;"))
          ,(string-append "Error: " msg)))
    (_
     `(h3 (@ (style "color: red;"))
          "Error !"))))

(define (error->html error)
  (call-with-output-string
    (lambda (port)
      (sxml->xml (error->shtml error) port))))

83
;;
84
;; Handlers.
85
86
;;

87
88
(define (heartbeat-handler kernel)
  (let ((message (zmq-message-receive-bytevector (kernel-heartbeat kernel)
89
                                                 (zmq-msg-init))))
90
91
    (zmq-message-send-bytevector (kernel-heartbeat kernel) message))
  (heartbeat-handler kernel))
jerry40's avatar
jerry40 committed
92

93

94
95
(define (general-handler kernel containers count)
  (let* ((message (read-message kernel))
Ludovic Courtès's avatar
Ludovic Courtès committed
96
         (handler (dispatch (message-type message))))
97
    (pub-busy kernel message)
Ludovic Courtès's avatar
Ludovic Courtès committed
98
    (let-values (((containers count)
99
100
101
                  (handler kernel message containers count)))
      (pub-idle kernel message)
      (general-handler kernel containers count))))
jerry40's avatar
jerry40 committed
102

103
;; Unknown request type, ignore it.
104
(define (ignore-request kernel message containers count)
105
  (values containers count))
jerry40's avatar
jerry40 committed
106

107
;; Send kernel-info.
108
109
(define (reply-kernel-info-request kernel message containers count)
  (send-message kernel (reply message "kernel_info_reply"
Ludovic Courtès's avatar
Ludovic Courtès committed
110
                                (scm->json-string KERNEL-INFO)))
111
  (values containers count))
112

113
(define (reply-execute-request kernel message containers count)
Ludovic Courtès's avatar
Ludovic Courtès committed
114
115
116
  (let* ((content (message-content message))
         (code    (hash-ref (json-string->scm content) "code"))
         (magic   (get-magic-line code)))
117
118
119
120
121
122
123
    (catch 'guix-kernel
      (λ ()
        (cond
         ((magic-env? code)
          (let* ((list     (string-split magic #\ ))
                 (env-name (list-ref list 2))
                 (env      (list-cdr-ref list 4)))
Ludovic Courtès's avatar
Ludovic Courtès committed
124
125
            (match (proxy-by-name containers env-name)
              (#f
126
               (let* ((id        (start-container kernel env-name env))
Ludovic Courtès's avatar
Ludovic Courtès committed
127
128
129
                      (container (new-container-connect env-name id))
                      (new       (register-proxy containers env-name
                                                 container)))
130
                 (relay-message (kernel-shell container) kernel
Ludovic Courtès's avatar
Ludovic Courtès committed
131
132
133
                                (string->utf8 env-name)
                                message)
                 (values new (+ count 1))))
134
135
              ((? kernel? proxy)
               (relay-message (kernel-shell proxy) kernel
Ludovic Courtès's avatar
Ludovic Courtès committed
136
137
138
                              (string->utf8 env-name)
                              message)
               (values containers (+ count 1))))))
139
140
141
         ((or (magic-run? code)
              (magic-kernel? code))
          (let* ((list     (string-split magic #\ ))
Ludovic Courtès's avatar
Ludovic Courtès committed
142
143
                 (env-name (list-ref list 2))
                 (proxy    (proxy-by-name containers env-name)))
144
            (relay-message (kernel-shell proxy) kernel
Ludovic Courtès's avatar
Ludovic Courtès committed
145
146
147
                           (string->utf8 env-name)
                           message)
            (values containers (+ count 1))))
148
149
         ((magic-html? code)
          (values containers
150
                  (reply-html kernel message
151
                              (delete-magic code)
Ludovic Courtès's avatar
Ludovic Courtès committed
152
                              count)))
153
         (else
154
          (relay-message (kernel-shell
Ludovic Courtès's avatar
Ludovic Courtès committed
155
                          (proxy-by-name containers "default"))
156
                         kernel (string->utf8 "default")
Ludovic Courtès's avatar
Ludovic Courtès committed
157
158
                         message)
          (values containers (+ count 1)))))
159
      (λ error
160
        (values containers
161
                (reply-html kernel message
Ludovic Courtès's avatar
Ludovic Courtès committed
162
163
                            (error->html error) count))))))

164
165
(define (shutdown kernel message containers count)
  (kill-containers containers kernel message)
166
  (exit #t))
jerry40's avatar
jerry40 committed
167

168
169
170
171
;;
;; Dispatch route.
;;

jerry40's avatar
jerry40 committed
172
173
174
175
(define dispatch-route
  `(("kernel_info_request" . ,reply-kernel-info-request)
    ("execute_request"     . ,reply-execute-request)
    ("shutdown_request"    . ,shutdown)
176
    ("comm_info_request"   . ,ignore-request)))
jerry40's avatar
jerry40 committed
177
178
179
180

(define (dispatch msg-type)
  (let ((res (assoc-ref dispatch-route msg-type)))
    (unless res
jerry40's avatar
jerry40 committed
181
      (display
182
183
       (string-append "\n(WW) unknown message type: "
                      msg-type "\n\n")))
jerry40's avatar
jerry40 committed
184
    (if res res ignore-request)))
jerry40's avatar
jerry40 committed
185

186
187
188
189
;;
;; Process exit and signals handler.
;;

190
(define (kill-containers containers kernel message)
191
  "Terminate all the proxies listed in the CONTAINERS vhash, sending them
Ludovic Courtès's avatar
Ludovic Courtès committed
192
MESSAGE."
193
194
195
196
  (vlist-for-each (match-lambda
                    ((name . proxy)
                     (format (current-error-port)
                             "terminating proxy ~s (PID ~s)...~%"
197
198
                             name (kernel-pid proxy))
                     (relay-message (kernel-shell proxy) kernel
Ludovic Courtès's avatar
Ludovic Courtès committed
199
                                    (string->utf8 name) message)
200
201
                     (zmq-close-socket (kernel-shell proxy))
                     (false-if-exception (kill (kernel-pid proxy) SIGTERM))))
202
                  containers))
203

204
205
206
207
;;
;; Run.
;;

208
(define (new-container-connect name pid)
209
  "Return a kernel object for process PID."
210
  (let* ((ipc-dir  (string-append "/tmp/guix-kernel/ipc/" name "-"
211
                                  (number->string session-id) "/"))
212
213
         (container-addr (string-append "ipc://" ipc-dir))
         (container-addr-sock (string-append container-addr "shell")))
214
215
216

    (mkdir-p ipc-dir)

217
    (let ((container-socket (zmq-create-socket container-context ZMQ_DEALER)))
Ludovic Courtès's avatar
Ludovic Courtès committed
218
      (zmq-set-socket-option container-socket ZMQ_IDENTITY name)
219

220
      (zmq-bind-socket container-socket container-addr-sock)
221
      (display "+")
222

223
224
225
      (kernel name pid
              #:shell container-socket
              #:iosub container-socket))))
226

227
228
229
230
231
232
233
234
(define %network-file-systems
  ;; The list of <file-system> objects corresponding to bind-mounts required
  ;; for networking.
  (filter-map (lambda (mapping)
                (let ((fs (file-system-mapping->bind-mount mapping)))
                  (and (file-exists? (file-system-device fs))
                       fs)))
              %network-file-mappings))
235

236
(define (start-container kernel name env)
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
  (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)))
         (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)
257
                                       (utf8->string (kernel-key kernel)))))))
258
259
         (root (string-append "/tmp/guix-kernel/container/"
                              name "-" (number->string session-id)))
260
261
262
263
264
265
266
267
268
         (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))))
269
270
271
272
    (mkdir-p root)
    (run-container root fs
                   %namespaces 1
                   exec)))
273

274
(define (start-kernel pid kernel)
275
  (let ((default-container (alist->vhash
276
                            `(("default" .
277
                               ,(new-container-connect "default" pid))))))
278
    (general-handler kernel default-container 0)))
279

280

281
(define (exit-handler kernel)
282
  (lambda _
283
    (close-kernel kernel)
284
285
    (exit 1)))

286
;; Start!
287
288
289
290
291
292
(let ((kernel (call-with-input-file (car (last-pair (command-line)))
                json->kernel)))
  (sigaction SIGTERM (exit-handler kernel))
  (sigaction SIGINT  (exit-handler kernel))
  (start-kernel (start-container kernel "default" '())
                kernel))