guix-jupyter-kernel.scm 31.5 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, 2020, 2021 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/>.

Ludovic Courtès's avatar
Ludovic Courtès committed
19
20
(use-modules (json parser)
             (json builder)
21
             (simple-zmq)
Ludovic Courtès's avatar
Ludovic Courtès committed
22
             (git)                                ;for 'git-error-message'
jerry40's avatar
jerry40 committed
23
	     (srfi srfi-1)
24
             (srfi srfi-13)
25
             (srfi srfi-19)
26
             (srfi srfi-26)
27
             (srfi srfi-34)
28
             (srfi srfi-71)
29
             (rnrs bytevectors)
30
             (ice-9 match)
31
32
             (texinfo)
             (texinfo html)
33
             (guix build syscalls)
34
35
             (guix gexp)
             (guix store)
Ludovic Courtès's avatar
Ludovic Courtès committed
36
             (guix channels)
37
             (guix download)
38
             (guix derivations)
Ludovic Courtès's avatar
Ludovic Courtès committed
39
             (guix inferior)
40
41
             (guix monads)
             (guix profiles)
42
             ((guix i18n) #:select (P_))
43
             (gcrypt base16)
44
             (gcrypt hash)
45
             (jupyter messages)
46
             (jupyter kernels)
Ludovic Courtès's avatar
Ludovic Courtès committed
47
             (jupyter servers)
48
             (jupyter guile)
49
             (guix jupyter logging)
50
             (guix jupyter proxy)
51
             (guix jupyter kernel)
52
             (guix jupyter environment))
jerry40's avatar
jerry40 committed
53

54
;;
55
;; Container tools.
56
57
;;

58
(define container-context (zmq-create-context))
59

60
61
62
63
64
65
66
(define %store-property
  ;; Key used to access the <store-connection> in <proxy-state>.
  (list 'store 'property))

(define (proxy-state-store state)
  "Return the <store-connection> associated with STATE."
  (proxy-state-property state %store-property))
67

68
69
70
71
72
73
74
75
76
77
78
79
80
(define %default-environment-property
  ;; Key used to access the name of the default environment.
  (list 'environment 'property))

(define (proxy-state-default-environment state)
  "Return the name of the default execution environment or #f."
  (proxy-state-property state %default-environment-property))

(define (set-proxy-state-default-environment state name)
  "Use NAME as the default environment."
  (set-proxy-state-property state %default-environment-property
                            name))

81
82
83
84
85
86
87
88
89
90
91
92
93
(define %inferior-property
  ;; Property to access the inferior associated with this proxy.
  (list 'inferior 'property))

(define (proxy-state-inferior state)
  "Return the inferior associated with STATE, or #f if there is none."
  (proxy-state-property state %inferior-property))

(define (set-proxy-state-inferior state inferior)
  "Associate STATE with INFERIOR and return the new proxy state.  If there
was already an inferior associated with STATE, close it."
  (let ((previous (proxy-state-inferior state)))
    (when previous
94
95
96
97
98
99
100
101
      ;; XXX: 'close-inferior' sometimes isn't enough and it ends up being
      ;; blocked in waitpid(2) (from 'close-pipe') while the inferior is
      ;; stuck in read(2).  Thus, forcefully terminate PREVIOUS beforehand.
      ;; This leads to an 'inferior-eval' exception because the inferior
      ;; doesn't respond, which we catch.
      (false-if-exception
       (inferior-eval '(primitive-exit 0) previous))

102
      (close-inferior previous))
103

104
105
106
107
108
109
110
111
112
    (set-proxy-state-property state %inferior-property
                              inferior)))

(define (ensure-proxy-state-inferior state)
  "Return a new state based on STATE that has an associated inferior."
  (if (proxy-state-inferior state)
      state
      (set-proxy-state-inferior state (open-default-inferior))))

113
;;
114
;; Handlers.
115
116
;;

117
;; Unknown request type, ignore it.
118
119
(define (ignore-request kernel kind message state)
  state)
jerry40's avatar
jerry40 committed
120

121
;; Send kernel-info.
122
(define (reply-kernel-info-request kernel kind message state)
123
124
125
126
127
128
129
  (let ((body (scm->json-string
               (kernel-info-reply->json %kernel-info-reply))))
    (send-message kernel (reply message "kernel_info_reply" body))

    ;; Send an IOPub message as expected by Notebook 6.3.0 (failing to do
    ;; that, it "nudges" the kernel by re-sending "kernel_info_request"
    ;; messages).
130
    (pub-idle kernel message))
131
  state)
132

133
134
135
136
137
138
139
140
141
142
143
144
145
146
(define (manifest->shtml manifest name)
  "Return SHTML representing the contents of MANIFEST."
  `(div
    (h3 (@ (style "color: green;"))
        "Preparing environment " (tt ,name) " with these packages:")
    (ul ,@(map (lambda (entry)
                 `(li (tt ,(manifest-entry-name entry)
                          " " ,(manifest-entry-version entry))))
               (manifest-entries manifest)))))

(define* (reply-for-environment kernel message
                                #:key name manifest (count 0))
  "Send KERNEL a reply to MESSAGE saying that we're preparing environment
NAME with MANIFEST."
147
148
149
  (reply-shtml kernel message
               (manifest->shtml manifest name)
               count))
150

151
152
153
154
155
156
157
158
(define* (reply-for-environment-kernel kernel message
                                       #:key name specs (count 0))
  "Send KERNEL a reply to MESSAGE saying that we found the kernel SPECS."
  (send-message kernel
                (reply message "execute_result"
                       (scm->json-string
                        `(("data"     .
                           (("text/html"
159
                             . ,(sxml->xml-string
160
161
162
163
164
165
166
167
                                 `(div
                                   "Running "
                                   ,(kernel-specs-display-name specs)
                                   " kernel.")))))
                          ("metadata" . ())
                          ("execution_count" . ,count))))
                #:kernel-socket kernel-iopub))

Ludovic Courtès's avatar
Ludovic Courtès committed
168
169
(define (channels->shtml channels)
  "Return SHTML representing CHANNELS."
170
171
172
173
174
175
176
177
  `(p (table
       ,@(map (lambda (channel)
                `(tr (tc (a (@ (href ,(channel-url channel)))
                            (code ,(channel-name channel))))
                     (tc (code ,(if (channel-commit channel)
                                    (channel-commit-hyperlink channel)
                                    (channel-branch channel))))))
              channels))))
Ludovic Courtès's avatar
Ludovic Courtès committed
178
179

(define* (reply-for-channels kernel message channels
180
181
182
183
184
185
186
187
                             #:key profile (count 0))
  "Reply to MESSAGE, which comes from KERNEL, that we successfully switched
to CHANNELS in PROFILE."
  (let ((instances (if profile
                       (match (profile-channels profile)
                         (()  channels)
                         (lst lst))
                       channels)))
188
    (reply-shtml kernel message
189
190
                 `(div
                   (bold "Switched to these Guix channels:")
191
192
                   ,(channels->shtml instances))
                 count)))
193

194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
(define* (search-inferior-packages inferior patterns
                                   #:key (max-results 20))
  "Return the list of name/version/synopsis tuples for the most relevant
packages matching PATTERNS, a list of string (possibly regexps).  Return at
most MAX-RESULTS elements."
  ;; Perform search in the inferior to reduce communication between the host
  ;; and the inferior, and to avoid allocating memory on both sides.
  (inferior-eval
   `(begin
      (use-modules ((guix ui) #:select (package-relevance))
                   (ice-9 regex)
                   (ice-9 match)
                   (srfi srfi-1)
                   (srfi srfi-26))

      (define regexps
        (map (cut make-regexp <> regexp/icase) ',patterns))

      (define (find-packages-by-description regexps)
        ;; XXX: Copied from (guix scripts package).
        (let ((matches (fold-packages
                        (lambda (package result)
                          (if (package-superseded package)
                              result
                              (match (package-relevance package regexps)
                                ((? zero?) result)
                                (score
                                 (cons (cons package score) result)))))
                        '())))
          (sort matches
                (lambda (m1 m2)
                  (match m1
                    ((package1 . score1)
                     (match m2
                       ((package2 . score2)
                        (if (= score1 score2)
                            (string>? (package-full-name package1)
                                      (package-full-name package2))
                            (> score1 score2))))))))))

      (let ((lst (find-packages-by-description regexps)))
        (map (match-lambda
               ((package . score)
                (list (package-name package) (package-version package)
                      (package-synopsis package))))
             (if (> (length lst) ,max-results)
                 (take lst ,max-results)
                 lst))))
   inferior))

(define* (reply-search-results kernel message inferior patterns
                               #:key (count 0))
  "Send to KERNEL a reply to MESSAGE showing search results for PATTERNS, a
list of regular expressions (strings)."
  (define (url package)
    (string-append "https://hpc.guix.info/package/" package))

  (define (ref package)
    `(a (@ (href ,(url package))) ,package))

  (define (synopsis->shtml synopsis)
    ;; 'texi-fragment->stexi' uses 'call-with-input-string', so make sure
    ;; those string ports are Unicode-capable.
    (with-fluids ((%default-port-encoding "UTF-8"))
      (and=> synopsis
             (compose stexi->shtml texi-fragment->stexi P_))))

  (catch 'regular-expression-syntax
    (lambda ()
      ;; Ensure PATTERNS are valid regexps.
      (for-each (cut make-regexp <> regexp/icase) patterns)

      (let ((lst (search-inferior-packages inferior patterns)))
267
        (reply-shtml kernel message
268
269
270
271
272
                     `(p (table
                          ,@(map (match-lambda
                                   ((name version synopsis)
                                    `(tr (td ,(ref name)) (td ,version)
                                         (td ,(synopsis->shtml synopsis)))))
273
274
                                 lst)))
                     count)))
275
    (lambda (key . args)
276
      (reply-shtml kernel message
277
                   `(div (@ (class "ansi-red-fg"))
278
279
                         "Invalid regular expression.")
                   count))))
280

281
282
283
284
285
286
287
288
289
(define* (reply-channel-description kernel message inferior
                                    #:key (count 0))
  "Reply to MESSAGE, which comes from KERNEL, with a description of the
channels currently used by INFERIOR."
  (let* ((profile  (inferior-eval '(begin
                                     (use-modules (guix describe))
                                     (current-profile))
                                  inferior))
         (channels (profile-channels profile)))
290
    (reply-shtml kernel message
291
292
                 `(div
                   (bold "Using these Guix channels:")
293
294
                   ,(channels->shtml channels))
                 count)))
Ludovic Courtès's avatar
Ludovic Courtès committed
295
296
297
298

(define* (reply-for-channel-failure kernel message channels error
                                    #:key (count 0))
  "Send KERNEL a reply saying we failed to switch to CHANNELS."
299
300
301
302
  (reply-shtml kernel message
               (string-append "Failed to switch to channels: "
                              (git-error-message error) ".")
               count))
Ludovic Courtès's avatar
Ludovic Courtès committed
303

304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
(define (link/copy source target)
  "Make the file SOURCE available as TARGET, either by creating a hard link
or otherwise by copying it.  If TARGET already exists, delete it."
  (catch 'system-error
    (lambda ()
      (link source target))
    (lambda args
      (cond ((= EXDEV (system-error-errno args))
             (copy-file source target)
             (utime target 1 1 1 1))
            ((= EEXIST (system-error-errno args))
             (delete-file target)
             (link/copy source target))
            (else
             (apply throw args))))))

(define* (handle-download kernel kind message state
                          #:key
                          url (hash-algo "sha256") hash
                          (file (basename url)))
  "Handle a request to download FILE from URL, which should have the given
HASH of type HASH-ALGO."
  (define algo
    (lookup-hash-algorithm (string->symbol hash-algo)))

  (define hash/bv
330
    (false-if-exception (base16-string->bytevector hash)))
331
332
333
334
335

  (define count
    (proxy-state-execution-count state))

  (cond ((not algo)
336
337
338
         (reply-shtml kernel message
                      `(bold "Unknown hash algorithm.")
                      count)
339
340
         state)
        ((not hash/bv)
341
342
343
         (reply-shtml kernel message
                      `(bold "Invalid hexadecimal string.")
                      count)
344
345
         state)
        ((not (= (bytevector-length hash/bv) (hash-size algo)))
346
347
348
         (reply-shtml kernel message
                      '(bold "Invalid hash length.")
                      count)
349
350
         state)
        ((not (proxy-state-default-environment state))
351
352
353
         (reply-shtml kernel message
                      '(bold "No current environment to download to.")
                      count))
354
355
        (else
         (guard (c ((store-protocol-error? c)
356
357
358
                    (reply-shtml kernel message
                                 `(bold ,(store-protocol-error-message c))
                                 count)
359
360
361
362
363
364
365
                    state))
           (format/log "downloading from '~a'...~%" url)
           (let* ((store       (proxy-state-store state))
                  (item        (run-with-store store
                                 (mlet %store-monad
                                     ((drv (url-fetch url (string->symbol hash-algo)
                                                      hash/bv file)))
366
367
368
369
370
371
                                   (if (derivation? drv)
                                       (mbegin %store-monad
                                         (built-derivations (list drv))
                                         (return
                                          (derivation->output-path drv)))
                                       (return drv))))) ;plain file
372
373
374
375
376
377
                  (environment (proxy-state-default-environment state))
                  (target      (lookup-proxied environment state))
                  (home        (assq-ref (kernel-properties target) 'home)))
             (format/log "copying '~a' to '~a/~a'~%"
                         item home file)
             (link/copy item (string-append home "/" file))
378
             (reply-shtml kernel message
379
380
381
382
                          `(bold "File " (code ,file)
                                 " from "
                                 (a (@ (href ,url)) ,url)
                                 " is now available in environment "
383
384
                                 (code ,environment) ".")
                          count)
385
386
             (increment-execution-count state))))))

387
388
389
390
391
392
(define* (create-environment name specs state
                             #:key kernel message)
  "Spawn a new execution environment called NAME and containing SPECS, a list
of package specifications such as \"guile@2.2\".  Send appropriate messages
to KERNEL as a reply to MESSAGE, and return STATE suitably adjusted."
  (define manifest
393
394
    (specifications->manifest (proxy-state-inferior state)
                              specs))
395

396
397
398
399
400
401
  (define store
    (proxy-state-store state))

  (define counter
    (proxy-state-execution-count state))

402
403
404
405
406
407
  (format/log "creating new environment ~s~%" name)

  ;; Reply right away without waiting for the profile to be built.
  (reply-for-environment kernel message
                         #:name name
                         #:manifest manifest
408
409
                         #:count counter)

410
411
412
413
414
415
  (let ((profile (with-build-progress-report kernel message
                   (run-with-store store
                     (mlet %store-monad ((drv (profile-derivation manifest)))
                       (mbegin %store-monad
                         (built-derivations (list drv)) ;XXX: somewhat ugly
                         (return drv)))))))
416
417
418
419
420
    (match (available-kernel-specs (derivation->output-path profile)
                                   (list (string-append
                                          (derivation->output-path profile)
                                          "/share/jupyter")))
      ((specs)
421
       (let* ((container (run-with-store store
422
423
                           (spawn-kernel/container container-context
                                                   profile)))
424
425
426
427
428
429
430
431
432
              (state     (register-proxied name container state)))
         (monitor-client container)
         (reply-for-environment-kernel kernel message
                                       #:name name
                                       #:specs specs
                                       #:count counter)
         (set-proxy-state-default-environment (increment-execution-count state)
                                              name)))
      (()
433
       (reply-shtml kernel message
434
                    `(bold "No kernel found in environment "
435
436
                           (code ,name) "!")
                    counter)
437
438
439
       ;; TODO: Send "error".
       state)
      ((lst ...)
440
       (reply-shtml kernel message
441
442
443
444
                    `(div
                      (bold "Found " ,(length lst)
                            " kernels in environment "
                            (code ,name) ":")
445
                      (ul ,@(map (lambda (specs)
446
                                   `(li ,(kernel-specs-display-name specs)))
447
448
                                 lst))
                      "Which one should we use?  Please create an "
449
450
                      "environment containing exactly one kernel.")
                    counter)
451
452
       ;; TODO: Send "error".
       state))))
453

454
455
456
457
458
459
460
461
462
463
464
465
466
467

(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"))
         (stripped (string-drop code
                                (or (string-index code #\newline)
                                    (string-length code)))))
    (set-message-content message
                         (scm->json-string
                          `(("code" . ,stripped)
                            ,@(alist-delete "code" content))))))

468
(define (reply-execute-request kernel kind message state)
469
470
  (let* ((request (json->execute-request (message-content message)))
         (code    (execute-request-code request))
471
472
473
         (line    (string-take code
                               (or (string-index code #\newline)
                                   (string-length code))))
474
         (count   (proxy-state-execution-count state)))
475
476
477
    (pub-busy kernel message)
    (match (string-tokenize line)
      ((";;guix" "environment" name "<-" specs ...)
478
479
       (guard (c ((package-not-found-error? c)
                  (let ((package (package-not-found-error-name c)))
480
                    (reply-shtml kernel message
481
482
                                 `(div (@ (class "ansi-red-fg"))
                                       "Package " (code ,package)
483
                                       " not found.")
484
485
486
487
488
                                count))
                  state)
                 ((output-not-found-error? c)
                  (let ((output  (output-not-found-error-output c))
                        (package (output-not-found-error-package c)))
489
                    (reply-shtml kernel message
490
491
492
                                 `(div (@ (class "ansi-red-fg"))
                                       "Output " (code ,output)
                                       " of package " (code ,package)
493
494
                                       " not found.")
                                 count)
495
496
497
498
499
500
501
                    state))
                 ((store-protocol-error? c)
                  (let ((string (store-protocol-error-message c)))
                    (reply-shtml kernel message
                                 `(div (@ (class "ansi-red-fg"))
                                       "Error: " ,string)
                                 count)
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
                    state)))
         (let ((state (ensure-proxy-state-inferior state)))
           (match (lookup-proxied name state)
             (#f
              (create-environment name specs state
                                  #:kernel kernel
                                  #:message message))
             ((? kernel? proxy)
              (format/log "terminating existing '~a' environment~%"
                          name)
              (unmonitor-client proxy)
              (terminate-proxied-kernel proxy)
              (create-environment name specs
                                  (unregister-proxied name state)
                                  #:kernel kernel
                                  #:message message))))))
518
519
520
      ((";;guix" "environment" name)
       (match (lookup-proxied name state)
         (#f
521
522
523
          (reply-shtml kernel message
                       `(bold "Unknown environment " (code ,name) ".")
                       count)
524
525
526
527
          (increment-execution-count state))
         ((? kernel? proxy)
          (format/log "evaluating code in container ~s (PID ~s)~%"
                      name (kernel-pid proxy))
528
          (send-message proxy (execute-request-sans-magic message))
529
530
          (let ((state (increment-execution-count state)))
            (set-proxy-state-default-environment state name)))))
531
532
533
534
535
536
      ((";;guix" "search" patterns ...)
       (let* ((state    (ensure-proxy-state-inferior state))
              (inferior (proxy-state-inferior state)))
         (reply-search-results kernel message inferior patterns
                               #:count count)
         (increment-execution-count state)))
537
538
539
540
541
542
543
      ((";;guix" "describe")
       (let* ((state    (ensure-proxy-state-inferior state))
              (inferior (proxy-state-inferior state)))
         (reply-channel-description kernel message
                                    (proxy-state-inferior state)
                                    #:count count)
         (increment-execution-count state)))
Ludovic Courtès's avatar
Ludovic Courtès committed
544
545
546
547
548
549
550
551
552
553
554
      ((";;guix" "pin" commit)
       (let ((count    (proxy-state-execution-count state))
             (channels (map (lambda (ch)
                              (if (guix-channel? ch)
                                  (channel (inherit ch)
                                           (commit commit))
                                  ch))
                            %default-channels)))
         (format/log "pinning to these channels: ~s~%" channels)
         (catch 'git-error
           (lambda ()
555
556
557
558
             (let* ((store    (proxy-state-store state))
                    (profile  (with-build-progress-report kernel message
                                (cached-channel-instance store channels)))
                    (inferior (open-inferior profile)))
Ludovic Courtès's avatar
Ludovic Courtès committed
559
               (reply-for-channels kernel message channels
560
                                   #:profile profile
Ludovic Courtès's avatar
Ludovic Courtès committed
561
562
563
564
565
566
567
                                   #:count count)
               (set-proxy-state-inferior (increment-execution-count state)
                                         inferior)))
           (lambda (key error . rest)
             (reply-for-channel-failure kernel message channels error
                                        #:count count)
             state))))
568
569
570
571
572
573
574
575
576
577
      ((";;guix" "download" url hash)
       (handle-download kernel kind message state
                        #:url url #:hash hash))
      ((";;guix" "download" url algo hash)
       (handle-download kernel kind message state
                        #:url url #:hash-algo algo #:hash hash))
      ((";;guix" "download" url algo hash "->" file)
       (handle-download kernel kind message state
                        #:url url #:hash-algo algo #:hash hash
                        #:file file))
578
      ((";;guix" _ ...)
579
580
581
       (reply-shtml kernel message
                    `(bold "Invalid " (code "guix") " magic.")
                    count)
582
583
584
585
586
587
588
589
590
591
       (increment-execution-count state))
      (_
       (match (proxy-state-default-environment state)
         ((? string? environment)
          (let ((proxied (lookup-proxied environment state)))
            (format/log "evaluating code in environment ~s (PID ~s)~%"
                        environment (kernel-pid proxied))
            (send-message proxied message #:kernel-socket kind)
            (increment-execution-count state)))
         (#f
592
          (reply-shtml kernel message
593
                       `(div "You have not selected an execution environment
594
yet.  You can create one by entering a “magic command” in a cell as follows:"
595
                             (p (code ";;guix environment my-environment <- \
596
597
python-ipykernel"))
                             "Subsequent cells will be executed by the "
598
599
                             "IPython kernel in this environment.")
                       count)
600
          state))))))
Ludovic Courtès's avatar
Ludovic Courtès committed
601

602
603
604
605
606
(define (environment-from-magic line)
  (match (string-tokenize line)
    ((";;guix" "environment" name) name)
    (_ #f)))

607
608
(define %magic-commands
  ;; The ";;guix" magic commands.
609
  '("describe" "download" "environment" "pin" "search"))
610

611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
(define (reply-complete-request kernel kind message state)
  "Reply to a \"complete_request\" message--i.e., a completion request.
Return STATE."
  (define (send-completion-reply matches start end)
    (format/log "sending completion reply with ~a matches~%"
                (length matches))
    (send-message kernel
                  (reply message "complete_reply"
                         (scm->json-string
                          `(("matches" . ,(list->vector matches))
                            ("cursor_start" . ,start)
                            ("cursor_end" . ,end)
                            ("metadata" . ())
                            ("status" . "ok"))))
                  #:recipient (message-sender message)))

  (let* ((content   (json-string->scm (message-content message)))
         (code      (assoc-ref content "code"))
         (cursor    (assoc-ref content "cursor_pos"))
         (line-end  (or (string-index code #\newline)
                        (string-length code)))
         (first     (string-take code line-end)))
    (if (and (string-prefix? ";;guix" (string-trim first))
             (<= cursor line-end))

        ;; This is a completion request on a ";;guix" magic.
        (match (string-split (string-take first cursor) #\space)
          ((";;guix" command)
639
640
           (send-completion-reply (filter (cut string-prefix? command <>)
                                          %magic-commands)
641
                                  (- cursor (string-length command))
642
643
                                  cursor)
           state)
644
645
646
647
648
649
          ((";;guix" "environment" prefix)
           (match (proxy-state-proxied state)
             (((names . _) ...)
              (send-completion-reply (filter (cut string-prefix? prefix <>)
                                             names)
                                     (- cursor (string-length prefix))
650
651
                                     cursor)
              state)))
Ludovic Courtès's avatar
Ludovic Courtès committed
652
          ((";;guix" "environment" _ "<-" _ ... prefix)
653
654
655
656
657
658
659
660
661
           (let* ((state    (ensure-proxy-state-inferior state))
                  (inferior (proxy-state-inferior state)))
             (match (inferior-available-packages inferior)
               (((names . _) ...)
                (send-completion-reply (filter (cut string-prefix? prefix <>)
                                               names)
                                       (- cursor (string-length prefix))
                                       cursor)))
             state))
662
663
          (_
           (format/log "ignoring completion request~%")
664
           state))
665
666
667
668
669
670
671
672
673

        ;; Pass the completion request to one of the proxied kernels.
        (match (or (environment-from-magic first)
                   (proxy-state-default-environment state))
          ((? string? environment)
           (let ((proxied (lookup-proxied environment state)))
             (format/log "forwarding completion request to \
environment ~s (PID ~s)~%"
                         environment (kernel-pid proxied))
674
675
             (send-message proxied message #:kernel-socket kind)
             state))
676
          (#f
677
678
           (format/log "unknown target kernel for completion request~%")
           state)))))
679

680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
(define (reply-inspect-request kernel kind message state)
  "Handle MESSAGE, an \"inspect_request\" message, possibly by forwarding it
to a proxied kernel.  Return STATE."
  (let* ((request   (json->inspect-request (message-content message)))
         (code      (inspect-request-code request))
         (cursor    (inspect-request-cursor-position request))
         (line-end  (or (string-index code #\newline)
                        (string-length code)))
         (first     (string-take code line-end)))
    (if (and (string-prefix? ";;guix" (string-trim first))
             (<= cursor line-end))
        (begin
          (format/log "ignoring inspection request on magic line~%")
          (send-message kernel
                        (reply message "inspect_reply"
                               (scm->json-string
                                (inspect-reply->json
                                 (inspect-reply (status 'ok) (found? #f)))))))

        ;; Pass the completion request to one of the proxied kernels.
        (match (or (environment-from-magic first)
                   (proxy-state-default-environment state))
          ((? string? environment)
           (let ((proxied (lookup-proxied environment state)))
             (format/log "forwarding inspection request to \
environment ~s (PID ~s)~%"
                         environment (kernel-pid proxied))
             (send-message proxied message #:kernel-socket kind)))
          (#f
           (format/log "unknown target kernel for completion request~%"))))
    state))

712
(define (shutdown kernel kind message state)
713
  (format/log "shutting down ~a containers~%"
714
715
              (proxy-state-proxied-number state))
  (leave-server-loop (terminate-proxied-kernels message state)))
jerry40's avatar
jerry40 committed
716

717
718
719
720
;;
;; Dispatch route.
;;

jerry40's avatar
jerry40 committed
721
722
723
724
(define dispatch-route
  `(("kernel_info_request" . ,reply-kernel-info-request)
    ("execute_request"     . ,reply-execute-request)
    ("shutdown_request"    . ,shutdown)
725
    ("complete_request"    . ,reply-complete-request)
726
    ("inspect_request"     . ,reply-inspect-request)
727
    ("comm_info_request"   . ,ignore-request)))
jerry40's avatar
jerry40 committed
728

729
730
731
732
;;
;; Run.
;;

733

734
(define (exit-handler kernel)
735
  (lambda _
736
    (close-kernel kernel)
737
738
    (exit 1)))

739
;; Start!
740
(let ((kernel (call-with-input-file (car (last-pair (command-line)))
Ludovic Courtès's avatar
Ludovic Courtès committed
741
                connection-file->kernel)))
742
743
  (sigaction SIGTERM (exit-handler kernel))
  (sigaction SIGINT  (exit-handler kernel))
744

745
746
747
  (setvbuf (current-output-port) 'line)
  (setvbuf (current-error-port) 'line)

Ludovic Courtès's avatar
Ludovic Courtès committed
748
  (format/log "Guix kernel started (PID ~a)~%" (getpid))
749
  (with-store store
750
751
752
753
754
755
756
    ;; Enable "build traces" so we can use (guix status) to track build and
    ;; download events.
    (set-build-options store
                       #:print-build-trace #t
                       #:print-extended-build-trace? #t
                       #:multiplexed-build-output? #t)

757
758
759
760
    (serve-kernels (list kernel)
                   (proxy-request-handler dispatch-route)
                   (set-proxy-state-property (proxy-state kernel)
                                             %store-property store))))
761
762
763
764

;; Local Variables:
;; eval: (put 'with-build-progress-report 'scheme-indent-function 2)
;; End: