├── .gitignore ├── make ├── XX-clean.mk ├── 99-driver.mk ├── 00-sys.mk ├── 01-quicklisp.mk └── 02-asdf.mk ├── vendor └── Makefile ├── .gitmodules ├── src ├── helpers.lisp ├── http │ ├── package.lisp │ ├── http-server.lisp │ ├── fsm.lisp │ ├── request.lisp │ └── parser.lisp ├── generics.lisp ├── package.lisp ├── hinge.lisp ├── server.lisp ├── zmq-socket.lisp ├── methods.lisp ├── emitter.lisp ├── patches │ └── zmq.lisp ├── pool.lisp └── socket.lisp ├── Makefile ├── examples ├── http.lisp ├── http-chunked.lisp ├── external.lisp ├── async.lisp ├── pause.lisp └── pingpong.lisp ├── LICENSE ├── hinge.asd └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | *.fasl 3 | scratch.lisp 4 | *.old 5 | \#* 6 | .\#* 7 | *.core 8 | -------------------------------------------------------------------------------- /make/XX-clean.mk: -------------------------------------------------------------------------------- 1 | #-*- mode:makefile-gmake; -*- 2 | clean: | lisp-fasl-clean asdf-clean lisp-clean 3 | -------------------------------------------------------------------------------- /vendor/Makefile: -------------------------------------------------------------------------------- 1 | #-*- mode:makefile-gmake; -*- 2 | .PHONY: all clean init 3 | init: 4 | @echo "=> Updating submodules" 5 | (cd .. ; git submodule update --init --recursive;) 6 | 7 | all: | init 8 | @echo "=> Nothing to do for vendor." 9 | 10 | clean: 11 | find . -name '*.fasl' -delete 12 | 13 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "vendor/cl-ev"] 2 | path = vendor/cl-ev 3 | url = git@github.com:sshirokov/cl-ev.git 4 | [submodule "vendor/cffi"] 5 | path = vendor/cffi 6 | url = git://common-lisp.net/projects/cffi/cffi.git 7 | [submodule "vendor/lisp-zmq"] 8 | path = vendor/lisp-zmq 9 | url = git://github.com/galdor/lisp-zmq.git 10 | -------------------------------------------------------------------------------- /make/99-driver.mk: -------------------------------------------------------------------------------- 1 | #-*- mode:makefile-gmake; -*- 2 | .PHONY: sanity-check init 3 | 4 | sanity-check: $(ROOT)/$(TARGET).asd $(LISP_BIN) $(QL_SETUP) 5 | @echo "!> Environment looks sane. I'll allow this." 6 | 7 | init: | sanity-check quicklisp 8 | $(MAKE) -C $(ROOT)/vendor init 9 | @echo "=> Environment Initialized." 10 | 11 | develop: | init asdf 12 | @echo "=> You should be good to go." 13 | -------------------------------------------------------------------------------- /src/helpers.lisp: -------------------------------------------------------------------------------- 1 | (in-package :hinge) 2 | 3 | ;; Helper 4 | (defgeneric socket-fd (socket) 5 | (:documentation "Translate a heavy `socket' object to a numeric file descriptor.") 6 | (:method ((socket sockets:socket)) 7 | (sockets:socket-os-fd socket)) 8 | (:method (socket) 9 | nil)) 10 | 11 | (defmacro sock-of (place) `(svref ,place 0)) 12 | (defmacro watcher-of (place) `(svref ,place 1)) 13 | -------------------------------------------------------------------------------- /make/00-sys.mk: -------------------------------------------------------------------------------- 1 | #-*- mode:makefile-gmake; -*- 2 | LISP_BIN ?= $(shell which sbcl || echo /sbcl/does/not/exist) 3 | LISP_PREFIX ?= CL_SOURCE_REGISTRY='$(ROOT):$(ROOT)/vendor//' 4 | LISP ?= $(LISP_PREFIX) $(LISP_BIN) 5 | 6 | SHUTUP = > /dev/null 2> /dev/null 7 | NODEBUG ?= --eval '(sb-ext:disable-debugger)' 8 | 9 | .PHONY: lisp-cmd lisp-clean lisp-fasl-clean 10 | 11 | lisp: $(LISP_BIN) | init 12 | $(LISP) 13 | 14 | lisp-clean: 15 | @echo "=> Clearing common-lisp cache" 16 | rm -rf ~/.cache/common-lisp/ 17 | 18 | lisp-fasl-clean: 19 | @echo "=> Clearing fasls from $(ROOT)" 20 | find $(ROOT) -name '*.fasl' -delete 21 | 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | #-*- mode:makefile-gmake; -*- 2 | ROOT ?= $(shell pwd) 3 | README ?= $(ROOT)/README.md 4 | TARGET ?= hinge 5 | 6 | include $(ROOT)/make/*.mk 7 | 8 | 9 | define HELP 10 | echo "Interesting targets:" 11 | echo "--------------------" 12 | echo "make help" 13 | echo " This noise" 14 | echo 15 | echo "make develop" 16 | echo " Configures the submodules, vendor packages, user lisp dependencies" 17 | echo " and anything else needed to actually boot the package" 18 | echo 19 | echo "Info:" 20 | echo "-----" 21 | echo "The make driven chain is in $(ROOT)/make." 22 | endef 23 | .DEFAULT_GOAL=help 24 | .PHONY: help 25 | help: 26 | @$(HELP) 27 | -------------------------------------------------------------------------------- /src/http/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :hinge.http 2 | (:use :cl :log5 :hinge) 3 | 4 | (:import-from :alexandria 5 | :curry 6 | :if-let) 7 | 8 | (:export :http-server 9 | 10 | :http-request 11 | :http-method 12 | :resource 13 | :version 14 | :headers 15 | :body 16 | 17 | :http-response 18 | :request 19 | :status-code 20 | :status-reason 21 | :headers 22 | 23 | :write-head 24 | :set-headers 25 | :header 26 | :send 27 | :end)) 28 | 29 | 30 | (in-package :hinge.http) 31 | -------------------------------------------------------------------------------- /examples/http.lisp: -------------------------------------------------------------------------------- 1 | (ql:quickload :hinge) 2 | (defpackage :hinge-example 3 | (:use :cl :hinge :hinge.http)) 4 | 5 | (in-package :hinge-example) 6 | 7 | (let ((server (make-instance 'http-server))) 8 | (add-listener server "request" 9 | (lambda (request response) 10 | (declare (ignorable request)) 11 | (async (:success (lambda (r) 12 | (write-head response 200 '(("Content-Type" . "text/html"))) 13 | (end response (format nil "Hello world! [~A]" r)))) 14 | (random 1024)))) 15 | 16 | (bind server 4545)) 17 | 18 | (run :default) 19 | -------------------------------------------------------------------------------- /examples/http-chunked.lisp: -------------------------------------------------------------------------------- 1 | (ql:quickload :hinge) 2 | (defpackage :hinge-example 3 | (:use :cl :hinge :hinge.http)) 4 | 5 | (in-package :hinge-example) 6 | 7 | (let ((server (make-instance 'http-server))) 8 | (add-listener server "request" 9 | (lambda (request response) 10 | (declare (ignorable request)) 11 | (write-head response 200 '(("Content-Type" . "text/html"))) 12 | (send response "Hello chunk one!") 13 | (send response (format nil "~%")) 14 | 15 | (send response "Hello chunk two!") 16 | (send response (format nil "~%")) 17 | 18 | (end response 19 | (format nil "Hello world!~%")))) 20 | 21 | (bind server 4545)) 22 | 23 | (run :default) 24 | -------------------------------------------------------------------------------- /make/01-quicklisp.mk: -------------------------------------------------------------------------------- 1 | #-*- mode:makefile-gmake; -*- 2 | QL_URL ?= "https://github.com/quicklisp/quicklisp-bootstrap/raw/master/quicklisp.lisp" 3 | QL_ROOT_NAME ?= quicklisp 4 | QL_ROOT_PATH = $(HOME)/$(QL_ROOT_NAME) 5 | QL_SETUP = $(QL_ROOT_PATH)/setup.lisp 6 | 7 | .PHONY: quicklisp quicklisp-test 8 | quicklisp: $(LISP_BIN) $(QL_SETUP) | quicklisp-test 9 | 10 | quicklisp-test: 11 | @echo "=> Verifying Quicklisp load ...\c" 12 | @$(LISP) $(NODEBUG) \ 13 | --load $(QL_SETUP) \ 14 | --eval '(quit :unix-status (if (find-package :ql) 0 1))' $(SHUTUP) \ 15 | || { E=$$?; echo " [ERROR]"; exit $$E; } 16 | @echo " [OK]" 17 | 18 | $(QL_SETUP): 19 | @echo "=> Installing quicklisp" 20 | @curl -L $(QL_URL) > /tmp/quicklisp.lisp; \ 21 | $(LISP) $(NODEBUG) --load /tmp/quicklisp.lisp \ 22 | --eval '(quicklisp-quickstart:install :path "$(QL_ROOT_PATH)/")' \ 23 | --eval '(quit)'; 24 | -------------------------------------------------------------------------------- /src/generics.lisp: -------------------------------------------------------------------------------- 1 | (in-package :hinge) 2 | 3 | ;; Generics 4 | (defgeneric run (hinge) 5 | (:documentation "Run the event loop.")) 6 | 7 | (defgeneric set-timeout (hinge timeout callback) 8 | (:documentation "Creates and registers a `callback' of no arguments 9 | to be invoked after `timeout' elapses.")) 10 | (defgeneric set-interval (hinge interval callback) 11 | (:documentation "Crates and registers a `callback' of no arguments 12 | to be invoked every `timeout'")) 13 | (defgeneric clear (hinge handle) 14 | (:documentation "Clear the registration of a watcher (e.g. timeout or interval) named by `handle'")) 15 | 16 | (defgeneric queue-work (hinge work &optional queue) 17 | (:documentation "Queue a thunk, `work', into a work queue on 18 | `hinge'. If no `queue' is named, `:low' should be used.")) 19 | 20 | ;; Wrappers 21 | (defmacro defer ((hinge) &body forms) 22 | "Enqueue work `forms' into the low priority queue of `hinge'" 23 | `(queue-work ,hinge (lambda () ,@forms) :low)) 24 | -------------------------------------------------------------------------------- /make/02-asdf.mk: -------------------------------------------------------------------------------- 1 | #-*- mode:makefile-gmake; -*- 2 | REGISTRYD ?= $(HOME)/.config/common-lisp/source-registry.conf.d 3 | ASDF_CONF = (:directory \"$(ROOT)/\") 4 | ASDF_CONF_NAME = $(REGISTRYD)/"$(TARGET)-02.conf" 5 | 6 | VENDOR_ASDF_CONF = (:tree \"$(ROOT)/vendor/\") 7 | VENDOR_ASDF_CONF_NAME = $(REGISTRYD)/"$(TARGET)-01.conf" 8 | 9 | .PHONY: asdf asdf-clean 10 | 11 | asdf: | $(REGISTRYD) $(ASDF_CONF_NAME) $(VENDOR_ASDF_CONF_NAME) 12 | @echo "Added $(TARGET) in $(ROOT) to ASDF registry" 13 | 14 | asdf-clean: 15 | @echo "=> Cleaning up after ASDF" 16 | rm -f $(ASDF_CONF_NAME) 17 | rm -f $(VENDOR_ASDF_CONF_NAME) 18 | 19 | $(REGISTRYD): 20 | @echo "=> Creating ASDF registry configuration directory" 21 | mkdir -p $(REGISTRYD) 22 | 23 | $(ASDF_CONF_NAME): 24 | @echo "=> Installing: $(ASDF_CONF_NAME)" 25 | echo "$(ASDF_CONF)" > $(ASDF_CONF_NAME) 26 | 27 | $(VENDOR_ASDF_CONF_NAME): 28 | @echo "=> Installing: $(VENDOR_ASDF_CONF_NAME)" 29 | echo "$(VENDOR_ASDF_CONF)" > $(VENDOR_ASDF_CONF_NAME) 30 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012 Yaroslav Shirokov 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of 4 | this software and associated documentation files (the "Software"), to deal in 5 | the Software without restriction, including without limitation the rights to 6 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 7 | the Software, and to permit persons to whom the Software is furnished to do so, 8 | subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 15 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 16 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 17 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 18 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :hinge 2 | (:use :cl :log5) 3 | 4 | (:import-from :alexandria 5 | :curry 6 | :with-gensyms 7 | :flatten 8 | :when-let 9 | :if-let 10 | :appendf) 11 | 12 | (:import-from :arnesi 13 | :queue 14 | :queue-empty-p 15 | :enqueue 16 | :dequeue) 17 | 18 | (:export :output 19 | :hinge 20 | :*hinge* 21 | :get-default-hinge 22 | :run 23 | 24 | :set-interval 25 | :set-timeout 26 | :defer 27 | 28 | :pool 29 | :job 30 | :submit 31 | :async 32 | 33 | :emit 34 | :emitter 35 | :add-listener 36 | :listen-once 37 | :remove-listener 38 | 39 | :socket 40 | :sock 41 | :zmq-socket 42 | :server 43 | 44 | :connect 45 | :bind 46 | :send)) 47 | 48 | 49 | 50 | (in-package :hinge) 51 | (defcategory output) 52 | (defcategory debug) 53 | -------------------------------------------------------------------------------- /hinge.asd: -------------------------------------------------------------------------------- 1 | (defpackage hinge-system 2 | (:use :asdf)) 3 | (in-package :hinge-system) 4 | 5 | (defsystem :hinge 6 | :description "A synonym for node. Something like an evented framework in and for CL." 7 | :version "0.0.1" 8 | :depends-on (:ev 9 | :zmq 10 | :closer-mop 11 | :bordeaux-threads 12 | :arnesi 13 | :log5 14 | :alexandria 15 | :iolib 16 | :uuid) 17 | 18 | :components ((:module "src" :components 19 | ((:module "patches" :components 20 | ((:file "zmq"))) 21 | 22 | (:file "package" :depends-on ("patches")) 23 | (:file "helpers" :depends-on ("package")) 24 | 25 | ;; Basic reactor 26 | (:file "hinge" :depends-on ("package" "helpers")) 27 | (:file "generics" :depends-on ("package")) 28 | (:file "methods" :depends-on ("generics" "hinge" "pool")) 29 | 30 | ;; Async job pool 31 | (:file "pool" :depends-on ("emitter")) 32 | 33 | ;; Event emitter 34 | (:file "emitter" :depends-on ("hinge" "generics")) 35 | 36 | ;; Network 37 | (:file "socket" :depends-on ("pool" "emitter")) 38 | (:file "zmq-socket" :depends-on ("socket")) 39 | (:file "server" :depends-on ("emitter" "helpers" "socket")) 40 | 41 | (:module "http" :depends-on ("package" "server" "socket") :components 42 | ((:file "package") 43 | (:file "fsm" :depends-on ("package")) 44 | (:file "parser" :depends-on ("fsm")) 45 | (:file "request" :depends-on ("package")) 46 | (:file "http-server" :depends-on ("parser" "request")))))))) 47 | -------------------------------------------------------------------------------- /src/http/http-server.lisp: -------------------------------------------------------------------------------- 1 | (in-package :hinge.http) 2 | 3 | ;; Server 4 | (defclass http-server (server) 5 | ()) 6 | 7 | (defmethod initialize-instance :after ((server http-server) &key) 8 | (add-listener server "connection" 9 | (lambda (client) 10 | (make-instance 'http-peer :server server :socket client)))) 11 | 12 | ;; HTTP Peer 13 | (defclass http-peer (emitter) 14 | ((server :initarg :server 15 | :accessor server) 16 | (socket :initarg :socket 17 | :accessor sock) 18 | (parser :accessor parser))) 19 | 20 | (defmethod initialize-instance :after ((peer http-peer) &key) 21 | (setf (parser peer) (make-instance 'request-parser :peer peer)) 22 | 23 | (add-listener peer "request" 24 | (lambda (parser) 25 | (let* ((request (make-instance 'http-request :peer peer 26 | :http-method (http-method (request-fsm parser)) 27 | :resource (resource (request-fsm parser)) 28 | :version (version (request-fsm parser)) 29 | :headers (headers (headers-fsm parser)) 30 | :body (body (body-fsm parser)))) 31 | (response (make-instance 'http-response :request request))) 32 | (when (string-equal (cdr (assoc "Connection" (headers request) :test #'string-equal)) 33 | "close") 34 | (setf (header response "Connection") "close")) 35 | (emit (server peer) "request" request response)))) 36 | 37 | (add-listener peer "error" 38 | (lambda (e) 39 | (format t "Error: ~S~%" e) 40 | (close (sock peer)))) 41 | 42 | (add-listener (sock peer) "data" 43 | (lambda (data) 44 | (funcall (parser peer) data))) 45 | 46 | (add-listener (sock peer) "close" 47 | (lambda (_) 48 | (declare (ignore _))))) 49 | -------------------------------------------------------------------------------- /src/hinge.lisp: -------------------------------------------------------------------------------- 1 | (in-package :hinge) 2 | 3 | ;; Dynamic default hinge 4 | (defvar *hinge* nil "The default hinge reactor.") 5 | (defun get-default-hinge (&optional reset) 6 | (when (and reset *hinge*) 7 | (close *hinge*) 8 | (setf *hinge* nil)) 9 | 10 | (or *hinge* 11 | (setf *hinge* (make-instance 'hinge)))) 12 | 13 | ;; Classes 14 | ;;; Queue drained by an idle runner 15 | (defclass running-queue (c2mop:funcallable-standard-object) 16 | ((owner :initarg :owner :accessor owner) 17 | 18 | (queue :initform (make-instance 'queue) :accessor queue) 19 | (priority :initarg :priority :initform 0 :accessor priority) 20 | (runner :initform (make-instance 'ev:ev-idle) :accessor runner)) 21 | (:metaclass c2mop:funcallable-standard-class) 22 | (:documentation "A wrapper that binds together a queue and an idle runner 23 | to process it.")) 24 | 25 | (defgeneric event-callback (inst l w e) 26 | (:documentation "Callback curried and submitted to libev for the `runner' of `inst'") 27 | (:method (inst l w e) 28 | (declare (ignore l w e)) 29 | (if-let (thunk (dequeue (queue inst))) 30 | (funcall thunk) 31 | (ev:stop-watcher (owner inst) (runner inst) :keep-callback t)))) 32 | 33 | (defmethod enqueue ((rqueue running-queue) thunk) 34 | (enqueue (queue rqueue) thunk) 35 | (ev:start-watcher (owner rqueue) (runner rqueue))) 36 | 37 | (defmethod close ((rqueue running-queue) &key &allow-other-keys) 38 | (ev:stop-watcher (owner rqueue) (runner rqueue))) 39 | 40 | (defmethod initialize-instance :after ((inst running-queue) &key) 41 | "Bind the `inst' funcallable callback. 42 | Set the watcher priority and bind the instance as the callback" 43 | (c2mop:set-funcallable-instance-function inst (curry #'event-callback inst)) 44 | (setf (ev:watcher-slot (runner inst) :priority) (priority inst)) 45 | (ev:set-idle (owner inst) (runner inst) inst)) 46 | 47 | ;;; Hinge 48 | (defclass hinge (ev:ev-loop) 49 | ((bg-pool :accessor bg-pool 50 | :documentation "Background work threadpool") 51 | 52 | (queues :initform '((:low . 0) 53 | (:normal . 1) 54 | (:high . 2)) 55 | :accessor queues 56 | :documentation "A set of work queues. 57 | If an alist of (:name . priority) it will be transformed 58 | to a hashtable of {:name => (ev:idle-watcher :priority priority)}"))) 59 | -------------------------------------------------------------------------------- /src/server.lisp: -------------------------------------------------------------------------------- 1 | (in-package :hinge) 2 | 3 | ;; Class 4 | (defclass server (emitter) 5 | ((acceptor :initform (vector nil nil) 6 | :accessor acceptor 7 | :documentation "The listen socket of the server and the watcher for it as a 2-vector.") 8 | (peers :initform (list) 9 | :accessor peers 10 | :documentation "Sockets of any accepted peers."))) 11 | 12 | ;; Generics -- User API 13 | (defgeneric bind (server port &optional host) 14 | (:documentation "Start listening for incoming connections for this `server' on the 15 | given `port' and `host', if given. If `host' the server will listen on any interface.")) 16 | (defgeneric connection (server) 17 | (:documentation "Called when a new connection is signaled on `server'. 18 | The connection is accepted and emitted with the `connection' event.")) 19 | 20 | ;; Methods 21 | (defmethod bind ((server server) (port number) &optional (host sockets:+ipv4-unspecified+)) 22 | (let* ((sock (sockets:make-socket :ipv6 nil :connect :passive 23 | :local-host host 24 | :local-port port 25 | :reuse-address t)) 26 | (watcher (make-instance 'ev:ev-io-watcher))) 27 | 28 | (ev:set-io-watcher (owner server) watcher (socket-fd sock) ev:EV_READ 29 | #'(lambda (l w e) 30 | (declare (ignore l w e)) 31 | (connection server))) 32 | (ev:start-watcher (owner server) watcher) 33 | 34 | (setf (sock-of (acceptor server)) sock 35 | (watcher-of (acceptor server)) watcher) 36 | 37 | (prog1 server 38 | (emit server "listening" server)))) 39 | 40 | (defmethod connection ((server server)) 41 | (let* ((peer-sock (sockets:accept-connection (sock-of (acceptor server)) :wait t)) 42 | (hinge-sock (make-instance 'socket :sock peer-sock))) 43 | (add-listener hinge-sock "close" 44 | (lambda (sock) 45 | (setf (peers server) (remove sock (peers server))))) 46 | (push hinge-sock (peers server)) 47 | (prog1 server 48 | (emit server "connection" hinge-sock)))) 49 | 50 | (defmethod close ((server server) &key abort) 51 | "Close the accepting socket to prevent further connections 52 | from arriving." 53 | (declare (ignore abort)) 54 | (when (acceptor server) 55 | (ev:stop-watcher (owner server) (watcher-of (acceptor server))) 56 | (close (sock-of (acceptor server))) 57 | (emit server "close" server))) 58 | -------------------------------------------------------------------------------- /examples/external.lisp: -------------------------------------------------------------------------------- 1 | ;; This demonstrates the same server as the one in `examples/async.lisp' 2 | ;; but using external symbols in a separate package. 3 | ;; 4 | ;; The driver below should be evaluated once the server is running 5 | ;; 6 | ;; Server setup 7 | ;;;;;;;;;;;;;;; 8 | (ql:quickload :hinge) 9 | (defpackage :hinge-example 10 | (:use :cl :hinge)) 11 | (in-package :hinge-example) 12 | 13 | (defparameter *ctx* (zmq:init 1)) 14 | (defparameter *addr* "ipc:///tmp/sock.command") 15 | 16 | (let ((sock (make-instance 'zmq-socket :type :sub :context *ctx*))) 17 | (zmq:setsockopt (sock sock) :subscribe "") 18 | (bind sock *addr*) 19 | 20 | (add-listener sock "data" 21 | (lambda (data) 22 | (let ((data (eval (read-from-string (babel:octets-to-string data))))) 23 | (format t "Got some data: ~S~%" data) 24 | (async (:success (lambda (result) 25 | (format t "Got: ~s in ~A~%" result (bt:current-thread))) 26 | :failure (lambda (condition) 27 | (format t "Error: ~s in ~A~%" condition (bt:current-thread)))) 28 | (format t "Doing division in: ~A~%" (bt:current-thread)) 29 | (/ 1337.0 data)))))) 30 | 31 | (set-interval (get-default-hinge) 10 32 | (lambda () (format t "Still kicking: ~S~%" (get-universal-time)))) 33 | 34 | (run :default) 35 | 36 | 37 | ;;;;;;;;;;;; 38 | ;; Driver ;; 39 | ;;;;;;;;;;;; 40 | (defun send-divisor (n) 41 | (zmq:with-context (ctx 1) 42 | (zmq:with-socket (pub ctx :pub) 43 | (zmq:connect pub *addr*) 44 | (zmq:send! pub (prin1-to-string n))))) 45 | 46 | ;; Perform a legal asynchronous division. 47 | ;; 48 | ;; The server should output a series of lines that look like the following, 49 | ;; potentially with some additional debug output as the `:success' callback 50 | ;; is invoked. 51 | ;; Doing division in: # 52 | ;; Got: 668.5 in # 53 | (send-divisor 2) 54 | 55 | ;; Perform an illegal asynchronous division, resulting in an error. 56 | ;; 57 | ;; The server should output similar lines as before, except this time 58 | ;; you should note that the `:failure' callback is invoked with the 59 | ;; signaled condition: 60 | ;; Doing division in: # 61 | ;; Error: # in # 62 | (send-divisor 0) 63 | -------------------------------------------------------------------------------- /examples/async.lisp: -------------------------------------------------------------------------------- 1 | ;; Server Setup 2 | ;; 3 | ;; This will run a server on an IPC ZeroMQ socket bound to /tmp/sock.command 4 | ;; as a `ZMQ_SUB' socket. Every message that is received is assumed to be 5 | ;; a number. 6 | ;; 7 | ;; When a message is received, it is read and eval'ed to convert it to a native 8 | ;; number, then an asynchronous job is scheduled to perform a division 9 | ;; of the number `1337.0' by the input. 10 | ;; 11 | ;; No data is returned over the network, it simply generates informational 12 | ;; output. 13 | (ql:quickload :hinge) 14 | (in-package :hinge) 15 | 16 | (defparameter *ctx* (zmq:init 1)) 17 | (defparameter *sock* (make-instance 'zmq-socket :type :sub :context *ctx*)) 18 | (zmq:setsockopt (sock *sock*) :subscribe "") 19 | (bind *sock* "ipc:///tmp/sock.command") 20 | 21 | (add-listener *sock* "data" 22 | (lambda (data) 23 | (let* ((data-str (babel:octets-to-string data)) 24 | (data (eval (read-from-string data-str)))) 25 | (format t "Got some data: ~S~%" data) 26 | (async (:success (lambda (result) 27 | (format t "Got: ~s in ~A~%" result (bt:current-thread))) 28 | :failure (lambda (condition) 29 | (format t "Error: ~s in ~A~%" condition (bt:current-thread)))) 30 | (format t "Doing division in: ~A~%" (bt:current-thread)) 31 | (/ 1337.0 data))))) 32 | 33 | (set-interval (get-default-hinge) 10 34 | (lambda () (format t "Still kicking: ~S~%" (get-universal-time)))) 35 | 36 | (run :default) 37 | 38 | 39 | ;; Command 40 | ;; -- Should be run in a separate thread or lisp process 41 | ;; or interactively from SLIME while the above server is running 42 | (ql:quickload :hinge) 43 | 44 | (defun send-divisor (n) 45 | (zmq:with-context (ctx 1) 46 | (zmq:with-socket (pub ctx :pub) 47 | (zmq:connect pub "ipc:///tmp/sock.command") 48 | (zmq:send! pub (prin1-to-string n))))) 49 | 50 | 51 | ;; Perform a legal asynchronous division. 52 | ;; 53 | ;; The server should output a series of lines that look like the following, 54 | ;; potentially with some additional debug output as the `:success' callback 55 | ;; is invoked. 56 | ;; Doing division in: # 57 | ;; Got: 668.5 in # 58 | (send-divisor 2) 59 | 60 | ;; Perform an illegal asynchronous division, resulting in an error. 61 | ;; 62 | ;; The server should output similar lines as before, except this time 63 | ;; you should note that the `:failure' callback is invoked with the 64 | ;; signaled condition: 65 | ;; Doing division in: # 66 | ;; Error: # in # 67 | (send-divisor 0) 68 | -------------------------------------------------------------------------------- /src/zmq-socket.lisp: -------------------------------------------------------------------------------- 1 | (in-package :hinge) 2 | 3 | (defclass zmq-socket (socket) 4 | ((context :initarg :context 5 | :accessor context) 6 | (sock-type :initarg :type 7 | :accessor sock-type)) 8 | 9 | (:default-initargs . (:sock nil))) 10 | 11 | ;; Init 12 | (defmethod init-watchers :before ((zsock zmq-socket)) 13 | (setf (sock zsock) (or (sock zsock) 14 | (zmq:socket (context zsock) (sock-type zsock))) 15 | (fd zsock) (zmq:getsockopt (sock zsock) :fd))) 16 | 17 | ;; TODO: Finer handling of on-write in ZMQ 18 | (defmethod init-watchers :after ((zsock zmq-socket)) 19 | "Hack measure to prevent the write callback for firing 20 | on the `zmq-socket', since more delicate handling of that event 21 | is required." 22 | (ev:stop-watcher (owner zsock) (svref (watchers zsock) 1))) 23 | 24 | (defmethod resume :after ((zsock zmq-socket)) 25 | (ev:stop-watcher (owner zsock) (svref (watchers zsock) 1))) 26 | 27 | ;; API 28 | (defmethod connect ((zsock zmq-socket) (spec string) &optional host) 29 | "Connect the socket `zsock' to the ZMQ endpoint declared by `spec'. The `host' 30 | parameter is ignored to remain API compatible with the `socket' class." 31 | (declare (ignore host)) 32 | (prog1 zsock 33 | (zmq:connect (sock zsock) spec) 34 | (emit zsock "connect" zsock))) 35 | 36 | (defmethod bind ((zsock zmq-socket) (spec string) &optional host) 37 | "Bind the socket `zsock' to the ZMQ endpoint declared by `spec'. The `host' 38 | parameter is ignored to remain API compatible with the `server' class." 39 | (declare (ignore host)) 40 | (prog1 zsock 41 | (zmq:bind (sock zsock) spec))) 42 | 43 | (defmethod close ((zsock zmq-socket) &key &allow-other-keys) 44 | (zmq:close (sock zsock))) 45 | 46 | (defmethod send ((zsock zmq-socket) data &optional (when-block-fn (lambda (zsock) (declare (ignore zsock))))) 47 | "Attempt to send the data `data' to the socket, if the send operation would block 48 | the callback `when-block-fn' will be invoked with the socket instance." 49 | (handler-case (zmq:send! (sock zsock) data '(:noblock)) 50 | (zmq:eagain-error () 51 | (funcall when-block-fn zsock)))) 52 | 53 | ;; Hooks 54 | (defmethod on-read ((zsock zmq-socket)) 55 | (flet ((get-msg () 56 | (handler-case (zmq:recv! (sock zsock) :array '(:noblock)) 57 | (zmq:eagain-error () nil)))) 58 | 59 | (when (member :pollin (handler-case (zmq:getsockopt (sock zsock) :events) 60 | (zmq:einval-error () nil))) 61 | (do ((msg (get-msg) (get-msg))) 62 | ((not msg) :done) 63 | (emit zsock "data" msg))))) 64 | 65 | (defmethod on-write ((zsock zmq-socket)) 66 | "The ZMQ socket should never be notified of write through libev. 67 | Blocking write failures should be handled with the `send' failure callback." 68 | (log-for (warn) "WARNING: The `on-write' fired for a zmq-socket: ~S" zsock)) 69 | -------------------------------------------------------------------------------- /src/methods.lisp: -------------------------------------------------------------------------------- 1 | (in-package :hinge) 2 | 3 | ;; Methods 4 | (defmethod initialize-instance :after ((hinge hinge) &key) 5 | "Remap the queues descriptions to an HT, then init the pool" 6 | (when-let (q-desc (and (listp (queues hinge)) (every #'consp (queues hinge)) 7 | (queues hinge))) 8 | (setf (queues hinge) (make-hash-table)) 9 | (mapc #'(lambda (name-priority) 10 | (destructuring-bind (name . priority) name-priority 11 | (setf (gethash name (queues hinge)) 12 | (make-instance 'running-queue :owner hinge :priority priority)))) 13 | q-desc)) 14 | 15 | 16 | (setf (bg-pool hinge) (make-instance 'pool :owner hinge))) 17 | 18 | (defmethod queue-work ((hinge hinge) work &optional (queue :low)) 19 | "Enqueue the `work' thunk into the `queue' queue within `hinge'" 20 | (enqueue (gethash queue (queues hinge)) work)) 21 | 22 | (defmethod close ((hinge hinge) &key &allow-other-keys) 23 | (maphash #'(lambda (name queue) 24 | (declare (ignore name)) 25 | (close queue)) 26 | (queues hinge)) 27 | (close (bg-pool hinge))) 28 | 29 | (defmethod run ((hinge (eql :default))) 30 | "Run the event loop then bind a new event loop 31 | instance then bind a new one after completion." 32 | (unwind-protect (run (get-default-hinge)) 33 | (get-default-hinge t))) 34 | 35 | (defmethod run ((hinge hinge)) 36 | "Run the event loop held by `hinge'" 37 | (unwind-protect (ev:event-dispatch hinge nil) 38 | (close hinge))) 39 | 40 | (defmethod set-timeout (hinge timeout (callback symbol)) 41 | "Fetches the function value of `callback' and passes it down." 42 | (set-timeout hinge timeout (symbol-function callback))) 43 | (defmethod set-timeout ((hinge hinge) (timeout number) (callback function)) 44 | "Typechecking and sanitizing wrapper to add a timeout callback." 45 | (flet ((timeout-fun (l w e) 46 | (declare (ignore l e)) 47 | (clear hinge w) 48 | (funcall callback))) 49 | (let ((timeout-cb (make-instance 'ev:ev-timer))) 50 | (ev:set-timer hinge timeout-cb #'timeout-fun (coerce timeout 'double-float)) 51 | (ev:start-watcher hinge timeout-cb) 52 | timeout-cb))) 53 | 54 | (defmethod set-interval (hinge timeout (callback symbol)) 55 | (set-interval hinge timeout (symbol-function callback))) 56 | (defmethod set-interval ((hinge hinge) (timeout number) (callback function)) 57 | (flet ((timeout-fun (l w e) 58 | (declare (ignore l w e)) 59 | (funcall callback))) 60 | (let ((timeout-cb (make-instance 'ev:ev-timer)) 61 | (timeout (coerce timeout 'double-float))) 62 | (ev:set-timer hinge timeout-cb #'timeout-fun timeout :repeat timeout) 63 | (ev:start-watcher hinge timeout-cb) 64 | timeout-cb))) 65 | 66 | (defmethod clear ((hinge hinge) (handle ev:ev-watcher)) 67 | (ev:stop-watcher hinge handle)) 68 | -------------------------------------------------------------------------------- /examples/pause.lisp: -------------------------------------------------------------------------------- 1 | ;; Pause/Resume sockets. 2 | ;; This server sets up a set of sockets in an event machine. 3 | ;; On the `*feed-addr*', one socket will bind and consider itself the consumer. 4 | ;; it will wait for messages to arrive on the wire, and echo them to the terminal 5 | ;; as strings with a timestamp. 6 | ;; 7 | ;; A second socket will connect as a producer, and every second will send the 8 | ;; universal time as a string to the `*feed-addr*' address, notifying the operator of any failures. 9 | ;; 10 | ;; A third socket will listen on the `*command-addr*' and expect one of two strings: 11 | ;; "pause" or "resume" and will invoked the same-named method on the feed-consuming socket. 12 | ;; 13 | ;; The pause and resume methods will pause the arrival of additional data events on the socket, 14 | ;; preventing it from doing any IO during the interval. 15 | ;; 16 | ;;; Server setup 17 | (ql:quickload :hinge) 18 | (in-package :hinge) 19 | 20 | (defparameter *ctx* (zmq:init 1)) 21 | (defparameter *command-addr* "ipc:///tmp/sock.command") 22 | (defparameter *feed-addr* "ipc:///tmp/sock.feed") 23 | 24 | 25 | (defparameter *command* (make-instance 'zmq-socket :type :pull :context *ctx*)) 26 | (bind *command* *command-addr*) 27 | 28 | (defparameter *feed-reader* (make-instance 'zmq-socket :type :pull :context *ctx*)) 29 | ;(zmq:setsockopt (sock *feed-reader*) :subscribe "") 30 | (bind *feed-reader* *feed-addr*) 31 | 32 | (defparameter *feed-producer* (make-instance 'zmq-socket :type :push :context *ctx*)) 33 | (connect *feed-producer* *feed-addr*) 34 | 35 | ;; Feed Producer interval 36 | (set-interval (get-default-hinge) 1 37 | (lambda () 38 | (send *feed-producer* (princ-to-string (get-universal-time)) 39 | (lambda (sock) 40 | (format t "Failed to write a feed number: ~S~%" (get-universal-time)))))) 41 | 42 | ;; Feed consumer 43 | (add-listener *feed-reader* "data" 44 | (lambda (data) 45 | (let ((s-data (babel:octets-to-string data))) 46 | (format t "Got data ~S at ~S~%" s-data (get-universal-time))))) 47 | 48 | ;; Command socket 49 | (add-listener *command* "data" 50 | (lambda (data) 51 | (let ((s-data (babel:octets-to-string data))) 52 | (format t "Got command: ~S~%" s-data) 53 | (when (string= s-data "pause") 54 | (format t "=> Pausing.~%") 55 | (pause *feed-reader*)) 56 | (when (string= s-data "resume") 57 | (format t "=> Resuming.~%") 58 | (resume *feed-reader*))))) 59 | 60 | ;; Run the event loop 61 | (run :default) 62 | 63 | ;;; Driver 64 | ;;;; This should be evaluated in a separate shell 65 | ;;;; or interactively while the above server is running 66 | (ql:quickload :hinge) 67 | (in-package :hinge) 68 | 69 | (defun send-command (command) 70 | (zmq:with-context (ctx 1) 71 | (zmq:with-socket (s ctx :push) 72 | (zmq:connect s *command-addr*) 73 | (zmq:send! s command)))) 74 | 75 | ;; Evaluating this should force the server to stop echoing back data 76 | ;; to the terminal, but it should continue to produce data for itself 77 | ;; without incident. 78 | (send-command "pause") 79 | 80 | ;; Once this command is received, IO is resumed. You should see 81 | ;; the backlog of messages delivered earlier appear as data events on the wire. 82 | ;; in rapid succession, then again proceed lockstep with the sends. 83 | (send-command "resume") 84 | -------------------------------------------------------------------------------- /src/http/fsm.lisp: -------------------------------------------------------------------------------- 1 | (in-package :hinge.http) 2 | (defcategory state-machine) 3 | 4 | (defclass standard-state-machine (c2mop:funcallable-standard-object) 5 | ((state :initform :initial :initarg :state 6 | :accessor state 7 | :documentation "The current state of the state-machine.") 8 | (last-event :initform (get-internal-real-time) 9 | :accessor last-event 10 | :documentation "The timestamp of the last event.")) 11 | 12 | (:metaclass c2mop:funcallable-standard-class) 13 | (:documentation "(funcall this-instance event-from-bus) 14 | Every iteration of the event machine the `last-event' slot is updated with `get-internal-real-time' before 15 | the funcallable instance application. 16 | 17 | SUBCLASS NOTE: Make sure to include ```(:metaclass c2mop:funcallable-standard-class)``` in your 18 | subclass definition, or else the funcallable instance will not function correctly.")) 19 | 20 | (defgeneric standard-state-machine-event (machine state event) 21 | (:documentation "Method specialized by `defstate' to handle the actual driving of 22 | the state machine with events.")) 23 | 24 | (defmethod initialize-instance :before ((machine standard-state-machine) &key) 25 | "Bind a (funcallable machine event) driver to the event machine instance. 26 | See `defstate' for the reasoning and function. This method is closure plumbing." 27 | (c2mop:set-funcallable-instance-function 28 | machine 29 | #'(lambda (event) 30 | (log-for (state-machine trace) "~A event ~A" machine event) 31 | (multiple-value-bind (next-state recur-p) 32 | (standard-state-machine-event machine (state machine) event) 33 | 34 | (log-for (state-machine trace) "Next state: ~A Recur?: ~A" next-state recur-p) 35 | (setf (last-event machine) (get-internal-real-time) 36 | (state machine) (or next-state (state machine))) 37 | 38 | (if recur-p 39 | (funcall machine event) 40 | (values machine (state machine))))))) 41 | 42 | (defmethod initialize-instance :after ((machine standard-state-machine) &key)) 43 | 44 | (defmacro deffsm (name parents slots &rest options) 45 | "Define an fsm `name' as in (defclass name parents slots options) 46 | This macro takes care of the inheritance chain of `standard-state-machine' 47 | and the funcallable metaclass" 48 | `(defclass ,name ,(append (list 'standard-state-machine) parents) 49 | ,slots 50 | (:metaclass c2mop:funcallable-standard-class) 51 | ,@options)) 52 | 53 | (defmacro defstate (machine-type state-name (machine-sym event-sym) &body body) 54 | "Helper macro to define states for the machine of type `machine-type'. 55 | 56 | The generated state methods will be specialized on `machine-type' and `state-name', and 57 | subclasses of `standard-state-machine' should use this property to extend the state machine. 58 | 59 | `state-name' is the identifier for this state, and names it. Event invocations will 60 | use this name to determine which state the machine is in, and error out if one cannot be found. 61 | The event will be bound to the symbol named `event-sym' declared as in a two-argument lambda list. 62 | Each invocation of this state with the even bound to `event-sym' will evaluate `body' forms as 63 | in a method invocation and the resulting value of the evaluation should return the next state 64 | for the machine as a `:keyword', or `nil' to indicate the machine should remain in its current state. 65 | The symbol named by `machine-sym' will be bound to the currently executing state machine. 66 | The current state is available in `state', though should be accessed as \"(state machine-sym)\" 67 | 68 | If the state produces two-value return, it is interpreted as (values next-state recur-event) 69 | and if recur-event is non-nil the same event is sent into the machine again after performing 70 | the transition into next-state. This is useful if simply performing a state transition would 71 | result in event starvation." 72 | `(defmethod standard-state-machine-event 73 | ((,machine-sym ,machine-type) (state (eql ,state-name)) ,event-sym) 74 | ,@body)) 75 | -------------------------------------------------------------------------------- /src/emitter.lisp: -------------------------------------------------------------------------------- 1 | (in-package :hinge) 2 | 3 | ;; Class 4 | (defclass emitter () 5 | ((owner :accessor owner 6 | :initarg :owner 7 | :initform (get-default-hinge) 8 | :documentation "The hinge instance the event emitter functions within.") 9 | 10 | (oneshots :accessor oneshots) 11 | (listeners :accessor listeners))) 12 | 13 | (defgeneric reset (emitter) 14 | (:documentation "Reset the emitter to its empty initial state.") 15 | (:method ((emitter emitter)) 16 | (setf (oneshots emitter) (make-hash-table) 17 | (listeners emitter) (make-hash-table :test 'equalp)))) 18 | 19 | (defmethod initialize-instance :after ((emitter emitter) &key) 20 | (unless (owner emitter) 21 | (error "Emitter ~A has no owner." emitter)) 22 | (reset emitter)) 23 | 24 | ;; Generics 25 | (defgeneric emit (emitter event &rest args) 26 | (:documentation "Emit `event' on the `emitter', invoking callbacks, if any, with `args'")) 27 | (defgeneric deliver (emitter event args) 28 | (:documentation "Queue the invocation of callbacks for the `event' event with `args'")) 29 | 30 | (defgeneric add-listener (emitter event callback) 31 | (:documentation "Add a listener to `emitter' so when `event' 32 | is emitted `callback' is called with any arguments that are emitted with the event.")) 33 | (defgeneric listen-once (emitter event callback) 34 | (:documentation "Add a listener to `emitter' so when `event' 35 | is emitted `callback' is called with any arguments that are emitted. The callback 36 | only fires once, then it is removed.")) 37 | 38 | (defgeneric remove-listener (emitter event callback) 39 | (:documentation "Remove a listener invoking `callback' from `emitter' from the chain for `event'.")) 40 | (defgeneric clear-listeners (emitter &optional event) 41 | (:documentation "remove either all listeners on `emitter' or just those bound to `event' if given.")) 42 | 43 | ;; Methods 44 | (defmethod deliver ((emitter emitter) event args) 45 | (let ((registered (gethash event (listeners emitter)))) 46 | (flet ((queue-cb (cb) 47 | (when (remhash cb (oneshots emitter)) 48 | (remove-listener emitter event cb)) 49 | (queue-work (owner emitter) (curry #'apply cb args) :normal))) 50 | (mapc #'queue-cb registered)))) 51 | 52 | (defmethod emit ((emitter emitter) (event string) &rest args) 53 | "Enqueue the delivery of an `event' with `args'. The event will 54 | be delivered at some point in the future, but very soon, in the order 55 | that it was emitted relative to other events." 56 | (flet ((emit-thunk () 57 | (deliver emitter event args))) 58 | (queue-work (owner emitter) #'emit-thunk))) 59 | 60 | (defmethod add-listener ((emitter emitter) (event string) (callback symbol)) 61 | (add-listener emitter event (symbol-function callback))) 62 | (defmethod add-listener ((emitter emitter) (event string) (callback function)) 63 | (prog1 emitter 64 | (let ((registered (gethash event (listeners emitter) (list)))) 65 | (setf (gethash event (listeners emitter)) 66 | (append registered (list callback))) 67 | emitter))) 68 | (defmethod add-listener :after ((emitter emitter) (event string) (callback function)) 69 | (emit emitter "new-listener" event callback)) 70 | 71 | (defmethod listen-once ((emitter emitter) (event string) (callback symbol)) 72 | (listen-once emitter event (symbol-function callback))) 73 | (defmethod listen-once ((emitter emitter) (event string) (callback function)) 74 | (prog1 emitter 75 | (add-listener emitter event callback) 76 | (setf (gethash callback (oneshots emitter)) t))) 77 | 78 | (defmethod remove-listener ((emitter emitter) (event string) (callback symbol)) 79 | (remove-listener emitter event (symbol-function callback))) 80 | (defmethod remove-listener ((emitter emitter) (event string) (callback function)) 81 | (prog1 emitter 82 | (let ((registered (remove callback (gethash event (listeners emitter))))) 83 | (if registered 84 | (setf (gethash event (listeners emitter)) registered) 85 | (remhash event (listeners emitter)))))) 86 | 87 | (defmethod clear-listeners ((emitter emitter) &optional event) 88 | (prog1 emitter 89 | (if event 90 | (and (gethash event (listeners emitter)) 91 | (remhash event (listeners emitter))) 92 | (reset emitter)))) 93 | -------------------------------------------------------------------------------- /examples/pingpong.lisp: -------------------------------------------------------------------------------- 1 | ;; Starts a server that accepts TCP connections on port 4545 2 | ;; and listens for commands "PING", "RANDOM" and "DIE" 3 | ;; PING is replied to with PONG, and the connection is maintained 4 | ;; RANDOM reports a random number to the requester, calculated asynchronously (for demonstration) 5 | ;; DIE disconnects everyone and should gracefully shut down the server 6 | ;; any other command causes the peer to disconnect 7 | ;; 8 | ;; Connected peers are bound by a 30 second inactivity timeout, after which they will 9 | ;; be notified and disconnected. 10 | ;; 11 | ;; Original application of this code was to aid in the development of the socket class 12 | (ql:quickload :hinge) 13 | (in-package :hinge) 14 | 15 | (defparameter *server* (make-instance 'server)) 16 | (defparameter *client* (make-instance 'socket)) 17 | 18 | (add-listener *server* "connection" 19 | (lambda (peer) 20 | (format t "New client: ~A~%" peer) 21 | (set-timeout peer 30 22 | (lambda (socket) 23 | (format t "Peer ~S is timing out.~%" socket) 24 | (send peer (babel:string-to-octets (format nil "You have timed out.~%")) 25 | (lambda (sock) 26 | (close sock))))) 27 | 28 | (add-listener peer "data" 29 | (lambda (data) 30 | (let ((data-str (string-right-trim '(#\return #\linefeed #\space) 31 | (babel:octets-to-string data)))) 32 | (cond ((string= "DIE" data-str) 33 | (format t "Asked to die.~%") 34 | (close peer) 35 | (close *server*) 36 | (close *client*)) 37 | 38 | ((string= "PING" data-str) 39 | (format t "Ponging ~A~%" peer) 40 | (send peer (babel:string-to-octets (format nil "PONG~%")))) 41 | 42 | ((string= "RANDOM" data-str) 43 | (format t "Random number request.~%") 44 | (async (:success (lambda (n) 45 | (send peer 46 | (babel:string-to-octets 47 | (format nil "Random: ~A~%" n))))) 48 | (random 100))) 49 | 50 | 51 | (t 52 | (format t "Unknown request, booting ~A: ~S~%" peer data-str) 53 | (send peer (babel:string-to-octets (format nil "Invalid request!~%")) 54 | (lambda (sock) 55 | (close sock)))))))) 56 | 57 | (add-listener peer "close" 58 | (lambda (peer) 59 | (format t "~A Left.~%" peer))))) 60 | 61 | 62 | 63 | (add-listener *client* "connect" 64 | (lambda (sock) 65 | (format t "Pinger client connected! Starting timer.~%") 66 | (let ((pinger (set-interval (owner sock) 5 67 | (lambda () 68 | (format t "Pinging!~%") 69 | (send sock (babel:string-to-octets "PING")))))) 70 | (add-listener sock "close" 71 | (lambda (s) 72 | (format t "Stopping the pinger.~%") 73 | (clear (owner sock) pinger)))))) 74 | 75 | (add-listener *client* "error" 76 | (lambda (c) 77 | (format t "Socket ~S error: ~S~%" *client* c) 78 | (describe c))) 79 | 80 | 81 | ;; Bind the server 82 | (bind *server* 4545) 83 | (format t "Bound ~S.~%" *server*) 84 | ;; Connect the client 85 | (connect *client* 4545) 86 | 87 | ;; Run the event loop 88 | (run :default) 89 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Hinge. A synonym for node. 2 | 3 | An evented framework for Common Lisp. 4 | Driven by [libev](http://software.schmorp.de/pkg/libev.html), like the cool kids. 5 | 6 | Check out the [wiki](https://github.com/sshirokov/hinge/wiki) for docs and writeups 7 | and stop by the `#hinge` channel on [Freenode](http://freenode.net/irc_servers.shtml) 8 | to bug me in real time. 9 | 10 | ## Requirements 11 | 12 | ### System level dependencies 13 | 14 | * [libev](http://software.schmorp.de/pkg/libev.html) 15 | * [ZeroMQ](http://www.zeromq.org/) (2.1.11+) 16 | * [SBCL](http://www.sbcl.org/) (With thread support) 17 | * [curl](http://curl.haxx.se/) (Required by `make develop`) 18 | 19 | [CCL](http://ccl.clozure.com/) is also supported, but SBCL is the 20 | primary development platform, and is favored in the makefiles. 21 | 22 | ### Dependencies built outside of quicklisp 23 | 24 | These deps are fetched and built with `make develop` 25 | 26 | * [cl-ev](https://github.com/sbryant/cl-ev) 27 | * [CFFI](http://common-lisp.net/project/cffi/) (Built from git, to support lisp-zmq) 28 | * [lisp-zmq](https://github.com/galdor/lisp-zmq) 29 | 30 | ## Quickstart 31 | 32 | Clone and init the project 33 | 34 | ```sh 35 | # Clone the repo 36 | $ git clone https://github.com/sshirokov/hinge.git 37 | $ cd hinge 38 | 39 | # Init the enviornment 40 | $ make develop 41 | ``` 42 | 43 | Once you run `make develop` you're free to use Hinge in other 44 | Lisp systems as long as you don't relocate the project directory. 45 | 46 | Fire up the REPL and evaluate the following. 47 | It should boot up and keep running an HTTP server on port 4545 48 | 49 | ```common-lisp 50 | (ql:quickload :hinge) 51 | (defpackage :hinge-example 52 | (:use :cl :hinge :hinge.http)) 53 | 54 | (in-package :hinge-example) 55 | 56 | (let ((server (make-instance 'http-server))) 57 | (add-listener server "request" 58 | (lambda (request response) 59 | (declare (ignorable request)) 60 | (write-head response 200 '(("Content-Type" . "text/html"))) 61 | (end response "Hello world!"))) 62 | 63 | (bind server 4545)) 64 | 65 | (run :default) 66 | ``` 67 | 68 | You should now be able to throw HTTP requests at localhost:4545 with something 69 | like `curl` and get replies: 70 | 71 | ```sh 72 | $ time curl -i localhost:4545 73 | HTTP/1.1 200 OK 74 | Content-Length: 12 75 | Content-Type: text/html 76 | 77 | Hello world! 78 | real 0m0.006s 79 | user 0m0.004s 80 | sys 0m0.000s 81 | ``` 82 | 83 | You can also throw something like `ab` at it, 84 | which is somewhat mandatory despite being a poor benchmark: 85 | 86 | ```sh 87 | $ ab -c 10 -n 1000 http://localhost:4545/ 88 | This is ApacheBench, Version 2.3 <$Revision: 655654 $> 89 | Copyright 1996 Adam Twiss, Zeus Technology Ltd, http://www.zeustech.net/ 90 | Licensed to The Apache Software Foundation, http://www.apache.org/ 91 | 92 | Benchmarking localhost (be patient) 93 | Completed 100 requests 94 | Completed 200 requests 95 | Completed 300 requests 96 | Completed 400 requests 97 | Completed 500 requests 98 | Completed 600 requests 99 | Completed 700 requests 100 | Completed 800 requests 101 | Completed 900 requests 102 | Completed 1000 requests 103 | Finished 1000 requests 104 | 105 | 106 | Server Software: 107 | Server Hostname: localhost 108 | Server Port: 4545 109 | 110 | Document Path: / 111 | Document Length: 12 bytes 112 | 113 | Concurrency Level: 10 114 | Time taken for tests: 0.397 seconds 115 | Complete requests: 1000 116 | Failed requests: 0 117 | Write errors: 0 118 | Total transferred: 51000 bytes 119 | HTML transferred: 12000 bytes 120 | Requests per second: 2519.51 [#/sec] (mean) 121 | Time per request: 3.969 [ms] (mean) 122 | Time per request: 0.397 [ms] (mean, across all concurrent requests) 123 | Transfer rate: 125.48 [Kbytes/sec] received 124 | 125 | Connection Times (ms) 126 | min mean[+/-sd] median max 127 | Connect: 0 0 0.0 0 0 128 | Processing: 2 3 9.7 3 214 129 | Waiting: 1 2 9.6 2 213 130 | Total: 2 3 9.7 3 214 131 | 132 | Percentage of the requests served within a certain time (ms) 133 | 50% 3 134 | 66% 3 135 | 75% 3 136 | 80% 3 137 | 90% 3 138 | 95% 3 139 | 98% 4 140 | 99% 5 141 | 100% 214 (longest request) 142 | ``` -------------------------------------------------------------------------------- /src/patches/zmq.lisp: -------------------------------------------------------------------------------- 1 | (in-package :zmq) 2 | 3 | (export 'send!) 4 | (export 'recv!) 5 | 6 | ;; Helper declaration and export 7 | (defgeneric send! (sock msg &optional flags count) 8 | (:documentation "A wrapper around the low level `zmq:send' 9 | supporting wrapping native types in ephemeral messages for transport.")) 10 | (defgeneric recv! (sock msg &optional flags count) 11 | (:documentation "A wrapper around the low level `zmq:recv'")) 12 | 13 | ;; Type-specific helpers 14 | (defmethod send! (sock (seq sequence) &optional flags count) 15 | "Translate a sequence into a 0MQ message and forward the method call." 16 | (zmq:with-msg-init-data (msg seq) 17 | (send! sock msg flags count))) 18 | 19 | (defmethod recv! (sock (msg (eql :string)) &optional flags count) 20 | "Receive a message from `sock' and return the contents as a string." 21 | (zmq:with-msg-init (msg) 22 | (multiple-value-bind (r c) (recv! sock msg flags count) 23 | (declare (ignore r)) 24 | (values (zmq:msg-data-string msg) c)))) 25 | 26 | (defmethod recv! (sock (msg (eql :array)) &optional flags count) 27 | "Receive a message from `sock' and return the contents as an array." 28 | (zmq:with-msg-init (msg) 29 | (multiple-value-bind (r c) (recv! sock msg flags count) 30 | (declare (ignore r)) 31 | (values (zmq:msg-data-array msg) c)))) 32 | 33 | (defmethod recv! (sock (what (eql :msg)) &optional flags count) 34 | "Receive and return the raw message object. 35 | 36 | !!WARNING!!: The returned value needs to be released with `zmq:msg-close' 37 | when finished with to avoid leaking in foreign code." 38 | (declare (ignore what)) 39 | (let ((msg (zmq:msg-init))) 40 | (handler-case (prog1 msg (recv! sock msg flags count)) 41 | (t (c) 42 | ;; In case of fire, clean up and keep panicing up the stack 43 | (zmq:msg-close msg) 44 | (error c))))) 45 | 46 | ;; Actual low-level interfacing methods. 47 | (defmethod send! (sock msg &optional flags (count 0)) 48 | (let* (condition 49 | (res (handler-case (zmq:send sock msg flags) (zmq:zmq-error (c) (setf condition c) -1))) 50 | (res (cond ((and (= res -1) 51 | (= (iolib.syscalls:errno) (foreign-enum-value 'error-code :eagain)) 52 | (not (member :noblock flags))) 53 | (send! sock msg flags (1+ (or count 0)))) 54 | 55 | (:otherwise 56 | (if (member :noblock flags) 57 | (or (and condition 58 | (signal condition)) 59 | res) 60 | res))))) 61 | (values res count))) 62 | 63 | (defmethod recv! (sock msg &optional flags (count 0)) 64 | (let* (condition 65 | (res (handler-case (zmq:recv sock msg flags) (zmq:zmq-error (c) (setf condition c) -1))) 66 | (res (cond ((and (= res -1) 67 | (= (iolib.syscalls:errno) (foreign-enum-value 'error-code :eagain)) 68 | (not (member :noblock flags))) 69 | (recv! sock msg flags (1+ (or count 0)))) 70 | 71 | (:otherwise 72 | (if (member :noblock flags) 73 | (or (and condition 74 | (signal condition)) 75 | res) 76 | res))))) 77 | (values res count))) 78 | 79 | ;; TODO: These patches should make it into a fork and be destined for 80 | ;; upstream pulls 81 | (export 'with-poll-sockets) 82 | (export 'describe-socket-polls) 83 | (export 'poll-item-socket) 84 | 85 | (defun poll-item-socket (poll-item) 86 | "Return the `socket' of the given `poll-item'" 87 | (foreign-slot-value poll-item 'pollitem 'socket)) 88 | 89 | (defun describe-socket-polls (&key in out err) 90 | "Return two values, a description of pollitems in the form: 91 | ((sock :pollin) (sock2 :pollin :pollout)) from the 92 | sockets passed in as `in' `out' `err' and the number of 93 | items returned in the list" 94 | (flet ((make-pollitem (sock in out err) 95 | (remove nil (list sock 96 | (when (member sock in) :pollin) 97 | (when (member sock out) :pollout) 98 | (when (member sock err) :pollerr))))) 99 | (let* ((pollitems (mapcar #'(lambda (sock) (make-pollitem sock in out err)) 100 | (remove-duplicates (append in out err))))) 101 | (values pollitems (length pollitems))))) 102 | 103 | (defmacro with-poll-sockets ((items-var size-var &key in out err) &body forms) 104 | "Evaluate FORMS in an environment where ITEMS-VAR is bound to a foreign 105 | array of poll items, and SIZE-VAR is bound to the number of polled 106 | items. Poll items are filled according to IN OUT and ERR. Each is a list where each 107 | element describes a socket. Depending on a sockets presence in one or multiple 108 | of these lists a combination of the :POLLIN, :POLLOUT and :POLLERR events will 109 | be watched for the given socket." 110 | (let ((g!pollitems (gensym "pollitems")) 111 | (g!count (gensym "count")) 112 | (g!i (gensym "i")) 113 | (pollitem-size (foreign-type-size 'pollitem))) 114 | `(multiple-value-bind (,g!pollitems ,g!count) (describe-socket-polls :in ,in :out ,out :err ,err) 115 | (with-foreign-object (,items-var 'pollitem ,g!count) 116 | (let ((,g!i 0)) 117 | (dolist (item ,g!pollitems) 118 | (with-foreign-slots ((socket fd events revents) 119 | (inc-pointer ,items-var 120 | (* ,g!i ,pollitem-size)) 121 | pollitem) 122 | (destructuring-bind (handle &rest event-list) item 123 | (cond 124 | ((pointerp handle) 125 | (setf socket handle)) 126 | (t 127 | (setf socket (null-pointer)) 128 | (setf fd handle))) 129 | (setf events (foreign-bitfield-value 130 | 'event-types event-list) 131 | revents 0))) 132 | (incf ,g!i))) 133 | (let ((,size-var ,g!count)) 134 | ,@forms))))) 135 | -------------------------------------------------------------------------------- /src/http/request.lisp: -------------------------------------------------------------------------------- 1 | (in-package :hinge.http) 2 | 3 | (defclass http-request (emitter) 4 | ((peer :initarg :peer :accessor peer) 5 | (http-method :initarg :http-method :accessor http-method) 6 | (resource :initarg :resource :accessor resource) 7 | (version :initarg :version :accessor version) 8 | (headers :initarg :headers :accessor headers) 9 | (body :initarg :body :accessor body))) 10 | 11 | (defclass http-response (emitter) 12 | ((request :initarg :request :accessor request) 13 | 14 | (status-code :initform 200 :accessor status-code) 15 | (status-reason :initform "OK" :accessor status-reason) 16 | (headers :initform (list (cons "Transfer-Encoding" "chunked")) :accessor headers) 17 | 18 | (status-sent :initform nil :accessor status-sent :accessor status-sent-p) 19 | (headers-sent :initform nil :accessor headers-sent-p :accessor headers-sent) 20 | 21 | (body :initform (vector) :accessor body))) 22 | 23 | ;; Response API 24 | (defgeneric write-head (response status &optional reason/headers headers) 25 | (:documentation "Write the status reply `status' with `readon/headers' as 26 | the reason, if it is a string, otherwise a stock reason for the given code. 27 | If `reason/headers' is a list or `headers' is given a call to `set-headers' 28 | is made, adding them to the response headers.")) 29 | 30 | (defgeneric write-headers (response &optional headers) 31 | (:documentation "Add any `headers' to the response headers 32 | of `response' then write the header list to the client.")) 33 | 34 | (defgeneric set-headers (response headers) 35 | (:documentation "Update the outgoing headers on `response' 36 | by adding the headers in the `headers' alist, replacing any 37 | with equal values.")) 38 | 39 | (defgeneric set-header (response header value) 40 | (:documentation "Set a header key `header' to `value' 41 | in the outgoing response headers of `response'. Existing 42 | values are overwritten.")) 43 | 44 | (defgeneric header (response header) 45 | (:documentation "Get a header from `response' named by the key 46 | `header'")) 47 | 48 | ;; Bind header/set-header as a setfable pair 49 | (defsetf header set-header) 50 | 51 | (defgeneric end (response &optional data) 52 | (:documentation "Finish the response. If `data' is given 53 | `send' is called with the data first. 54 | 55 | This method checks the `Connection' header to determine if 56 | the socket should be closed once the response is written, 57 | or if the parser machinery of the peer needs to be reloaded.")) 58 | 59 | ;; Response methods 60 | (defmethod write-head ((response http-response) status &optional reason/headers headers) 61 | (let ((reason (typecase reason/headers 62 | (string reason/headers) 63 | (otherwise "OK"))) 64 | (headers (typecase reason/headers 65 | (list reason/headers) 66 | (otherwise (or headers ()))))) 67 | 68 | (send (sock (peer (request response))) 69 | (babel:string-to-octets 70 | (format nil "~A ~A ~A~A~A" (version (request response)) status reason #\Return #\Newline))) 71 | (setf (status-sent response) t) 72 | 73 | (when headers 74 | (set-headers response headers)))) 75 | 76 | (defmethod write-headers ((response http-response) &optional headers) 77 | (when headers 78 | (set-headers response headers)) 79 | 80 | (mapc #'(lambda (header-pair) 81 | (destructuring-bind (key . value) header-pair 82 | (send (sock (peer (request response))) 83 | (babel:string-to-octets 84 | (format nil "~A: ~A~A~A" key value #\Return #\Newline))))) 85 | (headers response)) 86 | (send (sock (peer (request response))) 87 | (babel:string-to-octets 88 | (format nil "~A~A" #\Return #\Newline))) 89 | (setf (headers-sent response) t)) 90 | 91 | (defmethod set-headers ((response http-response) headers) 92 | (mapc #'(lambda (header-pair) 93 | (destructuring-bind (key . value) header-pair 94 | (set-header response key value))) 95 | headers)) 96 | 97 | (defmethod set-header ((response http-response) (key symbol) value) 98 | (set-header response (symbol-name key) value)) 99 | (defmethod set-header ((response http-response) (key string) value) 100 | (if-let (header (assoc key (headers response) :test #'string-equal)) 101 | (rplacd header value) 102 | (push (cons key value) (headers response)))) 103 | 104 | (defmethod header ((response http-response) (key symbol)) 105 | (header response (symbol-name key))) 106 | (defmethod header ((response http-response) (key string)) 107 | (cdr (assoc key (headers response) :test #'string-equal))) 108 | 109 | (defmethod begin ((response http-response)) 110 | (unless (status-sent-p response) 111 | (write-head response 200 "OK")) 112 | 113 | (unless (headers-sent-p response) 114 | (write-headers response))) 115 | 116 | (defmethod send ((response http-response) data &optional callback) 117 | (declare (ignore callback)) 118 | "Send a chunk to the client. 119 | 120 | If this is the first chunk and there is no content length set, 121 | or no chunked encoding set in the headers of the response a 122 | content-length header is stored before the write. 123 | 124 | If a chunked encoding header is found in the headers of the response 125 | the `data' is written as an HTTP chunk. 126 | 127 | No verification is made that the `data' does not exceed the advertised 128 | content length if one is present. 129 | 130 | If the response code or headers haven't been written yet, they are 131 | written first." 132 | (let ((bindata (if (stringp data) (babel:string-to-octets data) data))) 133 | (unless (or (header response "Content-Length") 134 | (string-equal (header response "Transfer-Encoding") "chunked")) 135 | (setf (header response "Content-Length") (length bindata))) 136 | 137 | (begin response) 138 | 139 | (if (string-equal (header response "Transfer-Encoding") "chunked") 140 | (progn 141 | (send (sock (peer (request response))) 142 | (babel:string-to-octets 143 | (format nil "~x~A~A" (length bindata) #\Return #\Newline))) 144 | 145 | (send (sock (peer (request response))) 146 | bindata) 147 | 148 | (send (sock (peer (request response))) 149 | (babel:string-to-octets 150 | (format nil "~A~A" #\Return #\Newline)))) 151 | 152 | (send (sock (peer (request response))) 153 | bindata)))) 154 | 155 | (defmethod end ((response http-response) &optional data) 156 | (if data 157 | (send response data) 158 | (begin response)) 159 | 160 | (when (string-equal (header response "Transfer-Encoding") "chunked") 161 | (send (sock (peer (request response))) 162 | (babel:string-to-octets 163 | (format nil "0~A~A~A~A" #\Return #\Newline #\Return #\Newline)))) 164 | 165 | (if (or (string-equal (header response "Connection") "close") 166 | (string-equal (version (request response)) "HTTP/1.0")) 167 | 168 | (add-listener (sock (peer (request response))) "drain" 169 | (lambda (sock) 170 | (close sock))) 171 | 172 | (setf (parser (peer (request response))) 173 | (make-instance 'request-parser :peer (peer (request response)))))) 174 | -------------------------------------------------------------------------------- /src/http/parser.lisp: -------------------------------------------------------------------------------- 1 | (in-package :hinge.http) 2 | 3 | ;; HTTP Parser 4 | ;;; Request line parser 5 | (deffsm request-fsm () 6 | ((http-method :initform (make-string-output-stream) :accessor http-method) 7 | (resource :initform (make-string-output-stream) :accessor resource) 8 | (version :initform (make-string-output-stream) :accessor version)) 9 | (:default-initargs . (:state :read-http-method)) 10 | (:documentation "The request line parser FSM. 11 | When the machine arrives in the `:done' state the `http-method', `resource' and 12 | `version' slots are converted into strings.")) 13 | 14 | (defun whitespace-p (code) 15 | "Is the `code' a code-char for a whitespace char?" 16 | (member (code-char code) `(#\Newline #\Linefeed #\Return #\Space #\Tab))) 17 | 18 | (defstate request-fsm :read-http-method (fsm cc) 19 | (if (not (whitespace-p cc)) 20 | (not (write-char (code-char cc) (http-method fsm))) 21 | 22 | (if (char-equal (code-char cc) #\Space) 23 | :read-resource 24 | :error))) 25 | 26 | (defstate request-fsm :read-resource (fsm cc) 27 | (if (not (whitespace-p cc)) 28 | (not (write-char (code-char cc) (resource fsm))) 29 | 30 | (if (char-equal (code-char cc) #\Space) 31 | :read-version 32 | :error))) 33 | 34 | (defstate request-fsm :read-version (fsm cc) 35 | (if (not (whitespace-p cc)) 36 | (not (write-char (code-char cc) (version fsm))) 37 | 38 | (if (char-equal (code-char cc) #\Return) 39 | :seek-newline 40 | :error))) 41 | 42 | (defstate request-fsm :seek-newline (fsm cc) 43 | (if (char-equal (code-char cc) #\Newline) 44 | (prog1 :done 45 | (setf (http-method fsm) (get-output-stream-string (http-method fsm)) 46 | (resource fsm) (get-output-stream-string (resource fsm)) 47 | (version fsm) (get-output-stream-string (version fsm)))) 48 | :error)) 49 | 50 | ;;; Header block parser 51 | (deffsm header-fsm () 52 | ((headers :initform (list) :accessor headers) 53 | (key-buffer :accessor key-buffer) 54 | (value-buffer :accessor value-buffer)) 55 | (:default-initargs . (:state :key-or-done))) 56 | 57 | (defmethod initialize-instance :after ((fsm header-fsm) &key) 58 | "Reset the key- and value- buffers to fresh string output streams" 59 | (setf (key-buffer fsm) (make-string-output-stream) 60 | (value-buffer fsm) (make-string-output-stream))) 61 | 62 | (defstate header-fsm :read-key (fsm cc) 63 | (cond ((not (or (char-equal (code-char cc) #\:) 64 | (whitespace-p cc))) 65 | (not (write-char (code-char cc) (key-buffer fsm)))) 66 | 67 | ((char-equal (code-char cc) #\:) 68 | :read-space) 69 | 70 | (:otherwise 71 | :error))) 72 | 73 | (defstate header-fsm :read-space (fsm cc) 74 | (if (char-equal (code-char cc) #\Space) 75 | :read-value 76 | :error)) 77 | 78 | (defstate header-fsm :read-value (fsm cc) 79 | (cond ((not (member (code-char cc) '(#\Newline #\Return))) 80 | (not (write-char (code-char cc) (value-buffer fsm)))) 81 | 82 | ((char-equal (code-char cc) #\Return) 83 | (push (cons (get-output-stream-string (key-buffer fsm)) 84 | (get-output-stream-string (value-buffer fsm))) 85 | (headers fsm)) 86 | (initialize-instance fsm) 87 | :read-newline) 88 | 89 | (:otherwise 90 | :error))) 91 | 92 | (defstate header-fsm :read-newline (fsm cc) 93 | (if (char-equal (code-char cc) #\Newline) 94 | :key-or-done 95 | :error)) 96 | 97 | (defstate header-fsm :key-or-done (fsm cc) 98 | (if (char-equal (code-char cc) #\Return) 99 | :expect-finish 100 | (values :read-key t))) 101 | 102 | (defstate header-fsm :expect-finish (fsm cc) 103 | (if (char-equal (code-char cc) #\Newline) 104 | :done 105 | :error)) 106 | 107 | ;;; Body dumper 108 | (deffsm body-fsm () 109 | ((body :initform (vector) :accessor body) 110 | (remaining :initform 0 :accessor remaining) 111 | 112 | (buffer :initform nil :accessor buffer 113 | :documentation "Stores any left-overs from the 114 | content-length read to be re-sent as data"))) 115 | 116 | (defstate body-fsm :initial (fsm event) 117 | (let ((next (cond ((>= (length event) (remaining fsm)) 118 | (setf (body fsm) (concatenate '(vector (unsigned-byte 8)) 119 | (body fsm) 120 | (subseq event 0 (remaining fsm))) 121 | (buffer fsm) (subseq event (remaining fsm) (length event)) 122 | (buffer fsm) (when (length (buffer fsm)) (buffer fsm)) 123 | (remaining fsm) 0) 124 | :done) 125 | (:otherwise 126 | (setf (body fsm) (concatenate '(vector (unsigned-byte 8)) 127 | (body fsm) 128 | event)) 129 | nil)))) 130 | (values next (buffer fsm)))) 131 | 132 | (defstate body-fsm :done (fsm event) 133 | "Do nothing, we don't care" 134 | (declare (ignore fsm event))) 135 | 136 | ;;; Overall request parser 137 | (deffsm request-parser () 138 | ((peer :initarg :peer :accessor peer) 139 | 140 | (request-fsm :accessor request-fsm :initform (make-instance 'request-fsm)) 141 | (headers-fsm :accessor headers-fsm :initform (make-instance 'header-fsm)) 142 | (body-fsm :accessor body-fsm :initform (make-instance 'body-fsm)) 143 | 144 | (buffer :initform nil :accessor buffer)) 145 | (:default-initargs . (:state :read-request))) 146 | 147 | (defstate request-parser :read-request (parser data) 148 | (flet ((finish (at) 149 | (if (not (equalp at :error)) 150 | (progn 151 | (unless (>= at (length data)) 152 | (setf (buffer parser) (subseq data at (length data)))) 153 | 154 | (values 155 | (if (eql (state (request-fsm parser)) :done) :read-headers nil) 156 | (buffer parser))) 157 | :error))) 158 | 159 | (finish 160 | (dotimes (i (length data) i) 161 | (funcall (request-fsm parser) (aref data i)) 162 | (when (eql (state (request-fsm parser)) :error) 163 | (emit (peer parser) "error" "Request Line Parser Error") 164 | (return :error)) 165 | (when (eql (state (request-fsm parser)) :done) 166 | (return (1+ i))))))) 167 | 168 | (defstate request-parser :read-headers (parser data) 169 | (let ((data (or (buffer parser) data))) 170 | (setf (buffer parser) nil) 171 | 172 | (flet ((finish (at) 173 | (if (not (equalp at :error)) 174 | (progn 175 | (unless (>= at (length data)) 176 | (setf (buffer parser) 177 | (concatenate '(vector (unsigned-byte 8)) 178 | (if (buffer parser) (buffer parser) #()) 179 | (subseq data at (length data))))) 180 | 181 | (values 182 | (if (eql (state (headers-fsm parser)) :done) 183 | (prog1 :read-body 184 | :TODO-parse-headers) 185 | nil) 186 | (buffer parser))) 187 | :error))) 188 | 189 | (finish 190 | (dotimes (i (length data) i) 191 | (funcall (headers-fsm parser) (aref data i)) 192 | (when (eql (state (headers-fsm parser)) :error) 193 | (emit (peer parser) "error" "Header Parser Error") 194 | (return :error)) 195 | (when (eql (state (headers-fsm parser)) :done) 196 | (let* ((con-len (cdr (assoc "content-length" (headers (headers-fsm parser)) :test #'string-equal))) 197 | (con-len (parse-integer (or con-len "") :junk-allowed t)) 198 | (con-len (or con-len 0))) 199 | (if (zerop con-len) 200 | (progn 201 | (setf (state (body-fsm parser)) :done) 202 | (emit (peer parser) "request" parser)) 203 | (setf (remaining (body-fsm parser)) con-len))) 204 | (return (1+ i)))))))) 205 | 206 | (defstate request-parser :read-body (parser data) 207 | (let ((data (or (buffer parser) data))) 208 | (setf (buffer parser) nil) 209 | 210 | (funcall (body-fsm parser) data) 211 | 212 | (values (cond ((eql (state (body-fsm parser)) :error) 213 | (emit (peer parser) "error" "Body Reader Error") 214 | :error) 215 | ((eql (state (body-fsm parser)) :done) 216 | (emit (peer parser) "request" parser) 217 | 218 | ;; Send any leftover data as a fresh data event 219 | (when (buffer (body-fsm parser)) 220 | (emit (peer parser) "data" (buffer (body-fsm parser)))) 221 | 222 | :done)) 223 | (buffer parser)))) 224 | -------------------------------------------------------------------------------- /src/pool.lisp: -------------------------------------------------------------------------------- 1 | (in-package :hinge) 2 | 3 | ;; Helpers 4 | (defun make-safe-hash-table (&rest args &key &allow-other-keys) 5 | "Wrapper to return a hash table that is safe 6 | to use concurrently. `args' are passed on as to `make-hash-table'" 7 | ;; TODO: Feature checks for other lisps 8 | (apply #'make-hash-table 9 | (append 10 | #+sbcl (list :synchronized t) 11 | args))) 12 | 13 | ;; Classes 14 | ;;; Job Class 15 | (defclass job () 16 | ((id :initarg :id 17 | :reader id 18 | :documentation "String identifier of the background job. Should match the key in the work table.") 19 | (stamps :initform (list (cons :new (get-internal-real-time))) 20 | :accessor stamps 21 | :documentation "A list of events and time-stamps in the format of (:event . time) in 22 | reverse-chronological order. Possible events are: `:new' `:active' `:done' `:error'") 23 | 24 | (thunk :initarg :thunk 25 | :accessor thunk 26 | :initform (lambda () :badjob) 27 | :documentation "Invoked when the job is scheduled to execute.") 28 | 29 | (result :accessor result 30 | :documentation "The result of evaluating `thunk'.") 31 | 32 | (finish :initarg :finish 33 | :reader finish 34 | :initform (lambda (result) (declare (ignore result))) 35 | :documentation "Invoked on successful run of `thunk' with the return value in the original thread.") 36 | (fail :initarg :fail 37 | :reader fail 38 | :initform (lambda (condition) (declare (ignore condition))) 39 | :documentation "Invoked on a failed run of `thunk' with the condition signaled in the original thread."))) 40 | 41 | 42 | ;;; Pool Class 43 | (defclass pool (emitter) 44 | ((context :initform (zmq:init 0) 45 | :reader context) 46 | 47 | (work-address :initform (format nil "inproc://threadpool-work-~A" (uuid:make-v4-uuid)) 48 | :reader work-address) 49 | (work-sock :accessor work-sock) 50 | 51 | (result-address :initform (format nil "inproc://threadpool-result-~A" (uuid:make-v4-uuid)) 52 | :reader result-address) 53 | (result-sock :accessor result-sock) 54 | 55 | (size :initform 2 56 | :initarg :size 57 | :reader size 58 | :documentation "The number of pool workers.") 59 | (workers :initform (list) 60 | :accessor workers 61 | :documentation "The collection of worker threads.") 62 | 63 | (work :initform (make-safe-hash-table :test 'equalp) 64 | :accessor work 65 | :documentation "A mapping of string job ids to `job' objects 66 | scheduled or running in the thread pool."))) 67 | 68 | ;;;; Generics 69 | (defgeneric make-worker (pool &optional id) 70 | (:documentation "Return a running thread ready to do work for the given pool.")) 71 | 72 | (defgeneric submit (pool job) 73 | (:documentation "Submit a job for execution to the pool")) 74 | 75 | ;;;; Lifecycle methods 76 | (defmethod bind ((pool pool) sub-mask &optional host) 77 | "Create and bind the sockets for work distribution and collection." 78 | (declare (ignore host)) 79 | (log-for (debug) "~A Building work and result sockets." pool) 80 | (setf (work-sock pool) (zmq:socket (context pool) :push) 81 | (result-sock pool) (make-instance 'zmq-socket :owner (owner pool) 82 | :context (context pool) :type :sub)) 83 | 84 | (zmq:bind (work-sock pool) (work-address pool)) 85 | (bind (result-sock pool) (result-address pool)) 86 | 87 | ;; TODO: There should probably be an API for this, since it's useless without it.. 88 | (log-for (debug) "Subscribing to results: ~S." sub-mask) 89 | (zmq:setsockopt (sock (result-sock pool)) :subscribe sub-mask) 90 | 91 | (add-listener (result-sock pool) "data" 92 | (lambda (data) 93 | (let* ((job-id (babel:octets-to-string data)) 94 | (job (prog1 (gethash job-id (work pool)) 95 | (remhash job-id (work pool))))) 96 | 97 | (when (zerop (hash-table-count (work pool))) 98 | (log-for (debug) "Pausing the result gathering socket of ~S" pool) 99 | (pause (result-sock pool))) 100 | 101 | (if (not job) 102 | (log-for (debug) "WARNING: Receiver could not find job: ~S" job-id) 103 | (progn 104 | (case (status job) 105 | (:done (funcall (finish job) (result job))) 106 | (:error (funcall (fail job) (result job))) 107 | (otherwise 108 | (log-for (debug) "WARNING: Job ~S returned in unknown status: ~S" job-id (status job))))))))) 109 | (pause (result-sock pool))) 110 | 111 | (defmethod initialize-instance :after ((pool pool) &key) 112 | (bind pool "") 113 | 114 | (log-for (debug) "Initializing pool: ~A" pool) 115 | (dotimes (worker-id (size pool)) 116 | (let ((worker (make-worker pool worker-id))) 117 | (log-for (debug) "Adding worker ~a: ~S" worker-id worker) 118 | (push worker (workers pool))))) 119 | 120 | (defmethod close ((pool pool) &key &allow-other-keys) 121 | "Terminate all of the workers in the pool and 122 | fire any leftover callbacks as failure." 123 | (dolist (worker (workers pool)) 124 | (when (and (bt:threadp worker) (bt:thread-alive-p worker)) 125 | (log-for (debug) "Destroying worker: ~S" (bt:thread-name worker)) 126 | (bt:destroy-thread worker))) 127 | (setf (workers pool) (list)) 128 | 129 | (log-for (debug) "Destroying worker socket.") 130 | (when-let (sock (work-sock pool)) 131 | (setf (work-sock pool) nil) 132 | (zmq:close sock)) 133 | (log-for (debug) "Destroying result socket.") 134 | (when-let (sock (result-sock pool)) 135 | (setf (result-sock pool) nil) 136 | (close sock)) 137 | (log-for (debug) "Destroying the job passing context.") 138 | (when-let (ctx (context pool)) 139 | (setf (slot-value pool 'context) nil) 140 | (zmq:term ctx)) 141 | 142 | (log-for (debug) "TODO: Fail remaining callbacks in ~A" (work pool))) 143 | 144 | ;;;; Methods 145 | (defmethod make-worker ((pool pool) &optional (id :somekind)) 146 | (flet ((work-fn () 147 | (setf *random-state* (make-random-state t)) 148 | (zmq:with-sockets ((work (context pool) :pull) 149 | (result (context pool) :pub)) 150 | (zmq:connect work (work-address pool)) 151 | (zmq:connect result (result-address pool)) 152 | 153 | (log-for (debug) "Worker: ~S waiting to work." (bt:thread-name (bt:current-thread))) 154 | (do* ((job-id (zmq:recv! work :string) (zmq:recv! work :string)) 155 | (job (gethash job-id (work pool)) (gethash job-id (work pool)))) 156 | (nil) 157 | (if (not job) 158 | (log-for (debug) "WARNING: Worker ~S could not find job-id ~S" 159 | (bt:thread-name (bt:current-thread)) job-id) 160 | (progn 161 | (perform job) 162 | (zmq:send! result job-id))))))) 163 | 164 | (bt:make-thread #'work-fn :name (format nil "pool-worker[~S]" id)))) 165 | 166 | (defmethod submit :before ((pool pool) (job job)) 167 | "Resume the response gathering socket." 168 | (resume (result-sock pool))) 169 | 170 | (defmethod submit ((pool pool) (job job)) 171 | "Submit a job to the pool" 172 | (setf (gethash (id job) (work pool)) job) 173 | (log-for (debug) "Sending job: ~S to pool ~S" (id job) pool) 174 | (zmq:send! (work-sock pool) (id job))) 175 | 176 | (defgeneric perform (job) 177 | (:documentation "Perform the job and either store success or failure. 178 | Returns three values: the job, the terminal status, and the result") 179 | (:method ((job job)) 180 | (log-for (debug) "Worker: ~S got job-id ~S => ~S" 181 | (bt:thread-name (bt:current-thread)) (id job) job) 182 | (stamp job :active) 183 | (setf (result job) (handler-case 184 | (prog1 (funcall (thunk job)) 185 | (stamp job :done)) 186 | 187 | (t (c) 188 | (prog1 c 189 | (stamp job :error))))) 190 | (log-for (debug) "Worker: ~S finished job-id ~S => ~S" (bt:thread-name (bt:current-thread)) (id job) (status job)) 191 | (values job (status job) (result job)))) 192 | 193 | (defgeneric status (job) 194 | (:documentation "The current status of the job.") 195 | (:method ((job job)) 196 | (caar (stamps job)))) 197 | 198 | (defgeneric stamp (job status) 199 | (:documentation "Add a status stamp to a job with the current internal time.") 200 | (:method ((job job) status) 201 | (push (cons status (get-internal-real-time)) (stamps job)))) 202 | 203 | ;;; API 204 | (defmacro async ((&key hinge pool success failure) &body forms) 205 | (with-gensyms (g!job-id g!job e!pool e!hinge e!success e!failure) 206 | `(let* ((,e!hinge ,hinge) 207 | (,e!pool (or ,pool 208 | (bg-pool (if ,e!hinge ,e!hinge (get-default-hinge))))) 209 | (,e!success ,success) 210 | (,e!failure ,failure) 211 | 212 | (,g!job-id (princ-to-string (uuid:make-v4-uuid))) 213 | (,g!job (apply #'make-instance 'job :id ,g!job-id 214 | :thunk (lambda () ,@forms) 215 | (flatten 216 | (remove nil (list 217 | (when ,e!success (list :finish ,e!success)) 218 | (when ,e!failure (list :fail ,e!failure)))))))) 219 | (submit ,e!pool ,g!job)))) 220 | -------------------------------------------------------------------------------- /src/socket.lisp: -------------------------------------------------------------------------------- 1 | (in-package :hinge) 2 | 3 | ;; Class 4 | (defclass socket (emitter) 5 | ((sock :initform (sockets:make-socket :ipv6 nil :reuse-address t) 6 | :initarg :sock 7 | :accessor sock) 8 | (watchers :initform (vector nil nil nil) 9 | :accessor watchers 10 | :documentation "#(read write timeout) watchers.") 11 | (writes :initform (list) 12 | :accessor writes 13 | :documentation "List of 3-vectors in the format 14 | #(buffer offset callback) of pending write operations. When possible 15 | write operations are performed from the head of the list. Each write 16 | a portion of the buffer will be written and a new offset into the 17 | buffer is stored. If the entire buffer is sent, callback is invoked, 18 | if provided. When the writes list becomes empty a \"drain\" event 19 | is emitted.") 20 | 21 | (fd :initform nil 22 | :initarg :fd 23 | :accessor fd 24 | :documentation "File descriptor of the socket."))) 25 | 26 | ;; Generics 27 | (defgeneric init-watchers (socket) 28 | (:documentation "Initialize the watchers of the `socket' 29 | and add them to the reactor. If any previous watchers exist 30 | they are first disposed.")) 31 | 32 | (defgeneric on-read (socket) 33 | (:documentation "Fired to handle a ready for read operation on the socket.")) 34 | (defgeneric on-write (socket) 35 | (:documentation "Fired to handle a ready for write operation on this socket.")) 36 | 37 | (defgeneric pause (socket) 38 | (:documentation "Pause the incoming data events.")) 39 | (defgeneric resume (socket) 40 | (:documentation "Resume the incoming data events.")) 41 | 42 | (defgeneric connect (socket port &optional host) 43 | (:documentation "Connect `socket' to `port' on `host'. 44 | If host is omitted localhost is assumed.")) 45 | (defgeneric send (socket data &optional callback) 46 | (:documentation "Schedule a write of `data' on `socket'. 47 | `callback' is invoked when the data is written as in: 48 | (funcall callback socket offset data-written). 49 | \"drain\" will be emitted on the socket when the write operation 50 | completes.")) 51 | 52 | ;; Interface methods 53 | (defmethod timeout-activity ((socket socket) &optional timeout start) 54 | "Signal activity on the `socket' to reschedule the timeout into the 55 | future, if one exists. If `timeout' is given, it is set to be the new 56 | timeout interval to use. Unless the timer is already active, or `start' 57 | is non-nil, the timer is not restarted." 58 | (when (svref (watchers socket) 2) 59 | (when timeout 60 | (setf (ev:watcher-slot (svref (watchers socket) 2) :repeat) (coerce timeout 'double-float))) 61 | 62 | (when (or start (ev:watcher-active-p (svref (watchers socket) 2))) 63 | (ev::ev_timer_again (ev::event-loop (owner socket)) (ev::ev-pointer (svref (watchers socket) 2)))))) 64 | 65 | (defmethod set-timeout ((socket socket) (timeout number) callback) 66 | "Set an inactivity timeout on the socket `socket' of `timeout' seconds. 67 | Callback must be specified, but can be `nil'. The `callback' parameter 68 | does not affect the emission of the \"timeout\" event." 69 | (when (and (not (svref (watchers socket) 2)) 70 | (svref (watchers socket) 0)) 71 | 72 | (flet ((timeout-cb (l watcher e) 73 | (declare (ignore e)) 74 | (ev:stop-watcher l watcher :keep-callback t) 75 | (emit socket "timeout" socket))) 76 | 77 | (let ((watcher (make-instance 'ev:ev-timer))) 78 | (ev:set-timer (owner socket) watcher #'timeout-cb (coerce timeout 'double-float)) 79 | (setf (svref (watchers socket) 2) watcher)))) 80 | 81 | (if (zerop timeout) 82 | (ev:stop-watcher (owner socket) (svref (watchers socket) 2) :keep-callback t) 83 | (progn 84 | (when callback 85 | (listen-once socket "timeout" callback)) 86 | (timeout-activity socket timeout t))) 87 | 88 | socket) 89 | 90 | (defmethod connect ((socket socket) (port number) &optional (host #(127 0 0 1))) 91 | (async (:hinge (owner socket) 92 | :success (curry #'emit socket "connect") 93 | :failure (curry #'emit socket "error")) 94 | (sockets:connect (sock socket) (sockets:make-address host) :port port) 95 | socket) 96 | socket) 97 | 98 | 99 | (defmethod send ((socket socket) (data sequence) &optional (callback (lambda (sock) (declare (ignore sock))))) 100 | (let ((watcher (svref (watchers socket) 1))) 101 | (when watcher 102 | (appendf (writes socket) 103 | (list (vector data 0 callback))) 104 | (unless (ev:watcher-active-p watcher) 105 | (ev:start-watcher (owner socket) watcher))))) 106 | 107 | (defmethod close ((socket socket) &key &allow-other-keys) 108 | "Close the actual socket before the close method cleans up the watchers 109 | and emits the event." 110 | (close (sock socket))) 111 | 112 | (defmethod close :after ((socket socket) &key &allow-other-keys) 113 | "Close the socket, emit \"close\" event." 114 | (when (svref (watchers socket) 0) 115 | (ev:stop-watcher (owner socket) (svref (watchers socket) 0))) 116 | (when (svref (watchers socket) 1) 117 | (ev:stop-watcher (owner socket) (svref (watchers socket) 1))) 118 | (when (svref (watchers socket) 2) 119 | (ev:stop-watcher (owner socket) (svref (watchers socket) 2))) 120 | (log-for (debug) "=> Emitting close on ~S" socket) 121 | (setf (watchers socket) (vector nil nil nil)) 122 | (emit socket "close" socket)) 123 | 124 | ;; Event methods 125 | (defmethod on-read :after ((socket socket)) 126 | "Signal timeout activity" 127 | (timeout-activity socket)) 128 | 129 | (defmethod on-write :after ((socket socket)) 130 | "Signal timeout activity" 131 | (timeout-activity socket)) 132 | 133 | (defmethod send :after ((socket socket) _ &optional __) 134 | "Signal timeout activity" 135 | (declare (ignore _ __)) 136 | (timeout-activity socket)) 137 | 138 | (defmethod on-read ((socket socket)) 139 | (if (sockets:socket-open-p (sock socket)) 140 | (if (sockets:socket-connected-p (sock socket)) 141 | (handler-case 142 | (multiple-value-bind (data size) 143 | (sockets:receive-from (sock socket) :size (* 8 1024) :dont-wait t) 144 | (progn 145 | (log-for (debug) "Got ~S ~S in read from ~S" size (subseq data 0 size) socket) 146 | (unless (zerop size) 147 | (log-for (debug) " +> ~S" (babel:octets-to-string (subseq data 0 size)))) 148 | (if (zerop size) 149 | (close socket) 150 | (prog1 (emit socket "data" (subseq data 0 size)) 151 | (log-for (debug) "Emitting data on ~S" socket))))) 152 | (iolib.syscalls:ewouldblock () nil)) 153 | (progn 154 | (log-for (debug) "Socket ~S not connected" socket) 155 | (close socket))) 156 | (close socket))) 157 | 158 | (defmethod on-write ((socket socket)) 159 | (if (sockets:socket-open-p (sock socket)) 160 | (let ((data (first (writes socket)))) 161 | (if data 162 | (let* ((buffer (svref data 0)) 163 | (start (svref data 1)) 164 | (callback (svref data 2)) 165 | (written (sockets:send-to (sock socket) buffer :start start :dont-wait t))) 166 | (when (= (incf (svref data 1) written) (length buffer)) 167 | (pop (writes socket)) 168 | (defer ((owner socket)) 169 | (funcall callback socket)))) 170 | 171 | (progn 172 | (log-for (debug) "Socket drained: ~A" socket) 173 | (ev:stop-watcher (owner socket) (svref (watchers socket) 1) :keep-callback t) 174 | (emit socket "drain" socket)))) 175 | (close socket))) 176 | 177 | (defmethod pause ((socket socket)) 178 | (prog1 socket 179 | (when (ev:watcher-active-p (svref (watchers socket) 0)) 180 | (ev:stop-watcher (owner socket) (svref (watchers socket) 0) :keep-callback t)) 181 | (when (ev:watcher-active-p (svref (watchers socket) 1)) 182 | (ev:stop-watcher (owner socket) (svref (watchers socket) 1) :keep-callback t)))) 183 | 184 | (defmethod resume ((socket socket)) 185 | (prog1 socket 186 | (ev:start-watcher (owner socket) (svref (watchers socket) 0)) 187 | (ev:start-watcher (owner socket) (svref (watchers socket) 1)))) 188 | 189 | ;; Init Methods 190 | (defmethod initialize-instance :after ((inst socket) &key) 191 | (setf (fd inst) (or (fd inst) (socket-fd (sock inst)))) 192 | (init-watchers inst)) 193 | 194 | (defmethod init-watchers :before ((socket socket)) 195 | (when (svref (watchers socket) 0) ;; Reader watcher 196 | (ev:stop-watcher (owner socket) (svref (watchers socket) 0)) 197 | (setf (svref (watchers socket) 0) nil)) 198 | 199 | (when (svref (watchers socket) 1) ;; Writer watcher 200 | (ev:stop-watcher (owner socket) (svref (watchers socket) 1)) 201 | (setf (svref (watchers socket) 1) nil)) 202 | 203 | (when (svref (watchers socket) 2) ;; Timeout watcher 204 | (ev:stop-watcher (owner socket) (svref (watchers socket) 2)) 205 | (setf (svref (watchers socket) 2) nil))) 206 | 207 | (defmethod init-watchers ((socket socket)) 208 | (let ((read-watcher (make-instance 'ev:ev-io-watcher))) 209 | (ev:set-io-watcher (owner socket) read-watcher (fd socket) ev:EV_READ 210 | #'(lambda (ev watcher events) 211 | (declare (ignore ev watcher events)) 212 | (on-read socket))) 213 | (ev:start-watcher (owner socket) read-watcher) 214 | (setf (svref (watchers socket) 0) read-watcher)) 215 | 216 | (let ((write-watcher (make-instance 'ev:ev-io-watcher))) 217 | (ev:set-io-watcher (owner socket) write-watcher (fd socket) ev:EV_WRITE 218 | #'(lambda (ev watcher events) 219 | (declare (ignore ev watcher events)) 220 | (on-write socket))) 221 | (unless (null (writes socket)) 222 | (ev:start-watcher (owner socket) write-watcher)) 223 | (setf (svref (watchers socket) 1) write-watcher))) 224 | --------------------------------------------------------------------------------