;;; Guix-kernel -- Guix kernel for Jupyter ;;; Copyright (C) 2018 Evgeny Panfilov ;;; Copyright (C) 2018 Pierre-Antoine Rouby ;;; Copyright (C) 2018, 2019, 2020, 2021 Inria ;;; ;;; 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 . (use-modules (json parser) (json builder) (simple-zmq) (git) ;for 'git-error-message' (srfi srfi-1) (srfi srfi-13) (srfi srfi-19) (srfi srfi-26) (srfi srfi-34) (srfi srfi-71) (rnrs bytevectors) (ice-9 match) (texinfo) (texinfo html) (guix build syscalls) (guix gexp) (guix store) (guix channels) (guix download) (guix derivations) (guix inferior) (guix monads) (guix profiles) ((guix i18n) #:select (P_)) (gcrypt base16) (gcrypt hash) (jupyter messages) (jupyter kernels) (jupyter servers) (jupyter guile) (guix jupyter logging) (guix jupyter proxy) (guix jupyter kernel) (guix jupyter environment)) ;; ;; Container tools. ;; (define container-context (zmq-create-context)) (define %store-property ;; Key used to access the in . (list 'store 'property)) (define (proxy-state-store state) "Return the associated with STATE." (proxy-state-property state %store-property)) (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)) (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 ;; 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)) (close-inferior previous)) (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)))) ;; ;; Handlers. ;; ;; Unknown request type, ignore it. (define (ignore-request kernel kind message state) state) ;; Send kernel-info. (define (reply-kernel-info-request kernel kind message state) (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). (pub-idle kernel message)) state) (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." (reply-shtml kernel message (manifest->shtml manifest name) count)) (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" . ,(sxml->xml-string `(div "Running " ,(kernel-specs-display-name specs) " kernel."))))) ("metadata" . ()) ("execution_count" . ,count)))) #:kernel-socket kernel-iopub)) (define (channels->shtml channels) "Return SHTML representing CHANNELS." `(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)))) (define* (reply-for-channels kernel message channels #: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))) (reply-shtml kernel message `(div (bold "Switched to these Guix channels:") ,(channels->shtml instances)) count))) (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))) (reply-shtml kernel message `(p (table ,@(map (match-lambda ((name version synopsis) `(tr (td ,(ref name)) (td ,version) (td ,(synopsis->shtml synopsis))))) lst))) count))) (lambda (key . args) (reply-shtml kernel message `(div (@ (class "ansi-red-fg")) "Invalid regular expression.") count)))) (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))) (reply-shtml kernel message `(div (bold "Using these Guix channels:") ,(channels->shtml channels)) count))) (define* (reply-for-channel-failure kernel message channels error #:key (count 0)) "Send KERNEL a reply saying we failed to switch to CHANNELS." (reply-shtml kernel message (string-append "Failed to switch to channels: " (git-error-message error) ".") count)) (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 (false-if-exception (base16-string->bytevector hash))) (define count (proxy-state-execution-count state)) (cond ((not algo) (reply-shtml kernel message `(bold "Unknown hash algorithm.") count) state) ((not hash/bv) (reply-shtml kernel message `(bold "Invalid hexadecimal string.") count) state) ((not (= (bytevector-length hash/bv) (hash-size algo))) (reply-shtml kernel message '(bold "Invalid hash length.") count) state) ((not (proxy-state-default-environment state)) (reply-shtml kernel message '(bold "No current environment to download to.") count)) (else (guard (c ((store-protocol-error? c) (reply-shtml kernel message `(bold ,(store-protocol-error-message c)) count) 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))) (if (derivation? drv) (mbegin %store-monad (built-derivations (list drv)) (return (derivation->output-path drv))) (return drv))))) ;plain file (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)) (reply-shtml kernel message `(bold "File " (code ,file) " from " (a (@ (href ,url)) ,url) " is now available in environment " (code ,environment) ".") count) (increment-execution-count state)))))) (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 (specifications->manifest (proxy-state-inferior state) specs)) (define store (proxy-state-store state)) (define counter (proxy-state-execution-count state)) (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 #:count counter) (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))))))) (match (available-kernel-specs (derivation->output-path profile) (list (string-append (derivation->output-path profile) "/share/jupyter"))) ((specs) (let* ((container (run-with-store store (spawn-kernel/container container-context profile))) (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))) (() (reply-shtml kernel message `(bold "No kernel found in environment " (code ,name) "!") counter) ;; TODO: Send "error". state) ((lst ...) (reply-shtml kernel message `(div (bold "Found " ,(length lst) " kernels in environment " (code ,name) ":") (ul ,@(map (lambda (specs) `(li ,(kernel-specs-display-name specs))) lst)) "Which one should we use? Please create an " "environment containing exactly one kernel.") counter) ;; TODO: Send "error". state)))) (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)))))) (define (reply-execute-request kernel kind message state) (let* ((request (json->execute-request (message-content message))) (code (execute-request-code request)) (line (string-take code (or (string-index code #\newline) (string-length code)))) (count (proxy-state-execution-count state))) (pub-busy kernel message) (match (string-tokenize line) ((";;guix" "environment" name "<-" specs ...) (guard (c ((package-not-found-error? c) (let ((package (package-not-found-error-name c))) (reply-shtml kernel message `(div (@ (class "ansi-red-fg")) "Package " (code ,package) " not found.") count)) state) ((output-not-found-error? c) (let ((output (output-not-found-error-output c)) (package (output-not-found-error-package c))) (reply-shtml kernel message `(div (@ (class "ansi-red-fg")) "Output " (code ,output) " of package " (code ,package) " not found.") count) state)) ((store-protocol-error? c) (let ((string (store-protocol-error-message c))) (reply-shtml kernel message `(div (@ (class "ansi-red-fg")) "Error: " ,string) count) 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)))))) ((";;guix" "environment" name) (match (lookup-proxied name state) (#f (reply-shtml kernel message `(bold "Unknown environment " (code ,name) ".") count) (increment-execution-count state)) ((? kernel? proxy) (format/log "evaluating code in container ~s (PID ~s)~%" name (kernel-pid proxy)) (send-message proxy (execute-request-sans-magic message)) (let ((state (increment-execution-count state))) (set-proxy-state-default-environment state name))))) ((";;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))) ((";;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))) ((";;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 () (let* ((store (proxy-state-store state)) (profile (with-build-progress-report kernel message (cached-channel-instance store channels))) (inferior (open-inferior profile))) (reply-for-channels kernel message channels #:profile profile #: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)))) ((";;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)) ((";;guix" _ ...) (reply-shtml kernel message `(bold "Invalid " (code "guix") " magic.") count) (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 (reply-shtml kernel message `(div "You have not selected an execution environment yet. You can create one by entering a “magic command” in a cell as follows:" (p (code ";;guix environment my-environment <- \ python-ipykernel")) "Subsequent cells will be executed by the " "IPython kernel in this environment.") count) state)))))) (define (environment-from-magic line) (match (string-tokenize line) ((";;guix" "environment" name) name) (_ #f))) (define %magic-commands ;; The ";;guix" magic commands. '("describe" "download" "environment" "pin" "search")) (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) (send-completion-reply (filter (cut string-prefix? command <>) %magic-commands) (- cursor (string-length command)) cursor) state) ((";;guix" "environment" prefix) (match (proxy-state-proxied state) (((names . _) ...) (send-completion-reply (filter (cut string-prefix? prefix <>) names) (- cursor (string-length prefix)) cursor) state))) ((";;guix" "environment" _ "<-" _ ... prefix) (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)) (_ (format/log "ignoring completion request~%") state)) ;; 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)) (send-message proxied message #:kernel-socket kind) state)) (#f (format/log "unknown target kernel for completion request~%") state))))) (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)) (define (shutdown kernel kind message state) (format/log "shutting down ~a containers~%" (proxy-state-proxied-number state)) (leave-server-loop (terminate-proxied-kernels message state))) ;; ;; Dispatch route. ;; (define dispatch-route `(("kernel_info_request" . ,reply-kernel-info-request) ("execute_request" . ,reply-execute-request) ("shutdown_request" . ,shutdown) ("complete_request" . ,reply-complete-request) ("inspect_request" . ,reply-inspect-request) ("comm_info_request" . ,ignore-request))) ;; ;; Run. ;; (define (exit-handler kernel) (lambda _ (close-kernel kernel) (exit 1))) ;; Start! (let ((kernel (call-with-input-file (car (last-pair (command-line))) connection-file->kernel))) (sigaction SIGTERM (exit-handler kernel)) (sigaction SIGINT (exit-handler kernel)) (setvbuf (current-output-port) 'line) (setvbuf (current-error-port) 'line) (format/log "Guix kernel started (PID ~a)~%" (getpid)) (with-store store ;; 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) (serve-kernels (list kernel) (proxy-request-handler dispatch-route) (set-proxy-state-property (proxy-state kernel) %store-property store)))) ;; Local Variables: ;; eval: (put 'with-build-progress-report 'scheme-indent-function 2) ;; End: