guix-jupyter-kernel.scm 10.8 KB
Newer Older
1
;;; Guix-kernel -- Guix kernel for Jupyter
2
3
;;; Copyright (C) 2018 Evgeny Panfilov <epanfilov@gmail.com>
;;; Copyright (C) 2018 Pierre-Antoine Rouby <pierre-antoine.rouby@inria.fr>
Ludovic Courtès's avatar
Ludovic Courtès committed
4
;;; Copyright (C) 2018, 2019 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)
Ludovic Courtès's avatar
Ludovic Courtès committed
36
             (jupyter servers)
37
             (guix-kernel magic)
Ludovic Courtès's avatar
Ludovic Courtès committed
38
             (guix-kernel environ))
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
89
90
91
92
93
94
95
96
97
(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))))))
jerry40's avatar
jerry40 committed
98

99
;; Unknown request type, ignore it.
100
(define (ignore-request kernel message containers count)
101
  (values containers count))
jerry40's avatar
jerry40 committed
102

Ludovic Courtès's avatar
Ludovic Courtès committed
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
(define KERNEL-INFO
  `(("protocol_version" . "5.3.0")
    ("implementation"   . "Guix Jupyter kernel")
    ("implementation_version" . "0.0.2")
    ("language_info" .
     (("name"     . "guile")
      ("version"  . ,(effective-version))
      ("mimetype" . "application/x-scheme")
      ("file_extension"  . ".scm")
      ("pygments_lexer"  . "scheme")
      ("codemirror_mode" . "scheme")))
    ("banner"     . "Guix kernel")
    ("help_links" .
     (("Gitlab Inria" .
       "https://gitlab.inria.fr/guix-hpc/guix-kernel")))))

119
;; Send kernel-info.
120
121
(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
122
                              (scm->json-string KERNEL-INFO)))
123
  (values containers count))
124

125
(define (reply-execute-request kernel message containers count)
Ludovic Courtès's avatar
Ludovic Courtès committed
126
  (let* ((content (message-content message))
Ludovic Courtès's avatar
Ludovic Courtès committed
127
         (code    (assoc-ref (json-string->scm content) "code"))
Ludovic Courtès's avatar
Ludovic Courtès committed
128
         (magic   (get-magic-line code)))
129
130
131
132
133
134
135
    (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
136
137
            (match (proxy-by-name containers env-name)
              (#f
138
               (let* ((id        (start-container kernel env-name env))
Ludovic Courtès's avatar
Ludovic Courtès committed
139
140
141
                      (container (new-container-connect env-name id))
                      (new       (register-proxy containers env-name
                                                 container)))
142
                 (relay-message (kernel-shell container) kernel
Ludovic Courtès's avatar
Ludovic Courtès committed
143
144
145
                                (string->utf8 env-name)
                                message)
                 (values new (+ count 1))))
146
147
              ((? kernel? proxy)
               (relay-message (kernel-shell proxy) kernel
Ludovic Courtès's avatar
Ludovic Courtès committed
148
149
150
                              (string->utf8 env-name)
                              message)
               (values containers (+ count 1))))))
151
152
153
         ((or (magic-run? code)
              (magic-kernel? code))
          (let* ((list     (string-split magic #\ ))
Ludovic Courtès's avatar
Ludovic Courtès committed
154
155
                 (env-name (list-ref list 2))
                 (proxy    (proxy-by-name containers env-name)))
156
            (relay-message (kernel-shell proxy) kernel
Ludovic Courtès's avatar
Ludovic Courtès committed
157
158
159
                           (string->utf8 env-name)
                           message)
            (values containers (+ count 1))))
160
161
         ((magic-html? code)
          (values containers
162
                  (reply-html kernel message
163
                              (delete-magic code)
Ludovic Courtès's avatar
Ludovic Courtès committed
164
                              count)))
165
         (else
166
          (relay-message (kernel-shell
Ludovic Courtès's avatar
Ludovic Courtès committed
167
                          (proxy-by-name containers "default"))
168
                         kernel (string->utf8 "default")
Ludovic Courtès's avatar
Ludovic Courtès committed
169
170
                         message)
          (values containers (+ count 1)))))
171
      (λ error
172
        (values containers
173
                (reply-html kernel message
Ludovic Courtès's avatar
Ludovic Courtès committed
174
175
                            (error->html error) count))))))

176
177
(define (shutdown kernel message containers count)
  (kill-containers containers kernel message)
178
  (exit #t))
jerry40's avatar
jerry40 committed
179

180
181
182
183
;;
;; Dispatch route.
;;

jerry40's avatar
jerry40 committed
184
185
186
187
(define dispatch-route
  `(("kernel_info_request" . ,reply-kernel-info-request)
    ("execute_request"     . ,reply-execute-request)
    ("shutdown_request"    . ,shutdown)
188
    ("comm_info_request"   . ,ignore-request)))
jerry40's avatar
jerry40 committed
189
190
191
192

(define (dispatch msg-type)
  (let ((res (assoc-ref dispatch-route msg-type)))
    (unless res
jerry40's avatar
jerry40 committed
193
      (display
194
195
       (string-append "\n(WW) unknown message type: "
                      msg-type "\n\n")))
jerry40's avatar
jerry40 committed
196
    (if res res ignore-request)))
jerry40's avatar
jerry40 committed
197

198
199
200
201
;;
;; Process exit and signals handler.
;;

202
(define (kill-containers containers kernel message)
203
  "Terminate all the proxies listed in the CONTAINERS vhash, sending them
Ludovic Courtès's avatar
Ludovic Courtès committed
204
MESSAGE."
205
206
207
208
  (vlist-for-each (match-lambda
                    ((name . proxy)
                     (format (current-error-port)
                             "terminating proxy ~s (PID ~s)...~%"
209
210
                             name (kernel-pid proxy))
                     (relay-message (kernel-shell proxy) kernel
Ludovic Courtès's avatar
Ludovic Courtès committed
211
                                    (string->utf8 name) message)
212
213
                     (zmq-close-socket (kernel-shell proxy))
                     (false-if-exception (kill (kernel-pid proxy) SIGTERM))))
214
                  containers))
215

216
217
218
219
;;
;; Run.
;;

220
(define (new-container-connect name pid)
221
  "Return a kernel object for process PID."
222
  (let* ((ipc-dir  (string-append "/tmp/guix-kernel/ipc/" name "-"
223
                                  (number->string session-id) "/"))
224
225
         (container-addr (string-append "ipc://" ipc-dir))
         (container-addr-sock (string-append container-addr "shell")))
226
227
228

    (mkdir-p ipc-dir)

229
    (let ((container-socket (zmq-create-socket container-context ZMQ_DEALER)))
Ludovic Courtès's avatar
Ludovic Courtès committed
230
      (zmq-set-socket-option container-socket ZMQ_IDENTITY name)
231

232
      (zmq-bind-socket container-socket container-addr-sock)
233
      (display "+")
234

235
236
237
      (kernel name pid
              #:shell container-socket
              #:iosub container-socket))))
238

239
240
241
242
243
244
245
246
(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))
247

248
(define (start-container kernel name env)
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
  (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)
269
                                       (utf8->string (kernel-key kernel)))))))
270
271
         (root (string-append "/tmp/guix-kernel/container/"
                              name "-" (number->string session-id)))
272
273
274
275
276
277
278
279
280
         (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))))
281
282
283
284
    (mkdir-p root)
    (run-container root fs
                   %namespaces 1
                   exec)))
285

286

287
(define (exit-handler kernel)
288
  (lambda _
289
    (close-kernel kernel)
290
291
    (exit 1)))

292
;; Start!
293
(let ((kernel (call-with-input-file (car (last-pair (command-line)))
Ludovic Courtès's avatar
Ludovic Courtès committed
294
                connection-file->kernel)))
295
296
  (sigaction SIGTERM (exit-handler kernel))
  (sigaction SIGINT  (exit-handler kernel))
297
298
299
300
301
302
303
304

  (let* ((pid        (start-container kernel "default" '()))
         (containers (vhash-cons "default"
                                 (new-container-connect "default" pid)
                                 vlist-null)))
   (serve-kernels (list kernel)
                  general-handler
                  (list containers 0))))