syndicate-lang
/
hop-2012
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

My First Common-Lisp Program

This commit is contained in:
Tony Garnock-Jones 2011-10-13 18:51:13 -04:00
parent bd9f124a62
commit 1e1b70994d
4 changed files with 255 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
lisp/main.lisp Normal file
View File

@ -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)))

47
lisp/network.lisp Normal file
View File

@ -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)))

33
lisp/packages.lisp Normal file
View File

@ -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))

142
lisp/sexp.lisp Normal file
View File

@ -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)))