Commit c7906233 authored by Ludovic Courtès's avatar Ludovic Courtès
Browse files

Add (jupyter guile).

* jupyter/guile.scm, tests/guile.scm: New files.
* Makefile.am (SOURCES): Add jupyter/guile.scm.
(SCM_TESTS): Add tests/guile.scm.
parent 0b9fec78
......@@ -28,6 +28,7 @@ SOURCES = \
guix/jupyter/logging.scm \
guix/jupyter/magic.scm \
guix/jupyter/proxy.scm \
jupyter/guile.scm \
jupyter/json.scm \
jupyter/messages.scm \
jupyter/kernels.scm \
......@@ -44,7 +45,8 @@ SCM_TESTS = \
tests/magic.scm \
tests/hmac.scm \
tests/kernels.scm \
tests/servers.scm
tests/servers.scm \
tests/guile.scm
TESTS = $(SCM_TESTS)
......
;;; Guix-kernel -- Guix kernel for Jupyter
;;; Copyright (C) 2019 Ludovic Courtès <ludovic.courtes@inria.fr>
;;;
;;; 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/>.
(define-module (jupyter guile)
#:use-module (jupyter messages)
#:use-module (jupyter kernels)
#:use-module (jupyter servers)
#:use-module (json)
#:use-module (simple-zmq)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-71)
#:use-module (ice-9 match)
#:export (run-guile-kernel))
;;; Commentary:
;;;
;;; This module provides a Jupyter kernel for Guile programming.
;;;
;;; Code:
;;;
;;; Logging.
;;;
(define current-logging-port
;; Logging port, for debugging.
(make-parameter (current-error-port)))
(define-syntax format/log
(lambda (s)
"Log the given string."
(syntax-case s ()
((_ fmt args ...)
(string? (syntax->datum #'fmt))
(with-syntax ((fmt (string-append "guile kernel[~a]: "
(syntax->datum #'fmt))))
#'(format (current-logging-port) fmt
(getpid) args ...))))))
;;;
;;; Kernel info.
;;;
(define %language-info
;; Language info for the Guix kernel.
(language-info
(name "guile")
(version (effective-version))
(mime-type "application/x-scheme")
(file-extension ".scm")
(pygments-lexer "scheme")
(codemirror-mode "scheme")))
(define %kernel-info-reply
;; Reply to "kernel_info_request" messages.
(kernel-info-reply
(implementation "GNU Guile")
(implementation-version "0.0.1")
(language-info %language-info)
(banner "GNU Guile kernel")
(help-links
'(("Inria GitLab" . "https://gitlab.inria.fr/guix-hpc/guix-kernel")
("GNU Guix" . "https://guix.gnu.org")
("GNU Guile" . "https://www.gnu.org/software/guile/")))))
;;;
;;; Request handling.
;;;
(define (reply-kernel-info-request kernel kind message state)
(send-message kernel
(reply message "kernel_info_reply"
(scm->json-string
(kernel-info-reply->json %kernel-info-reply))))
state)
(define %user-module
;; Module in which user code runs.
(make-fresh-user-module))
(define (frame->string frame) ;TODO: Improve by showing location, etc.
(match (frame-procedure-name frame)
(#f "?")
(name (symbol->string name))))
(define (code->execute-reply code counter)
"Return two values: an <execute-reply> record, and a Scheme value resulting
from the evaluation of CODE, a string."
(define prompt
(make-prompt-tag "user-extent"))
(define stack #f)
(catch #t
(lambda ()
(let ((result (call-with-prompt prompt
(lambda ()
(eval (with-input-from-string code read)
%user-module))
(const #f))))
(values (execute-reply (status 'ok)
(counter counter))
(pk 'result result))))
(lambda (key . args)
(let ((frames (unfold (cute >= <> (stack-length stack))
(cut stack-ref stack <>)
1+ 0)))
(values (execute-reply (status 'error)
(counter counter)
(exception-name (symbol->string key))
(exception-value (object->string args))
(traceback (map frame->string frames)))
#f)))
(lambda (key . args) ;pre-unwind hook
(set! stack (make-stack #t 1 prompt)))))
(define (reply-execute-request kernel kind message counter)
(format/log "handling execute-request~%")
(let* ((request (json->execute-request (message-content message)))
(sender (header-sender (message-header message)))
(code (string-append "(begin "
(execute-request-code request )
")")))
;; First off, say we're busy and echo the input back.
(pub-busy kernel message)
(send-message kernel
(reply message "execute_input"
(scm->json-string
(execute-input->json
(execute-input (code code)
(counter counter)))))
#:kernel-socket kernel-iopub)
(let ((xreply result (code->execute-reply code counter)))
(format/log "sending execution result for ~s~%" code)
(if (eq? 'error (execute-reply-status xreply))
(send-message kernel
(reply message "error"
(scm->json-string
`(("ename"
. ,(execute-reply-exception-name xreply))
("evalue"
. ,(execute-reply-exception-value xreply))
("traceback"
. ,(list->vector
(execute-reply-traceback xreply)))))))
(send-message kernel
(reply message "execute_result"
(scm->json-string
(execute-result->json
(execute-result
(counter counter)
(data
`(("text/plain"
. ,(object->string result))))))))
#:kernel-socket kernel-shell))
(send-message kernel
(reply message "execute_reply"
(scm->json-string
(execute-reply->json xreply)))
#:kernel-socket kernel-shell)
(pub-idle kernel message)
(+ 1 counter))))
(define (shutdown kernel kind message state)
(format/log "shutting down~%")
(leave-server-loop state))
;;
;; Dispatch route.
;;
(define dispatch-route
`(("kernel_info_request" . ,reply-kernel-info-request)
("execute_request" . ,reply-execute-request)
("shutdown" . ,shutdown)))
(define (request-handler handlers)
"Return a request handler that dispatches to HANDLERS, an alist."
(lambda (kernel kind message state)
(let ((handler (assoc-ref handlers (message-type message))))
(if handler
(handler kernel kind message state)
(begin
(format/log "unhandled '~a' message from client; ignoring~%"
(message-type message))
state)))))
;;
;; Top level.
;;
(define (run-guile-kernel connection)
"Run a Guile kernel with its client at CONNECTION, a <connection> record.
Return the kernel's state upon receiving a 'shutdown' request."
(let* ((context (zmq-create-context))
(kernel (connection->kernel connection #:context context)))
(format/log "started Guile kernel as PID ~a~%" (getpid))
(let ((result (serve-kernels (list kernel)
(request-handler dispatch-route)
0)))
(close-kernel kernel)
result)))
;;; Guix-kernel -- Guix kernel for Jupyter
;;; Copyright (C) 2019 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 <https://www.gnu.org/licenses/>.
(define-module (tests guile)
#:use-module (jupyter kernels)
#:use-module (jupyter messages)
#:use-module (jupyter servers)
#:use-module (jupyter guile)
#:use-module (simple-zmq)
#:use-module (json)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-64)
#:use-module (srfi srfi-71)
#:use-module (ice-9 threads)
#:use-module (ice-9 match))
(define %client-context
(zmq-create-context))
(define %kernel-key "secretkey")
(test-begin "guile")
(test-equal "kernel_info_request"
(@@ (jupyter guile) %kernel-info-reply)
(let ((connection client (allocate-connection %client-context
"tcp" "127.0.0.1"
%kernel-key)))
(define (client-thunk)
(let ((request (message (header "kernel_info_request" "luser" "12345")
"{}")))
(send-message client request)
(let ((reply (read-message client 10000)))
(send-message client
(message (header "shutdown" "luser" "12345")
"{}"))
(close-kernel client)
(json->kernel-info-reply (message-content reply)))))
(let ((thread (call-with-new-thread client-thunk)))
(run-guile-kernel connection)
(join-thread thread))))
(test-equal "execute_request"
(list (kernel-status (execution-state 'busy))
(kernel-status (execution-state 'idle))
(execute-input (code "(begin (* 7 6))"))
(execute-result (data `(("text/plain" . "42")))
(counter 0))
(execute-reply (status 'ok) (counter 0)))
(let ((connection client (allocate-connection %client-context
"tcp" "127.0.0.1"
%kernel-key)))
(define (type-predicate type)
(lambda (message)
(string=? (message-type message) type)))
(define (client-thunk)
(let ((request (message (header "execute_request" "luser" "12345")
(scm->json-string
(execute-request->json
(execute-request (code "(* 7 6)")))))))
(send-message client request)
(let ((replies (unfold (cut > <> 4)
(lambda (_)
(read-message client 10000))
1+ 0)))
(send-message client
(message (header "shutdown" "luser" "12345")
"{}"))
(close-kernel client)
(map (lambda (message)
(let ((content (message-content message)))
(match (message-type message)
("status" (json->kernel-status content))
("execute_input" (json->execute-input content))
("execute_result" (json->execute-result content))
("execute_reply" (json->execute-reply content)))))
(append (filter (type-predicate "status") replies)
(remove (type-predicate "status") replies))))))
(let ((thread (call-with-new-thread client-thunk)))
(run-guile-kernel connection)
(join-thread thread))))
(test-equal "execute_request, exception"
"system-error"
(let ((connection client (allocate-connection %client-context
"tcp" "127.0.0.1"
%kernel-key)))
(define (type-predicate type)
(lambda (message)
(string=? (message-type message) type)))
(define (client-thunk)
(let ((request (message (header "execute_request" "luser" "12345")
(scm->json-string
(execute-request->json
(execute-request (code "(delete-file \"/\")")))))))
(send-message client request)
(let ((replies (unfold (cut > <> 4)
(lambda (_)
(read-message client 10000))
1+ 0)))
(send-message client
(message (header "shutdown" "luser" "12345")
"{}"))
(close-kernel client)
(json->execute-reply
(message-content (find (type-predicate "execute_reply")
replies))))))
(let ((thread (call-with-new-thread client-thunk)))
(run-guile-kernel connection)
(let ((reply (join-thread thread)))
(and (pair? (execute-reply-traceback reply))
(execute-reply-exception-name reply))))))
(test-end "guile")
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment