signed messages (need more work)

cl-jupyter.lisp

@@ -21,10 +21,12 @@
     (push def-dir asdf:*central-registry*)))
 
 ;; not yet installed in quicklisp directory
-;; (format t "path = ~A~%" (directory-namestring *load-truename*))
 (push (truename (format nil "~Asrc/" (directory-namestring *load-truename*)))
       asdf:*central-registry*)
 
+;; for debugging only:
+;; (push (truename "./src/") asdf:*central-registry*)
+
 ;; activate debugging
 (declaim (optimize (speed 0) (space 0) (debug 3) (safety 3)))
 

src/cl-jupyter.asd

@@ -7,17 +7,18 @@
   :depends-on (:pzmq
                :bordeaux-threads
                :uuid
-	       ;; :ironclad  (for signed messages)
-	       :cl-base64)
+               :babel
+               :ironclad
+               :cl-base64)
   :serial t
   :components ((:file "packages")
                (:file "utils")
-	       (:file "myjson")
-	       (:file "config")
+               (:file "myjson")
+               (:file "config")
                (:file "message")
                (:file "shell")
-	       (:file "iopub")
-	       (:file "display")
-	       (:file "evaluator")
+               (:file "iopub")
+               (:file "display")
+               (:file "evaluator")
                (:file "user")
                (:file "kernel")))

src/iopub.lisp

@@ -26,34 +26,34 @@
 	  (setf (slot-value kernel 'iopub) iopub)
           iopub)))))
 
-(defun send-status-starting (iopub session)
+(defun send-status-starting (iopub session &key (key nil))
   (let ((status-msg (make-orphan-message session "status" nil
 					  `(("execution_state" . "starting")))))
     (message-send (iopub-socket iopub) status-msg :identities '("status"))))
-  
-(defun send-status-update (iopub parent-msg status)
+
+(defun send-status-update (iopub parent-msg status &key (key nil))
   (let ((status-content `((:execution--state . ,status))))
     (let ((status-msg (make-message parent-msg "status" nil
 				    `(("execution_state" . ,status)))))
       (message-send (iopub-socket iopub) status-msg :identities '("status")))))
 
-(defun send-execute-code (iopub parent-msg execution-count code)
+(defun send-execute-code (iopub parent-msg execution-count code &key (key nil))
   (let ((code-msg (make-message  parent-msg "execute_input" nil
 				 `(("code" . ,code)
 				   ("execution_count" . ,execution-count)))))
     ;;(format t "content to send = ~W~%" (encode-json-to-string (message-content code-msg)))
     (message-send (iopub-socket iopub) code-msg :identities '("execute_input"))))
 
 
-(defun send-execute-result (iopub parent-msg execution-count result)
+(defun send-execute-result (iopub parent-msg execution-count result &key (key nil))
   (let ((display-obj (display result)))
     (let ((result-msg (make-message parent-msg "execute_result" nil
 				    `(("execution_count" . ,execution-count)
 				      ("data" . ,(display-object-data display-obj))
 				      ("metadata" . ())))))
       (message-send (iopub-socket iopub) result-msg :identities '("execute_result")))))
 
-(defun send-stream (iopub parent-msg stream-name data)
+(defun send-stream (iopub parent-msg stream-name data &key (key nil))
   (let ((stream-msg (make-message parent-msg "stream" nil
 				  `(("name" . ,stream-name)
 				    ("text" . ,data)))))

src/kernel.lisp

@@ -1,7 +1,7 @@
 (in-package #:cl-jupyter)
 
 (defclass kernel ()
-  ((config :initarg :config :reader kerner-config)
+  ((config :initarg :config :reader kernel-config)
    (ctx :initarg :ctx :reader kernel-ctx)
    (shell :initarg :shell :initform nil :reader kernel-shell)
    (iopub :initarg :iopub :initform nil :reader kernel-iopub)
@@ -81,8 +81,8 @@
    (control-port :initarg :control-port :reader config-control-port :type fixnum)
    (stdin-port :initarg :stdin-port :reader config-stdin-port :type fixnum)
    (hb-port :initarg :hb-port :reader config-hb-port :type fixnum)
-   (signature-scheme :initarg :signature-scheme :reader kernel-config-signature-scheme :type string)
-   (key :initarg :key :reader kernel-config-key :type string)))
+   (signature-scheme :initarg :signature-scheme :reader config-signature-scheme :type string)
+   (key :initarg :key :reader kernel-config-key)))
 
 (defun kernel-start ()
   (let ((cmd-args (get-argv)))
@@ -99,7 +99,7 @@
       (unless (stringp connection-file-name)
         (error "Wrong connection file argument (expecting a string)"))
       (let ((config-alist (parse-json-from-string (concat-all 'string "" (read-file-lines connection-file-name)))))
-        ;; (format t "kernel configuration = ~A~%" config-alist)
+        (format t "kernel configuration = ~A~%" config-alist)
         (let ((config
                (make-instance 'kernel-config
                               :transport (afetch "transport" config-alist :test #'equal)
@@ -109,10 +109,13 @@
                               :control-port (afetch "control_port" config-alist :test #'equal)
                               :hb-port (afetch "hb_port" config-alist :test #'equal)
                               :signature-scheme (afetch "signature_scheme" config-alist :test #'equal)
-                              :key (afetch "key" config-alist :test #'equal))))
-          (when (not (string= (kernel-config-key config) ""))
-            ;; TODO: add support for encryption
-            (error "Secure connection not yet supported: please use an empty encryption key"))
+                              :key (let ((str-key (afetch "key" config-alist :test #'equal)))
+                                     (if (string= str-key "")
+                                         nil
+                                         (babel:string-to-octets str-key :encoding :ASCII))))))
+          (when (not (string= (config-signature-scheme config) "hmac-sha256"))
+            ;; XXX: only hmac-sha256 supported
+            (error "Kernel only support signature scheme 'hmac-sha256' (provided ~S)" (config-signature-scheme config)))
           ;;(inspect config)
           (let* ((kernel (make-kernel config))
                  (evaluator (make-evaluator kernel))

src/message.lisp

@@ -37,11 +37,11 @@
                  :indent indent :first-line first-line)))
 
 (example-progn
-  (defparameter *header1* (make-instance 'header
-                                         :msg-id "XXX-YYY-ZZZ-TTT"
-                                         :username "fredokun"
-                                         :session "AAA-BBB-CCC-DDD"
-                                         :msg-type "execute_request")))
+ (defparameter *header1* (make-instance 'header
+                                        :msg-id "XXX-YYY-ZZZ-TTT"
+                                        :username "fredokun"
+                                        :session "AAA-BBB-CCC-DDD"
+                                        :msg-type "execute_request")))
 
 (example
  (encode-json-to-string *header1* :indent 0)
@@ -66,8 +66,8 @@
 
 (example (parse-json-from-string (encode-json-to-string *header1*))
          => '(("msg_id" . "XXX-YYY-ZZZ-TTT") ("username" . "fredokun")
-	      ("session" . "AAA-BBB-CCC-DDD") ("msg_type" . "execute_request")
-	      ("version" . "5.0")))
+              ("session" . "AAA-BBB-CCC-DDD") ("msg_type" . "execute_request")
+              ("version" . "5.0")))
 
 (example
  (afetch "msg_id" (parse-json-from-string (encode-json-to-string *header1*)) :test #'equal)
@@ -96,7 +96,7 @@ The deserialization of a message header from a JSon string is then trivial.
         nil)))
 
 (example-progn
-  (defparameter *header2* (wire-deserialize-header (encode-json-to-string *header1*))))
+ (defparameter *header2* (wire-deserialize-header (encode-json-to-string *header1*))))
 
 
 (example (header-username *header2*)
@@ -120,12 +120,12 @@ The deserialization of a message header from a JSon string is then trivial.
     (make-instance 
      'message
      :header (make-instance 
-	      'header
-	      :msg-id (format nil "~W" (uuid:make-v4-uuid))
-	      :username (header-username hdr)
-	      :session (header-session hdr)
-	      :msg-type msg_type
-	      :version (header-version hdr))
+              'header
+              :msg-id (format nil "~W" (uuid:make-v4-uuid))
+              :username (header-username hdr)
+              :session (header-session hdr)
+              :msg-type msg_type
+              :version (header-version hdr))
      :parent-header hdr
      :metadata metadata
      :content content)))
@@ -134,18 +134,18 @@ The deserialization of a message header from a JSon string is then trivial.
   (make-instance 
    'message
    :header (make-instance 
-	    'header
-	    :msg-id (format nil "~W" (uuid:make-v4-uuid))
-	    :username "kernel"
-	    :session session-id
-	    :msg-type msg-type
-	    :version +KERNEL-PROTOCOL-VERSION+)
+            'header
+            :msg-id (format nil "~W" (uuid:make-v4-uuid))
+            :username "kernel"
+            :session session-id
+            :msg-type msg-type
+            :version +KERNEL-PROTOCOL-VERSION+)
    :parent-header '()
    :metadata metadata
    :content content))
 
 (example-progn
-  (defparameter *msg1* (make-instance 'message :header *header1*)))
+ (defparameter *msg1* (make-instance 'message :header *header1*)))
 
 
 #|
@@ -156,27 +156,50 @@ The wire-serialization of IPython kernel messages uses multi-parts ZMQ messages.
 
 |#
 
-;; strange issue with defconstant...
+(defun octets-to-hex-string (bytes)
+  (apply #'concatenate (cons 'string (map 'list (lambda (x) (format nil "~(~2,'0X~)" x)) bytes))))
+
+(defun message-signing (key parts)
+  (let ((hmac (ironclad:make-hmac key :SHA256)))
+    ;; updates
+    (loop for part in parts
+       do (let ((part-bin (babel:string-to-octets part)))
+            (ironclad:update-hmac hmac part-bin)))
+    ;; digest
+    (octets-to-hex-string (ironclad:hmac-digest hmac))))
+
+(example
+ (message-signing (babel:string-to-octets "toto") '("titi" "tata" "tutu" "tonton"))
+ => "d32d091b5aabeb59b4291a8c5d70e0c20302a8bf9f642956b6affe5a16d9e134")
+
+;; XXX: should be a defconstant but  strings are not EQL-able...
 (defvar +WIRE-IDS-MSG-DELIMITER+ "<IDS|MSG>")
 
-(defmethod wire-serialize ((msg message) &key (identities nil))
+(defmethod wire-serialize ((msg message) &key (identities nil) (key nil))
   (with-slots (header parent-header metadata content) msg
-      (append identities
-              (list +WIRE-IDS-MSG-DELIMITER+
-                    "" ; TODO   HMAC signature
-                    (encode-json-to-string header)
-		    (if parent-header
-			(encode-json-to-string parent-header)
-			"{}")
-		    (if metadata
-			(encode-json-to-string metadata)
-			"{}")
-		    (if content
-			(encode-json-to-string content)
-			"{}")))))
+    (let ((header-json (encode-json-to-string header))
+          (parent-header-json (if parent-header
+                                  (encode-json-to-string parent-header)
+                                  "{}"))
+          (metadata-json (if metadata
+                             (encode-json-to-string metadata)
+                             "{}"))
+          (content-json (if content
+                            (encode-json-to-string content)
+                            "{}")))
+      (let ((sig (if key
+                     (message-signing key (list header-json parent-header-json metadata-json content-json))
+                     "")))
+        (append identities
+                (list +WIRE-IDS-MSG-DELIMITER+
+                      sig
+                      header-json
+                      parent-header-json
+                      metadata-json
+                      content-json))))))
 
 (example-progn
-  (defparameter *wire1* (wire-serialize *msg1* :identities '("XXX-YYY-ZZZ-TTT" "AAA-BBB-CCC-DDD"))))
+ (defparameter *wire1* (wire-serialize *msg1* :identities '("XXX-YYY-ZZZ-TTT" "AAA-BBB-CCC-DDD"))))
 
 
 #|
@@ -228,9 +251,9 @@ The wire-deserialization part follows.
 
 
 (example-progn
-  (defparameter *dewire-1* (multiple-value-bind (ids sig msg raw)
-                               (wire-deserialize *wire1*)
-                             (list ids sig msg raw))))
+ (defparameter *dewire-1* (multiple-value-bind (ids sig msg raw)
+                              (wire-deserialize *wire1*)
+                            (list ids sig msg raw))))
 
 (example
  (header-username (message-header (third *dewire-1*)))
@@ -242,9 +265,9 @@ The wire-deserialization part follows.
 
 |#
 
-(defun message-send (socket msg &key (identities nil))
-  (let ((wire-parts (wire-serialize msg :identities identities)))
-    ;;(format t "~%[Send] wire parts: ~W~%" wire-parts)
+(defun message-send (socket msg &key (identities nil) (key nil))
+  (let ((wire-parts (wire-serialize msg :identities identities :key key)))
+    (format t "~%[Send] wire parts: ~W~%" wire-parts)
     (dolist (part wire-parts)
       (pzmq:send socket part :sndmore t))
     (pzmq:send socket nil)))
@@ -275,3 +298,6 @@ The wire-deserialization part follows.
   (let ((parts (zmq-recv-list socket)))
     ;;(format t "[Recv]: parts: ~A~%" (mapcar (lambda (part) (format nil "~W" part)) parts))
     (wire-deserialize parts)))
+
+
+

src/shell.lisp

@@ -102,13 +102,8 @@
                           ;("help_links" . ,help-links))
                  :indent indent :first-line first-line)))
 
-;; for protocol version 4.1
-;; (defmethod encode-json (stream (object content-kernel-info-reply) &key (indent nil) (first-line nil))
-;;   (with-slots (protocol-version ipython-version language-version language) object
-;;     (encode-json stream `(("protocol_version" . ,protocol-version)
-;;                           ("language_version" . ,language-version)
-;;                           ("language" . ,language))
-;;                  :indent indent :first-line first-line)))
+(defun kernel-key (shell)
+  (kernel-config-key (kernel-config (shell-kernel shell))))
 
 (defun handle-kernel-info-request (shell identities msg buffers)
   ;;(format t "[Shell] handling 'kernel-info-request'~%")
@@ -138,7 +133,7 @@
   ;;   				  :protocol-version #(4 1)
   ;;   				  :language-version #(1 2 7)  ;; XXX: impl. dependent but really cares ?
     ;;   				  :language "common-lisp"))))
-    (message-send (shell-socket shell) reply :identities identities)
+    (message-send (shell-socket shell) reply :identities identities :key (kernel-key shell))
     ;; status back to idle
     (send-status-update (kernel-iopub (shell-kernel shell)) msg "idle")))
 
@@ -163,32 +158,32 @@
         ;(format t "STDOUT = ~A~%" stdout)
         ;(format t "STDERR = ~A~%" stderr)
         ;; broadcast the code to connected frontends
-        (send-execute-code (kernel-iopub (shell-kernel shell)) msg execution-count code)
+        (send-execute-code (kernel-iopub (shell-kernel shell)) msg execution-count code :key (kernel-key shell))
 	(when (and (consp results) (typep (car results) 'cl-jupyter-user::cl-jupyter-quit-obj))
 	  ;; ----- ** request for shutdown ** -----
 	  (let ((reply (make-message msg "execute_reply" nil
 				     `(("status" . "abort")
 				       ("execution_count" . ,execution-count)))))
-	    (message-send (shell-socket shell) reply :identities identities))
+	    (message-send (shell-socket shell) reply :identities identities :key (kernel-key shell)))
 	  (return-from handle-execute-request nil))
 	;; ----- ** normal request ** -----
         ;; send the stdout
         (when (and stdout (> (length stdout) 0))
-          (send-stream (kernel-iopub (shell-kernel shell)) msg "stdout" stdout))
+          (send-stream (kernel-iopub (shell-kernel shell)) msg "stdout" stdout :key (kernel-key shell)))
         ;; send the stderr
         (when (and stderr (> (length stderr) 0))
-          (send-stream (kernel-iopub (shell-kernel shell)) msg "stderr" stderr))
+          (send-stream (kernel-iopub (shell-kernel shell)) msg "stderr" stderr :key (kernel-key shell)))
 	;; send the first result
 	(send-execute-result (kernel-iopub (shell-kernel shell)) 
-			     msg execution-count (car results))
+			     msg execution-count (car results) :key (kernel-key shell))
 	;; status back to idle
 	(send-status-update (kernel-iopub (shell-kernel shell)) msg "idle")
 	;; send reply (control)
 	(let ((reply (make-message msg "execute_reply" nil
 				   `(("status" . "ok")
 				     ("execution_count" . ,execution-count)
 				     ("payload" . ,(vector))))))
-	  (message-send (shell-socket shell) reply :identities identities)
+	  (message-send (shell-socket shell) reply :identities identities :key (kernel-key shell))
 	  t)))))
 
 #|