Commit 2cc4a5cc authored by Ludovic Courtès's avatar Ludovic Courtès
Browse files

Move messaging to (jupyter messages).

* guix-kernel/jupyter-client.scm (<header>, <message>, message)
(make-message, message-parts, reply, message-type, message-sender)
(string->header, header->string, parts->message, DELIM): Move to...
* jupyter/messages.scm: ... here.  New file.
(get-signature, make-id): New procedures.
* guix-kernel/hmac.msc, guix-kernel/tools.scm, tests/tools.scm: Remove.
* Makefile.am (SOURCES, SCM_TESTS): Adjust accordingly.
* guix-jupyter-container.scm, guix-jupyter-kernel.scm,
guix-kernel/jupyter-client.scm: Adjust import list accordingly.
* tests/hmac.scm (get-signature): New variable.
parent 7da97367
# Guix-kernel -- Guix kernel for Jupyter
# Copyright (C) 2018 Pierre-Antoine Rouby <pierre-antoine.rouby@inria.fr>
# Copyright (C) 2018 Pierre-Antoine Rouby <pierre-antoine.rouby@inria.fr>
# 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
......@@ -20,9 +21,8 @@ moddir=@guilemoduledir@
godir=@guileobjectdir@
SOURCES = \
jupyter/messages.scm \
guix-kernel/environ.scm \
guix-kernel/hmac.scm \
guix-kernel/tools.scm \
guix-kernel/magic.scm \
guix-kernel/jupyter-client.scm \
guix-kernel/jupyter-server.scm \
......@@ -41,7 +41,6 @@ TEST_EXTENSIONS = .scm
SCM_TESTS = \
tests/magic.scm \
tests/hmac.scm \
tests/tools.scm \
tests/environ.scm
TESTS = $(SCM_TESTS)
......
......@@ -26,8 +26,7 @@
(ice-9 futures)
(ice-9 match)
(sxml simple)
(guix-kernel tools)
(guix-kernel hmac)
(jupyter messages)
(guix-kernel magic)
(guix-kernel jupyter-client)
(guix-kernel jupyter-server))
......@@ -127,7 +126,7 @@ KEY for signing."
(lambda () (display key))))
(evalue (with-output-to-string
(lambda () (display parameters))))
(stacktrace (list (colorize err-key) evalue))
(stacktrace (list err-key evalue))
(result ""))
(values err err-key evalue
stacktrace result))))))
......
......@@ -31,8 +31,7 @@
(gnu system file-systems)
(guix build syscalls)
(guix build utils)
(guix-kernel tools)
(guix-kernel hmac)
(jupyter messages)
(guix-kernel magic)
(guix-kernel environ)
(guix-kernel jupyter-server)
......
;;; Guix-kernel -- Guix kernel for Jupyter
;;; Copyright (C) 2018 Evgeny Panfilov <epanfilov@gmail.com>
;;; Copyright (C) 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 (guix-kernel hmac)
#:use-module (gcrypt hmac)
#:use-module (gcrypt base16)
#:use-module (rnrs bytevectors)
#:export (get-signature))
(define (get-signature key str)
"Return a hexadecimal string containing the SHA256 HMAC of STR, a string,
with KEY, another string."
(bytevector->base16-string
(sign-data key (string->utf8 str)
#:algorithm 'sha256)))
......@@ -16,13 +16,10 @@
;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
(define-module (guix-kernel jupyter-client)
#:use-module (guix-kernel hmac)
#:use-module (guix-kernel tools)
#:use-module (jupyter messages)
#:use-module (guix-kernel jupyter-server)
#:use-module (simple-zmq)
#:use-module (json)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-19)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
#:export (guile-version
......@@ -30,28 +27,6 @@
json->kernel
message make-message
reply
message?
message-header
message-parent-header
message-metadata
message-content
message-buffers
message-type
message-sender
message-parts
parts->message
header?
header-id
header-user
header-session-id
header-date
header-type
header-version
header-sender
read-message
send-message
relay-message
......@@ -96,158 +71,9 @@
#:iosub
(make-socket ZMQ_PUB (hash-ref table "iopub_port")))))
;; Jupyter message header as defined at
;; <https://jupyter-client.readthedocs.io/en/stable/messaging.html#general-message-format>.
(define-record-type <header>
(header id user session date type version sender)
header?
(id header-id) ;bytevector (UUID)
(user header-user) ;string
(session header-session) ;bytevector (UUID)
(date header-date) ;string
(type header-message-type) ;string
(version header-version) ;string
;; This is the ZeroMQ identity of the sender and not part of the header
;; itself.
(sender header-sender)) ;bytevector (UUID) | #f
;; Jupyter message.
(define-record-type <message>
(%message header parent-header metadata content buffers)
message?
(header message-header) ;<header>
(parent-header message-parent-header) ;<header> | #f
(metadata message-metadata) ;hash table (?)
(content message-content) ;bytevector
(buffers message-buffers)) ;bytevector
(define* (message header content
#:key parent-header metadata (buffers '()))
"Return a new Jupyter message."
(%message header parent-header metadata content buffers))
(define make-message message)
(define* (message-parts message key
#:key
(recipient (and=> (message-parent-header message)
header-sender)))
"Return the list of parts (bytevectors) of MESSAGE for RECIPIENT, a ZeroMQ
identity (a bytevector).
This is a low-level procedure for internal use."
(let* ((header (header->string (message-header message)))
(parent (match (message-parent-header message)
(#f "{}")
(header (header->string header))))
(metadata (or (message-metadata message) "{}"))
(content (message-content message))
(payload (string-append header parent metadata content))
(signature (get-signature key payload)))
(cons* recipient DELIM
(map string->utf8
(list signature
header parent
metadata content)))))
(define (reply message type content)
"Return a Jupyter message that is a reply to MESSAGE."
(let ((parent (message-header message)))
(make-message (header (make-id) (header-user parent)
(header-session parent)
(date->string (time-utc->date
(current-time time-utc))
"~5.~N")
type
(header-version parent)
#f)
content
#:parent-header parent)))
(define (message-type message)
"Return the type of MESSAGE as a string--e.g., \"kernel_info_request\"."
(header-message-type (message-header message)))
(define (message-sender message)
"Return the identity (a bytevector) of the sender of MESSAGE or #f."
(header-sender (message-header message)))
(define* (string->header str #:optional sender)
"Read the JSON dictionary in STR and return the corresponding <header>
record. Return #f if STR is the empty dictionary."
(let ((table (json-string->scm str)))
(if (zero? (hash-count (const #t) table))
#f
(header (hash-ref table "msg_id")
(hash-ref table "username")
(hash-ref table "session")
(hash-ref table "date")
(hash-ref table "msg_type")
(hash-ref table "version")
sender))))
(define (header->string header)
"Return HEADER as a JSON string."
(scm->json-string `(("msg_id" . ,(header-id header))
("username" . ,(header-user header))
("session" . ,(header-session header))
,@(match (header-date header)
(#f '())
(date `(("date" . ,date))))
("msg_type" . ,(header-message-type header))
("version" . ,(header-version header)))))
(define (parts->message parts)
"Return a message record from PARTS, a list of bytevectors as returned by
'zmq-get-msg-parts-bytevector'.
This is a low-level procedure for internal use."
(define (delimiter? bv)
(bytevector=? DELIM bv))
;; Note: The "routing prefix", which comes before <IDS|MSG>, "can be zero
;; or more socket identities", quoth
;; <https://jupyter-client.readthedocs.io/en/stable/messaging.html#messages-on-the-shell-router-dealer-channel>.
;; Here we only remember the first one, which is the real sender identity;
;; subsequent identities can appear when the message has been relayed.
(match parts
((routing ... (? delimiter?) signature
(= utf8->string header)
(= utf8->string parent-header)
(= utf8->string metadata)
(= utf8->string content))
(message (string->header header
(match routing
(() #f)
((sender _ ...) sender)))
content
#:parent-header (string->header parent-header)
#:metadata metadata))))
(define (read-message kernel)
"Read a message for KERNEL--i.e., a message sent by Jupyter--and return
it or #f if nothing is available."
;; FIXME Use 'zmq_poll'.
(define (waiting-data socket next)
(catch 'zmq-error
(λ _
(zmq-get-msg-parts-bytevector socket))
(λ stuff
(cond
((equal? EAGAIN (cadr stuff))
(and next (waiting-data next socket)))
(else #f)))))
(and=> (waiting-data (kernel-shell kernel)
(kernel-control kernel))
parts->message))
(define guile-version (effective-version))
(define DELIM (string->utf8 "<IDS|MSG>"))
(define KERNEL-INFO
`(("protocol_version" . "5.3.0")
("implementation" . "Guix Jupyter kernel")
......@@ -268,6 +94,24 @@ it or #f if nothing is available."
;; Send procedures.
;;
(define (read-message kernel)
"Read a message for KERNEL--i.e., a message sent by Jupyter--and return
it or #f if nothing is available."
;; FIXME Use 'zmq_poll'.
(define (waiting-data socket next)
(catch 'zmq-error
(λ _
(zmq-get-msg-parts-bytevector socket))
(λ stuff
(cond
((equal? EAGAIN (cadr stuff))
(and next (waiting-data next socket)))
(else #f)))))
(and=> (waiting-data (kernel-shell kernel)
(kernel-control kernel))
parts->message))
(define* (send-message kernel message
#:key
(kernel-socket kernel-shell)
......
;;; Guix-kernel -- Guix kernel for Jupyter
;;; Copyright (C) 2018 Evgeny Panfilov <epanfilov@gmail.com>
;;;
;;; 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 (guix-kernel tools)
#:use-module (json)
#:export (make-id
colorize))
(define (make-id)
(number->string (random (expt 2 128)) 16))
(define (colorize string)
(string-append "\x1b[0;31m" string "\x1b[0;32m"))
;;; Guix-kernel -- Guix kernel for Jupyter
;;; Copyright (C) 2018 Evgeny Panfilov <epanfilov@gmail.com>
;;; Copyright (C) 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 messages)
#:use-module (simple-zmq)
#:use-module (json)
#:use-module (gcrypt hmac)
#:use-module (gcrypt base16)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-19)
#:use-module (ice-9 match)
#:export (message
make-message
reply
message?
message-header
message-parent-header
message-metadata
message-content
message-buffers
message-type
message-sender
message-parts
parts->message
header?
header-id
header-user
header-session-id
header-date
header-type
header-version
header-sender))
;;; Commentary:
;;;
;;; This file implements Jupyter messaging as defined at
;;; <https://jupyter-client.readthedocs.io/en/stable/messaging.html>.
;;;
;;; Code:
;; Jupyter message header as defined at
;; <https://jupyter-client.readthedocs.io/en/stable/messaging.html#general-message-format>.
(define-record-type <header>
(header id user session date type version sender)
header?
(id header-id) ;bytevector (UUID)
(user header-user) ;string
(session header-session) ;bytevector (UUID)
(date header-date) ;string
(type header-message-type) ;string
(version header-version) ;string
;; This is the ZeroMQ identity of the sender and not part of the header
;; itself.
(sender header-sender)) ;bytevector (UUID) | #f
;; Jupyter message.
(define-record-type <message>
(%message header parent-header metadata content buffers)
message?
(header message-header) ;<header>
(parent-header message-parent-header) ;<header> | #f
(metadata message-metadata) ;hash table (?)
(content message-content) ;bytevector
(buffers message-buffers)) ;bytevector
(define* (message header content
#:key parent-header metadata (buffers '()))
"Return a new Jupyter message."
(%message header parent-header metadata content buffers))
(define make-message message)
(define (make-id)
(number->string (random (expt 2 128)) 16))
(define (get-signature key str)
"Return a hexadecimal string containing the SHA256 HMAC of STR, a string,
with KEY, another string."
(bytevector->base16-string
(sign-data key (string->utf8 str)
#:algorithm 'sha256)))
(define* (message-parts message key
#:key
(recipient (and=> (message-parent-header message)
header-sender)))
"Return the list of parts (bytevectors) of MESSAGE for RECIPIENT, a ZeroMQ
identity (a bytevector).
This is a low-level procedure for internal use."
(let* ((header (header->string (message-header message)))
(parent (match (message-parent-header message)
(#f "{}")
(header (header->string header))))
(metadata (or (message-metadata message) "{}"))
(content (message-content message))
(payload (string-append header parent metadata content))
(signature (get-signature key payload)))
(cons* recipient DELIM
(map string->utf8
(list signature
header parent
metadata content)))))
(define (reply message type content)
"Return a Jupyter message that is a reply to MESSAGE."
(let ((parent (message-header message)))
(make-message (header (make-id) (header-user parent)
(header-session parent)
(date->string (time-utc->date
(current-time time-utc))
"~5.~N")
type
(header-version parent)
#f)
content
#:parent-header parent)))
(define (message-type message)
"Return the type of MESSAGE as a string--e.g., \"kernel_info_request\"."
(header-message-type (message-header message)))
(define (message-sender message)
"Return the identity (a bytevector) of the sender of MESSAGE or #f."
(header-sender (message-header message)))
(define* (string->header str #:optional sender)
"Read the JSON dictionary in STR and return the corresponding <header>
record. Return #f if STR is the empty dictionary."
(let ((table (json-string->scm str)))
(if (zero? (hash-count (const #t) table))
#f
(header (hash-ref table "msg_id")
(hash-ref table "username")
(hash-ref table "session")
(hash-ref table "date")
(hash-ref table "msg_type")
(hash-ref table "version")
sender))))
(define (header->string header)
"Return HEADER as a JSON string."
(scm->json-string `(("msg_id" . ,(header-id header))
("username" . ,(header-user header))
("session" . ,(header-session header))
,@(match (header-date header)
(#f '())
(date `(("date" . ,date))))
("msg_type" . ,(header-message-type header))
("version" . ,(header-version header)))))
(define DELIM (string->utf8 "<IDS|MSG>"))
(define (parts->message parts)
"Return a message record from PARTS, a list of bytevectors as returned by
'zmq-get-msg-parts-bytevector'.
This is a low-level procedure for internal use."
(define (delimiter? bv)
(bytevector=? DELIM bv))
;; Note: The "routing prefix", which comes before <IDS|MSG>, "can be zero
;; or more socket identities", quoth
;; <https://jupyter-client.readthedocs.io/en/stable/messaging.html#messages-on-the-shell-router-dealer-channel>.
;; Here we only remember the first one, which is the real sender identity;
;; subsequent identities can appear when the message has been relayed.
(match parts
((routing ... (? delimiter?) signature
(= utf8->string header)
(= utf8->string parent-header)
(= utf8->string metadata)
(= utf8->string content))
(message (string->header header
(match routing
(() #f)
((sender _ ...) sender)))
content
#:parent-header (string->header parent-header)
#:metadata metadata))))
......@@ -15,9 +15,12 @@
;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
(define-module (tests hmac)
#:use-module (guix-kernel hmac)
#:use-module (jupyter messages)
#:use-module (srfi srfi-64))
(define get-signature
(@@ (jupyter messages) get-signature))
(test-begin "hmac")
(test-equal "unit: (get-signature empty string)"
......
;;; Guix-kernel -- Guix kernel for Jupyter
;;; Copyright (C) 2018 Pierre-Antoine Rouby <pierre-antoine.rouby@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 (tests tools)
#:use-module (guix-kernel tools)
#:use-module (srfi srfi-64)
#:use-module (json))
(test-begin "tools")
(test-equal "unit: (string? (make-id))"
#t (string? (make-id)))
(test-end "tools")
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