Message encryption.

src/cl-jupyter.asd

@@ -7,7 +7,8 @@
   :depends-on (:pzmq
                :bordeaux-threads
                :uuid
-	       ;; :ironclad  (for signed messages)
+	       :babel
+	       :ironclad
 	       :cl-base64)
   :serial t
   :components ((:file "packages")

src/iopub.lisp

@@ -26,35 +26,35 @@
 	  (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)
+    (message-send (iopub-socket iopub) status-msg :identities '("status") :key key)))
+
+(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")))))
+      (message-send (iopub-socket iopub) status-msg :identities '("status") :key key))))
 
-(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"))))
+    (message-send (iopub-socket iopub) code-msg :identities '("execute_input") :key key)))
 
 
-(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")))))
+      (message-send (iopub-socket iopub) result-msg :identities '("execute_result") :key key))))
 
-(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)))))
-    (message-send (iopub-socket iopub) stream-msg :identities `(,(format nil "stream.~W" stream-name)))))
+    (message-send (iopub-socket iopub) stream-msg :identities `(,(format nil "stream.~W" stream-name)) :key key)))

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)
    (stdin :initarg :stdin :initform nil :reader kernel-stdin)
@@ -82,8 +82,8 @@
    (iopub-port :initarg :iopub-port :reader config-iopub-port :type fixnum)
    (control-port :initarg :control-port :reader config-control-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 ()
   ;; IS THERE OTHER STUFF HANDLED BY MAXIMA INIT-CL.LISP THAT WE NEED TO DUPLICATE HERE ??
@@ -103,7 +103,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)
@@ -114,10 +114,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)
@@ -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*)
@@ -145,7 +145,7 @@ The deserialization of a message header from a JSon string is then trivial.
    :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,8 +265,8 @@ The wire-deserialization part follows.
 
 |#
 
-(defun message-send (socket msg &key (identities nil))
-  (let ((wire-parts (wire-serialize msg :identities identities)))
+(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)
       (when (< (pzmq:send socket part :sndmore t) 0)

src/shell.lisp

@@ -28,7 +28,7 @@
 (defun shell-loop (shell)
   (let ((active t))
     (format t "[Shell] loop started~%")
-    (send-status-starting (kernel-iopub (shell-kernel shell)) (kernel-session (shell-kernel shell)))
+    (send-status-starting (kernel-iopub (shell-kernel shell)) (kernel-session (shell-kernel shell)) :key (kernel-key shell))
     (while active
       (vbinds (identities sig msg buffers)  (message-recv (shell-socket shell))
 	      ;;(format t "Shell Received:~%")
@@ -110,13 +110,16 @@
 ;;                           ("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'~%")
   ;; status to busy
-  (send-status-update (kernel-iopub (shell-kernel shell)) msg "busy")
+  (send-status-update (kernel-iopub (shell-kernel shell)) msg "busy" :key (kernel-key shell))
   ;; for protocol version 5
   (let ((reply (make-message
-                msg "kernel_info_reply" nil 
+                msg "kernel_info_reply" nil
                 (make-instance
                  'content-kernel-info-reply
                  :protocol-version (header-version (message-header msg))
@@ -138,9 +141,9 @@
   ;;   				  :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")))
+    (send-status-update (kernel-iopub (shell-kernel shell)) msg "idle" :key (kernel-key shell))))
 
 #|
 
@@ -152,7 +155,7 @@
 
   (defun handle-execute-request (shell identities msg buffers)
     ;;(format t "[Shell] handling 'execute_request'~%")
-    (send-status-update (kernel-iopub (shell-kernel shell)) msg "busy")
+    (send-status-update (kernel-iopub (shell-kernel shell)) msg "busy" :key (kernel-key shell))
     (let ((content (parse-json-from-string (message-content msg))))
       ;;(format t "  ==> Message content = ~W~%" content)
       (let ((code (afetch "code" content :test #'equal)))
@@ -166,32 +169,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-status-update (kernel-iopub (shell-kernel shell)) msg "idle" :key (kernel-key shell))
   	;; 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)))))
 
   ;; Redefine RETRIEVE in src/macsys.lisp to make use of input-request/input-reply.
@@ -217,7 +220,7 @@
             (maxima::aformat nil "~M" maxima::msg)))))
       (let ((kernel (shell-kernel execute-request-shell)))
         (let ((stdin (kernel-stdin kernel)))
-          (send-input-request stdin execute-request-msg retrieve-prompt)
+	  (send-input-request stdin execute-request-msg retrieve-prompt :key (kernel-key shell))
           (multiple-value-bind (identities signature message buffers) (message-recv (stdin-socket stdin))
             (let*
               ((content (parse-json-from-string (message-content message)))

src/stdin.lisp

@@ -57,8 +57,7 @@ See: http://jupyter-client.readthedocs.org/en/latest/messaging.html#messages-on-
   ;; AT THIS POINT NEED TO HAND OFF VALUE TO ASKSIGN OR WHATEVER
   ;; CAUSED INPUT_REQUEST TO BE SENT !!
 )
-
-(defun send-input-request (stdin parent-msg prompt)
+(defun send-input-request (stdin parent-msg prompt &key (key nil))
   (let ((message (make-message parent-msg "input_request" nil `(("prompt" . ,prompt)))))
-    (message-send (stdin-socket stdin) message :identities '("input_request"))))
+    (message-send (stdin-socket stdin) message :identities '("input_request") :key key)))