From 1e1b70994d4bcc196900c9cca8f5657f51a75adf Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 13 Oct 2011 18:51:13 -0400 Subject: [PATCH] My First Common-Lisp Program --- lisp/main.lisp | 33 +++++++++++ lisp/network.lisp | 47 +++++++++++++++ lisp/packages.lisp | 33 +++++++++++ lisp/sexp.lisp | 142 +++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 255 insertions(+) create mode 100644 lisp/main.lisp create mode 100644 lisp/network.lisp create mode 100644 lisp/packages.lisp create mode 100644 lisp/sexp.lisp diff --git a/lisp/main.lisp b/lisp/main.lisp new file mode 100644 index 0000000..b8a3325 --- /dev/null +++ b/lisp/main.lisp @@ -0,0 +1,33 @@ +(ql:quickload "flexi-streams") +;(ql:quickload "babel") +(ql:quickload "usocket") +(ql:quickload "cl-match") + +(ql:quickload "gbbopen") +(require :portable-threads) + +(load "packages.lisp") +(load "sexp.lisp") +(load "network.lisp") + +(in-package :cl-user) + +;; (defun handle-connection (stream) +;; (spki-sexp:write-sexp (spki-sexp:read-sexp stream) stream)) + +;; (defun start-server (port) +;; (usocket:socket-server "localhost" port 'handle-connection '() +;; :in-new-thread t +;; :multi-threading t +;; :reuse-address t +;; :element-type '(unsigned-byte 8))) + +;; (start-server 5671) + +(smsg-network:serve-on-port 5671) + +;; (let ((server-socket (socket-listen "localhost" 5671 +;; :reuse-address t +;; :element-type unsigned-integer))) +;; (loop for conn = (socket-accept server-socket) +;; do (handle-connection conn))) diff --git a/lisp/network.lisp b/lisp/network.lisp new file mode 100644 index 0000000..e36803e --- /dev/null +++ b/lisp/network.lisp @@ -0,0 +1,47 @@ +(in-package :smsg-network) + +(defun command-loop (in out route) + (loop (let ((command (read-sexp in))) + (when (not (handle-inbound-command command in out route)) + (return))))) + +(defun handle-inbound-command (command in out route) + (ematch-sexp command + (("subscribe" filter sink name reply-sink reply-name) + (if (rebind-node filter nil route) + (when (plusp (length reply-sink)) + (post reply-sink reply-name (sexp-build ("subscribe-ok" (= filter))))) + (report! `(rebind-failed ,command)))) + (("unsubscribe" id) + (when (not (rebind-node id route nil)) + (report! `(rebind-failed ,command)))) + (("post" name body token) + (send name body)))) + +(defun relay (in out localname servermode) + (flet ((route (message) + (write-sexp message out) + (write-byte 13 out) + (write-byte 10 out))) + (if servermode + (route (sexp-quote ("hop" "0"))) + (ematch-sexp (read-sexp in) + (("hop" "0") t))) + (force-output out) + (route (sexp-build ("subscribe" (= localname) "" "" "" ""))) + (command-loop in out #'route))) + +(defun handle-connection (stream) + (relay stream stream (sexp-quote "smsg") t)) + +(defun serve-on-port (port) + (usocket:socket-server "localhost" port 'handle-connection '() + :in-new-thread t + :multi-threading t + :reuse-address t + :element-type '(unsigned-byte 8))) + +(defun client (localname hostname portnumber) + (let ((s (usocket:socket-stream + (usocket:socket-connect hostname portnumber :element-type '(unsigned-byte 8))))) + (relay s s localname nil))) diff --git a/lisp/packages.lisp b/lisp/packages.lisp new file mode 100644 index 0000000..20d0e8b --- /dev/null +++ b/lisp/packages.lisp @@ -0,0 +1,33 @@ +(defpackage :spki-sexp + (:use :cl :flexi-streams :cl-match) + (:shadow :read-from-string) + + (:export :read-sexp :write-sexp + + :display-hint + :make-display-hint + :display-hint-p + :copy-display-hint + :display-hint-hint + :display-hint-body + + :syntax-error + :bad-length-prefix + :bad-display-hint + :bad-input-character + :unexpected-close-paren + + :match-failure + + :convert-sexp + :sexp-quote + :sexp-build + + :match-sexp + :ematch-sexp)) + +(defpackage :smsg-network + (:use :cl :flexi-streams :spki-sexp) + (:export :relay + :serve-on-port + :client)) diff --git a/lisp/sexp.lisp b/lisp/sexp.lisp new file mode 100644 index 0000000..93d1d9e --- /dev/null +++ b/lisp/sexp.lisp @@ -0,0 +1,142 @@ +;; SPKI SEXPs for Common Lisp + +(in-package :spki-sexp) + +(define-condition syntax-error (error) ()) +(define-condition bad-length-prefix (syntax-error) ()) +(define-condition bad-display-hint (syntax-error) ()) +(define-condition bad-input-character (syntax-error) ()) +(define-condition unexpected-close-paren (syntax-error) ()) + +(define-condition match-failure (error) ()) + +(defstruct display-hint hint body) + +(defun write-integer (n output-stream) + (labels ((w (n) + (when (plusp n) + (multiple-value-bind (top-half lower-digit) + (floor n 10) + (w top-half) + (write-byte (+ lower-digit 48) output-stream))))) + (if (zerop n) + (write-byte 48 output-stream) + (w n)))) + +(defun write-sexp (sexp &optional (output-stream *standard-output*)) + (etypecase sexp + ((array (unsigned-byte 8)) + (write-integer (length sexp) output-stream) + (write-byte 58 output-stream) ;; #\: + (write-sequence sexp output-stream)) + (cons + (write-byte 40 output-stream) ;; #\( + (loop for v in sexp do (write-sexp v output-stream)) + (write-byte 41 output-stream)) ;; #\) + (display-hint + (write-byte 91 output-stream) + (write-sexp (display-hint-hint sexp) output-stream) + (write-byte 93 output-stream) + (write-sexp (display-hint-body sexp) output-stream)) + (string + (write-sexp (flexi-streams:string-to-octets sexp :external-format :utf-8) output-stream)))) + +(defun read-simple-string (input-stream &optional (len 0)) + (loop (let ((c (read-byte input-stream))) + (if (eql c 58) ;; #\: + (let ((buf (make-array len :element-type '(unsigned-byte 8)))) + (read-sequence buf input-stream) + (return buf)) + (let ((v (digit-char-p c))) + (if v + (setq len (+ (* len 10) v)) + (error 'bad-length-prefix))))))) + +(defun read-sexp-list (input-stream) + (loop for v = (read-sexp-inner input-stream) + until (eq v 'end-of-list-marker) + collect v)) + +(defun read-sexp-inner (input-stream) + (let (result) + (tagbody :retry + (setq result + (let ((c (read-byte input-stream))) + (cond + ((eql c 40) (read-sexp-list input-stream)) ;; #\( + ((eql c 41) 'end-of-list-marker) ;; #\) + ((eql c 91) ;; #\[ + (let ((hint (read-simple-string input-stream))) + (when (not (eql (read-byte input-stream) 93)) ;; #\] + (error 'bad-display-hint)) + (make-display-hint :hint hint :body (read-simple-string input-stream)))) + ((<= 48 c 57) (read-simple-string input-stream (- c 48))) ;; digits + ((<= c 32) ;; whitespace - convenience for testing + (go :retry)) + (t (error 'bad-input-character)))))) + result)) + +(defun read-sexp (&optional (input-stream *standard-input*)) + (let ((v (read-sexp-inner input-stream))) + (if (eq v 'end-of-list-marker) + (error 'unexpected-close-paren) + v))) + +(defun convert-sexp (val) + (etypecase val + ((array (unsigned-byte 8)) val) + (cons (cons (convert-sexp (car val)) + (convert-sexp (cdr val)))) + (null nil) + (display-hint (make-display-hint + :hint (convert-sexp (display-hint-hint val)) + :body (convert-sexp (display-hint-body val)))) + (string (flexi-streams:string-to-octets val :external-format :utf-8)))) + +(defmacro sexp-quote (val) + `(quote ,(convert-sexp val))) + +(defun build-sexp (stx) + (etypecase stx + ((array (unsigned-byte 8)) stx) + (cons (if (eq (car stx) '=) + (cadr stx) + `(cons ,(build-sexp (car stx)) + ,(build-sexp (cdr stx))))) + (null 'nil) + (display-hint `(make-display-hint + :hint ,(build-sexp (display-hint-hint stx)) + :body ,(build-sexp (display-hint-body stx)))) + (string (flexi-streams:string-to-octets stx :external-format :utf-8)))) + +(defmacro sexp-build (template) + (build-sexp template)) + +(defun convert-match-pattern (pattern) + (etypecase pattern + ((array (unsigned-byte 8)) `(array (1 (unsigned-byte 8)) ,(coerce pattern 'list))) + (cons `(cons ,(convert-match-pattern (car pattern)) + ,(convert-match-pattern (cdr pattern)))) + (null 'nil) + (display-hint `(struct display-hint + (:hint ,(convert-match-pattern (display-hint-hint pattern))) + (:body ,(convert-match-pattern (display-hint-body pattern))))) + (string (convert-match-pattern + (flexi-streams:string-to-octets pattern :external-format :utf-8))) + (symbol pattern))) + +(defmacro match-sexp (val &rest clauses) + `(cl-match:match ,val + ,@(mapcar (lambda (clause) + `(,(convert-match-pattern (car clause)) ,@(cdr clause))) + clauses))) + +(defmacro ematch-sexp (val &rest clauses) + `(match-sexp ,val ,@clauses (_ (error 'match-failure)))) + +;; Useful for testing +(defun read-from-string (str &optional (external-format :utf-8)) + (read-sexp (flexi-streams:make-flexi-stream + (flexi-streams:make-in-memory-input-stream + (flexi-streams:string-to-octets str :external-format external-format)) + :external-format external-format)))