├── .gitignore ├── LICENSE ├── README.md ├── cl-async-repl.asd ├── cl-async-ssl.asd ├── cl-async-test.asd ├── cl-async.asd ├── examples ├── dns-lookup.lisp ├── echo-server.lisp ├── simple-proxy.lisp ├── spawn.lisp └── tcp-client.lisp ├── src ├── async-stream.lisp ├── base.lisp ├── dns.lisp ├── event-loop.lisp ├── event.lisp ├── filesystem.lisp ├── fsevent.lisp ├── idle.lisp ├── notify.lisp ├── package.lisp ├── pipe.lisp ├── poll.lisp ├── process.lisp ├── repl.lisp ├── signal.lisp ├── socket.lisp ├── ssl │ ├── package.lisp │ ├── tcp.lisp │ └── util.lisp ├── streamish.lisp ├── tcp.lisp └── util │ ├── error.lisp │ ├── foreign.lisp │ ├── helpers.lisp │ └── package.lisp └── test ├── async-stream.lisp ├── base.lisp ├── benchmarks.lisp ├── dns.lisp ├── event.lisp ├── filesystem.lisp ├── fsevent.lisp ├── http.lisp ├── idle.lisp ├── pipe.lisp ├── poll.lisp ├── process.lisp ├── run.lisp ├── signal.lisp ├── ssl └── certkey ├── tcp-ssl.lisp ├── tcp.lisp ├── threading.lisp └── util.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *.lx64fsl 3 | *.lx32fsl 4 | *.lafsl 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012 Lyon Bros LLC 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all 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, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | cl-async - Asynchronous operations for Common Lisp 2 | ================================================== 3 | Cl-async is a library for general purpose, non-blocking programming in Common 4 | Lisp. Cl-async uses [libuv](http://docs.libuv.org/en/v1.x/) as the backend, 5 | which is a fast, stable, portable library for asynchronous IO (used as the 6 | backend library in Node.js). 7 | 8 | The main goal is to provide an experience that makes general asynchronous 9 | programming in lisp natural, and to also provide a number of 10 | [drivers](http://orthecreedence.github.io/cl-async/drivers) on top of cl-async. 11 | 12 | __NOTE:__ cl-async uses the v1.x branch of libuv, so make sure to grab that 13 | version of it (not the v0.10.x branch). 14 | 15 | ### [Documentation](http://orthecreedence.github.io/cl-async/documentation) 16 | Please see the [cl-async website](http://orthecreedence.github.io/cl-async) for 17 | full documentation, examples, etc. 18 | 19 | Quick links: 20 | 21 | - [Documentation](http://orthecreedence.github.io/cl-async/documentation) 22 | - [Base system](http://orthecreedence.github.io/cl-async/base) 23 | - [Timers](http://orthecreedence.github.io/cl-async/timers) 24 | - [Signal handling](http://orthecreedence.github.io/cl-async/signal-handling) 25 | - [DNS](http://orthecreedence.github.io/cl-async/dns) 26 | - [TCP](http://orthecreedence.github.io/cl-async/tcp) 27 | - [TCP stream](http://orthecreedence.github.io/cl-async/tcp-stream) 28 | - [TCP SSL](http://orthecreedence.github.io/cl-async/tcp-ssl) 29 | - [Pollers](http://orthecreedence.github.io/cl-async/pollers) 30 | - [Idlers](http://orthecreedence.github.io/cl-async/idlers) 31 | - [Notifiers](http://orthecreedence.github.io/cl-async/notifiers) 32 | - [Futures](http://orthecreedence.github.io/cl-async/future) 33 | - [Threading](http://orthecreedence.github.io/cl-async/threading) 34 | - [Stats](http://orthecreedence.github.io/cl-async/stats) 35 | - [Event callbacks and error handling](http://orthecreedence.github.io/cl-async/event-handling) 36 | - [Examples](http://orthecreedence.github.io/cl-async/examples) 37 | - [Benchmarks](http://orthecreedence.github.io/cl-async/benchmarks) 38 | - [Implementation notes](http://orthecreedence.github.io/cl-async/implementation-notes) 39 | - [Drivers](http://orthecreedence.github.io/cl-async/drivers) 40 | 41 | ### Install 42 | ```lisp 43 | (ql:quickload :cl-async) 44 | ``` 45 | 46 | Please be aware that until cl-async v0.6.x is in quicklisp, you might want to 47 | git clone the master branch into `quicklisp/local-projects/`. 48 | 49 | ### Tests 50 | There is a fairly complete suite of tests in the `cl-async-test` package: 51 | 52 | ```common-lisp 53 | (ql:quickload :cl-async-test) 54 | (cl-async-test:run-tests) 55 | (cl-async-test:run-tests :ssl t) 56 | (cl-async-test:run-tests :threading t) 57 | ``` 58 | 59 | ### License 60 | As always, my code is MIT licensed. Do whatever the hell you want with it. Enjoy! 61 | 62 | -------------------------------------------------------------------------------- /cl-async-repl.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem cl-async-repl 2 | :author "Andrew Danger Lyon " 3 | :license "MIT" 4 | :version "0.1" 5 | :description "REPL integration for CL-ASYNC." 6 | :depends-on (#:cl-async #:bordeaux-threads) 7 | :components 8 | ((:file "src/repl"))) 9 | -------------------------------------------------------------------------------- /cl-async-ssl.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem cl-async-ssl 2 | :author "Andrew Danger Lyon " 3 | :license "MIT" 4 | :version "0.6.0" 5 | :description "SSL Wrapper around cl-async socket implementation." 6 | :depends-on (#:cffi 7 | #:cl-async 8 | #:vom) 9 | :components 10 | ((:file "src/ssl/package") 11 | (:file "src/ssl/util" :depends-on ("src/ssl/package")) 12 | (:file "src/ssl/tcp" :depends-on ("src/ssl/package" "src/ssl/util")))) 13 | -------------------------------------------------------------------------------- /cl-async-test.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem cl-async-test 2 | :author "Andrew Danger Lyon " 3 | :license "MIT" 4 | :version "0.2" 5 | :description "TESTS FOR Asynchronous operations for Common Lisp." 6 | :depends-on (#:cffi 7 | #:cl-async 8 | #:cl-async-ssl 9 | #:fiveam 10 | #:bordeaux-threads 11 | #:usocket 12 | #:flexi-streams 13 | #:ironclad) 14 | :components 15 | ((:module test 16 | :serial t 17 | :components ((:file "util") 18 | (:file "base") 19 | (:file "event") 20 | (:file "dns") 21 | (:file "tcp") 22 | (:file "pipe") 23 | (:file "async-stream") 24 | (:file "threading") 25 | (:file "tcp-ssl") 26 | (:file "signal") 27 | (:file "idle") 28 | (:file "poll") 29 | (:file "benchmarks") 30 | (:file "run") 31 | (:file "filesystem") 32 | (:file "process") 33 | (:file "fsevent"))))) 34 | -------------------------------------------------------------------------------- /cl-async.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem cl-async-base 2 | :author "Andrew Danger Lyon " 3 | :license "MIT" 4 | :version "0.6.1" 5 | :description "Base system for cl-async." 6 | :depends-on (#:cffi #:cl-libuv #:bordeaux-threads) 7 | :serial t 8 | :components 9 | ((:file "src/base"))) 10 | 11 | (asdf:defsystem cl-async-util 12 | :author "Andrew Danger Lyon " 13 | :license "MIT" 14 | :version "0.6.1" 15 | :description "Internal utilities for cl-async." 16 | :depends-on (#:cffi 17 | #:fast-io 18 | #:vom 19 | #:cl-libuv 20 | #:cl-ppcre 21 | #:cl-async-base) 22 | :serial t 23 | :components 24 | ((:file "src/util/package") 25 | (:file "src/util/helpers") 26 | (:file "src/util/foreign") 27 | (:file "src/util/error"))) 28 | 29 | (asdf:defsystem cl-async 30 | :author "Andrew Danger Lyon " 31 | :license "MIT" 32 | :version "0.6.1" 33 | :description "Asynchronous operations for Common Lisp." 34 | :depends-on (#:cffi 35 | #:trivial-features 36 | #:static-vectors 37 | #:cl-libuv 38 | #:cl-async-base 39 | #:cl-async-util 40 | #:babel 41 | #:cl-ppcre 42 | #:trivial-gray-streams 43 | #:uiop) 44 | :components 45 | ((:module src 46 | :components 47 | ((:file "package") 48 | (:file "event-loop" :depends-on ("package")) 49 | (:file "event" :depends-on ("package")) 50 | (:file "dns" :depends-on ("package" "streamish")) 51 | (:file "streamish" :depends-on ("event-loop" "event")) 52 | (:file "async-stream" :depends-on ("streamish")) 53 | (:file "socket" :depends-on ("streamish" "async-stream")) 54 | (:file "tcp" :depends-on ("dns" "socket")) 55 | (:file "filesystem" :depends-on ("streamish")) 56 | (:file "pipe" :depends-on ("socket" "filesystem")) 57 | (:file "signal" :depends-on ("streamish")) 58 | (:file "notify" :depends-on ("streamish")) 59 | (:file "poll" :depends-on ("streamish")) 60 | (:file "idle" :depends-on ("package")) 61 | (:file "process" :depends-on ("pipe")) 62 | (:file "fsevent" :depends-on ("streamish")))))) 63 | 64 | -------------------------------------------------------------------------------- /examples/dns-lookup.lisp: -------------------------------------------------------------------------------- 1 | ;;; Some examples of async DNS lookups. 2 | 3 | (ql:quickload :cl-async) 4 | 5 | (defun do-lookups () 6 | (dolist (lookup `(("google.com" ,as:+af-unspec+) 7 | ("musio.com" ,as:+af-inet+) 8 | ("www.google.com" ,as:+af-inet6+))) 9 | (destructuring-bind (host family) lookup 10 | (as:dns-lookup host 11 | (lambda (addr fam) 12 | (declare (ignore fam)) 13 | (format t "~a resolved to ~s (~s)~%" host addr family)) 14 | :event-cb 15 | (lambda (ev) 16 | (format t "ev: ~a(~a): ~a~%" host family ev)) 17 | :family family)))) 18 | 19 | (as:start-event-loop #'do-lookups) 20 | -------------------------------------------------------------------------------- /examples/echo-server.lisp: -------------------------------------------------------------------------------- 1 | ;;; This shows an example echo server that writes everything it receives on port 2 | ;;; 5000 back to the connected client. A ctrl-c exits the server. 3 | 4 | (ql:quickload :cl-async) 5 | 6 | (defun echo-server () 7 | (as:tcp-server nil 5000 8 | (lambda (sock data) 9 | ;; echo data back to client 10 | (as:write-socket-data sock data)) 11 | (lambda (ev) 12 | (format t "ev: ~a~%" ev))) 13 | (as:signal-handler as:+sigint+ 14 | (lambda (sig) 15 | (declare (ignore sig)) 16 | (as:exit-event-loop)))) 17 | 18 | (as:start-event-loop #'echo-server) 19 | 20 | 21 | -------------------------------------------------------------------------------- /examples/simple-proxy.lisp: -------------------------------------------------------------------------------- 1 | ;;; This file contains a simple proxy. It binds to a local port and connects to 2 | ;;; a remote host/port, proxying all data received locally or remotely. It uses 3 | ;;; the "socket data" accessor to reference the local and remote socket to each 4 | ;;; other, allowing one to be closed if the other gets an EOF. 5 | ;;; 6 | ;;; It has the ability to print out all data sent/received, and print out 7 | ;;; reports on connection statistics. 8 | ;;; 9 | ;;; Usage: 10 | ;;; 11 | ;;; (simple-proxy:start local-bind local-port 12 | ;;; remote-host remote-port 13 | ;;; &key stats debug ascii verbose) 14 | ;;; 15 | ;;; Not only does this offer a good example of a more advanced usage of cl-async 16 | ;;; but is actually really useful for peeking into plaintext TCP protocols. For 17 | ;;; instance, you could use it to debug HTTP requests or learn what a driver is 18 | ;;; sending to a server (which is what I built it for). 19 | 20 | (ql:quickload :cl-async) 21 | 22 | (defpackage :simple-proxy 23 | (:use :cl) 24 | (:export #:start)) 25 | (in-package :simple-proxy) 26 | 27 | (defparameter *debug* nil "If T, will echo all data coming through the proxy") 28 | (defparameter *verbose* nil "If T (and *debug* is T), will spit out every byte that passes through") 29 | (defparameter *ascii* nil "If T, will echo all non-UTF8 data as a string of ASCII bytes instead of a vector") 30 | 31 | (defun to-ascii (data) 32 | "Print data to an ASCII string byte by byte (if enabled)." 33 | (if *ascii* 34 | (progn 35 | (loop for byte-code across data do 36 | (format t "~c" (code-char byte-code))) 37 | (format t "~%")) 38 | data)) 39 | 40 | (defun output-data (location &optional data) 41 | "Outputs the given data using the specified location as the header." 42 | (when *debug* 43 | (if data 44 | (progn 45 | (format t "---~a(~a)---~%" location (length data)) 46 | (when *verbose* 47 | (handler-case (format t "~a~%" (babel:octets-to-string data :encoding :utf-8)) 48 | (error () (format t "~a~%" (to-ascii data)))))) 49 | (format t "---~a---~%" location)))) 50 | 51 | (defun socketp (socket) 52 | "Test if given object is an as:socket." 53 | (subtypep (type-of socket) 'as:socket)) 54 | 55 | (defun pair-sockets (sock1 sock2) 56 | "Pair two sockets to each other." 57 | (when (and (socketp sock1) 58 | (socketp sock2)) 59 | (setf (as:socket-data sock1) sock2 60 | (as:socket-data sock2) sock1))) 61 | 62 | (defun close-paired-socket (socket) 63 | "Given a socket, close the paired socket (if it exists)." 64 | (when (socketp socket) 65 | (let ((paired-socket (as:socket-data socket))) 66 | (when (and (socketp paired-socket) 67 | (not (as:socket-closed-p paired-socket))) 68 | (output-data "close") 69 | (as:close-socket paired-socket) 70 | ;; deref them 71 | (setf (as:socket-data socket) nil 72 | (as:socket-data paired-socket) nil))))) 73 | 74 | (defun proxy-event-handler (ev) 75 | "Handle all proxy events." 76 | (handler-case 77 | (error ev) 78 | ;; if a socket times out, close the paired socket 79 | (as:tcp-timeout () 80 | (close-paired-socket (as:tcp-socket ev))) 81 | ;; if we get a socket eof, close the paired socket, but delay it so that any 82 | ;; data being sent out before closing has a chance to "escape." 83 | (as:tcp-error () 84 | (as:delay (lambda () (close-paired-socket (as:tcp-socket ev))))) 85 | (as:tcp-eof () 86 | (as:delay (lambda () (close-paired-socket (as:tcp-socket ev))))) 87 | ;; just echo the event 88 | (error () 89 | (when *debug* 90 | (format t "ev: ~a (~a)~%" (type-of ev) ev))))) 91 | 92 | (defun proxy-remote-response (sock-remote data) 93 | "Send data received on the remote socket into the local socket." 94 | (output-data "remote" data) 95 | (let ((sock-local (as:socket-data sock-remote))) 96 | (if (as:socket-closed-p sock-local) 97 | (close-paired-socket sock-local) 98 | (as:write-socket-data sock-local data)))) 99 | 100 | (defun proxy-local-data (sock-local data) 101 | "Send data received on the local socket into the remote socket." 102 | (output-data "local" data) 103 | (let ((sock-remote (as:socket-data sock-local))) 104 | (if (as:socket-closed-p sock-remote) 105 | (close-paired-socket sock-remote) 106 | (as:write-socket-data sock-remote data)))) 107 | 108 | (defun start (local-bind local-port remote-host remote-port &key stats debug ascii verbose) 109 | "Start a proxy on a local port and proxy to a remote host. If :stats is T, 110 | connection stats are printed every 2 seconds. If :debug is T, all data 111 | passing through the proxy is echoed to STDOUT." 112 | (let ((server nil) 113 | (quit nil) 114 | (*debug* debug) 115 | (*verbose* verbose) 116 | (*ascii* ascii)) 117 | (as:with-event-loop (:catch-app-errors t) 118 | (format t "Starting proxy.~%") 119 | (setf server (as:tcp-server 120 | local-bind local-port 121 | (lambda (sock-local data) 122 | (proxy-local-data sock-local data)) 123 | :event-cb #'proxy-event-handler 124 | :connect-cb (lambda (sock-local) 125 | (output-data "connection") 126 | ;; on local connect, establish the remote connection 127 | (let ((sock-remote (as:tcp-connect remote-host remote-port 128 | #'proxy-remote-response 129 | :event-cb #'proxy-event-handler))) 130 | ;; pair the local and remote sockets. if 131 | ;; one closes, so does the other. 132 | (pair-sockets sock-local sock-remote))) 133 | :backlog -1)) 134 | 135 | ;; SIGINT will *cleanly* close the proxy (doesn't accept any new 136 | ;; connections, but lets current ones run free until they close). 137 | (as:signal-handler as:+sigint+ 138 | (lambda (sig) 139 | (declare (ignore sig)) 140 | (format t "Closing proxy...~%") 141 | (setf quit t) 142 | (as:close-tcp-server server) 143 | (as:free-signal-handler as:+sigint+))) 144 | 145 | ;; if :stats is T, print connections statistics every few seconds 146 | (when stats 147 | (labels ((print-stats () 148 | (let* ((stats (as:stats)) 149 | (incoming (getf stats :incoming-tcp-connections)) 150 | (outgoing (getf stats :outgoing-tcp-connections))) 151 | (format t "incoming: ~a~%outgoing: ~a~%~%" incoming outgoing)) 152 | (unless quit 153 | (as:delay #'print-stats :time 2)))) 154 | (print-stats))))) 155 | (format t "Closed.~%")) 156 | -------------------------------------------------------------------------------- /examples/spawn.lisp: -------------------------------------------------------------------------------- 1 | ;;; Spawn 100 subprocesses and wait for them all to wake. Implementation of 2 | ;;; sleep sort. 3 | 4 | (ql:quickload :cl-async :silent t) 5 | (ql:quickload :babel :silent t) 6 | 7 | (defun spawn-one (v) 8 | (let ((sh (format NIL "sleep ~f; echo ~:*~f~%" v))) 9 | (as:spawn "bash" `("-c" ,sh) 10 | :output 11 | (list :pipe 12 | :read-cb 13 | (lambda (pipe data) 14 | (format T "~A~&" (babel:octets-to-string data))))))) 15 | 16 | (as:with-event-loop (:catch-app-errors t) 17 | (let ((ar (loop for i below 100 collect (/ (random 100) 10)))) 18 | (mapc #'spawn-one ar))) 19 | -------------------------------------------------------------------------------- /examples/tcp-client.lisp: -------------------------------------------------------------------------------- 1 | ;;; This shows a quick example of using TCP to communicate with a server. In 2 | ;;; this case, we'll use HTTP as an example as it's a fairly straightforward 3 | ;;; protocol 4 | 5 | (ql:quickload :cl-async) 6 | 7 | (defun get-http-response (host &optional (port 80)) 8 | (as:tcp-connect host port 9 | (lambda (sock data) 10 | (unless (as:socket-closed-p sock) 11 | (as:close-socket sock)) 12 | (format t "~a" (babel:octets-to-string data))) 13 | (lambda (ev) 14 | (format t "ev: ~a~%" ev)) 15 | :data (format nil "GET / HTTP/1.1~c~cHost: ~a~c~c~c~c" 16 | #\return #\newline 17 | host 18 | #\return #\newline 19 | #\return #\newline) 20 | :read-timeout 5)) 21 | 22 | (as:start-event-loop (lambda () (get-http-response "www.google.com"))) 23 | -------------------------------------------------------------------------------- /src/async-stream.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async) 2 | 3 | (defclass async-stream (trivial-gray-stream-mixin) 4 | ((streamish :accessor streamish :initarg :streamish :initarg :socket :initform nil) 5 | (buffer :accessor stream-buffer :initform (make-buffer))) 6 | (:documentation "The underlying class for async streams. Wraps a streamish.")) 7 | (defclass async-output-stream (async-stream fundamental-binary-output-stream) () 8 | (:documentation "Async output stream.")) 9 | (defclass async-input-stream (async-stream fundamental-binary-input-stream) () 10 | (:documentation "Async input stream.")) 11 | (defclass async-io-stream (async-input-stream async-output-stream) () 12 | (:documentation "Async stream for both input and output.")) 13 | 14 | ;; ----------------------------------------------------------------------------- 15 | ;; base stream 16 | ;; ----------------------------------------------------------------------------- 17 | (defmethod stream-append-bytes ((stream async-stream) bytes) 18 | "Append some data to a stream's underlying buffer." 19 | (write-to-buffer bytes (stream-buffer stream))) 20 | 21 | (defmethod stream-output-type ((stream async-stream)) 22 | "This is always a binary stream." 23 | 'cl-async-util:octet) 24 | 25 | (defmethod stream-element-type ((stream async-stream)) 26 | "This is always a binary stream." 27 | 'cl-async-util:octet) 28 | 29 | (defmethod open-stream-p ((stream async-stream)) 30 | "Test the underlying streamish to see if this stream is open." 31 | (not (streamish-closed-p (streamish stream)))) 32 | 33 | (defmethod close ((stream async-stream) &key abort) 34 | "Close the stream. If aborting, attempt to clear out remaining data in the 35 | buffers before closing (is this really needed?)" 36 | (when abort 37 | (when (output-stream-p stream) 38 | (clear-output stream)) 39 | (when (input-stream-p stream) 40 | (clear-input stream))) 41 | (close-streamish (streamish stream))) 42 | 43 | ;; ----------------------------------------------------------------------------- 44 | ;; output stream 45 | ;; ----------------------------------------------------------------------------- 46 | (defmethod stream-clear-output ((stream async-output-stream)) 47 | "Attempt to clear the output buffer of an output stream." 48 | ;; we don't have the concept of an output buffer, only an underlying UV stream 49 | ;; that's either written to or isn't 50 | nil) 51 | 52 | (defmethod stream-force-output ((stream async-output-stream)) 53 | "Force an output stream to send its data to the underlying fd." 54 | ;; we don't have the concept of an output buffer, only an underlying UV stream 55 | ;; that's either written to or isn't 56 | nil) 57 | 58 | (defmethod stream-finish-output ((stream async-output-stream)) 59 | "Really, since we're async, same as force-output." 60 | (stream-force-output stream)) 61 | 62 | (defmethod stream-write-sequence ((stream async-output-stream) sequence start end &key) 63 | "Write a sequence of bytes to the underlying streamish." 64 | (when (open-stream-p stream) 65 | (let ((seq (subseq sequence start end))) 66 | (streamish-write (streamish stream) seq) 67 | seq))) 68 | 69 | (defmethod stream-write-byte ((stream async-output-stream) byte) 70 | "Write one byte to the underlying streamish." 71 | (stream-write-sequence stream (make-array 1 :element-type 'octet 72 | :initial-element byte) 0 1)) 73 | 74 | (defmethod send-buffered-data ((stream async-output-stream)) 75 | "Take data we've buffered between initial sending and actual streamish 76 | and send it out." 77 | (let ((data (buffer-output (stream-buffer stream)))) 78 | (setf (stream-buffer stream) (make-buffer)) 79 | (streamish-write (streamish stream) data)) 80 | nil) 81 | 82 | ;; ----------------------------------------------------------------------------- 83 | ;; input stream 84 | ;; ----------------------------------------------------------------------------- 85 | (defmethod stream-clear-input ((stream async-input-stream)) 86 | "Attempt to clear the input buffer of an input stream." 87 | (when (open-stream-p stream) 88 | (setf (stream-buffer stream) (make-buffer)))) 89 | 90 | (defmethod stream-read-byte ((stream async-input-stream)) 91 | "Read one byte from the underlying streamish." 92 | (let* ((buff (make-array 1 :element-type '(unsigned-byte 8))) 93 | (num (stream-read-sequence stream buff 0 1))) 94 | (if (= num 1) 95 | (aref buff 0) 96 | :eof))) 97 | 98 | (defmethod stream-read-sequence ((stream async-input-stream) sequence start end &key) 99 | "Attempt to read a sequence of bytes from the underlying streamish." 100 | (let* ((buffer (buffer-output (stream-buffer stream))) 101 | (numbytes (min (length buffer) (- end start)))) 102 | (setf (stream-buffer stream) (make-buffer (subseq buffer numbytes))) 103 | (replace sequence buffer :start1 start :end1 end) 104 | numbytes)) 105 | 106 | ;;;; compatibility 107 | 108 | (defun stream-socket (stream) 109 | (streamish stream)) 110 | -------------------------------------------------------------------------------- /src/base.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-async-base 2 | (:use :cl) 3 | (:export #:event-info 4 | #:event-error 5 | #:event-errcode 6 | #:event-errmsg 7 | 8 | #:*event-base* 9 | #:*event-base-next-id* 10 | #:*enable-threading* 11 | #:event-base 12 | #:event-base-c 13 | #:event-base-id 14 | #:event-base-function-registry 15 | #:event-base-data-registry 16 | #:event-base-exit-functions 17 | #:event-base-signal-handlers 18 | #:event-base-dns-base 19 | #:event-base-dns-ref-count 20 | #:event-base-catch-app-errors 21 | #:event-base-send-errors-to-eventcb 22 | #:event-base-lock 23 | #:event-base-num-connections-in 24 | #:event-base-num-connections-out 25 | 26 | #:*buffer-writes* 27 | 28 | #:*buffer-size* 29 | #:*output-buffer* 30 | #:*input-buffer* 31 | #:*data-registry* 32 | #:*function-registry* 33 | #:*safe-sldb-quit-restart*)) 34 | 35 | (in-package :cl-async-base) 36 | 37 | (define-condition event-info () () 38 | (:report (lambda (c s) 39 | (print-unreadable-object (c s :type t :identity t) 40 | (format s "")))) 41 | (:documentation "Describes the base event for any action in cl-async.")) 42 | 43 | (define-condition event-error (event-info error) 44 | ((code :initarg :code :reader event-errcode :initform 0) 45 | (msg :initarg :msg :reader event-errmsg :initform nil)) 46 | (:report (lambda (c s) 47 | (print-unreadable-object (c s :type t :identity t) 48 | (format s "~a: ~a" (event-errcode c) (event-errmsg c))))) 49 | (:documentation "Describes a general error event.")) 50 | 51 | (defvar *event-base* nil 52 | "THE event base object used to process all async operations.") 53 | (defvar *event-base-next-id* 0 54 | "The numeric identifier assigned to each new event base.") 55 | (defclass event-base () 56 | ((c :accessor event-base-c :initarg :c :initform nil 57 | :documentation "Holds the C object pointing to the underlying event loop object.") 58 | (id :accessor event-base-id :initarg :id :initform nil 59 | :documentation "Holds this event loop's numeric id.") 60 | (function-registry :accessor event-base-function-registry :initarg :function-registry :initform (make-hash-table :test #'eql) 61 | :documentation "Holds all callbacks attached to this event loop.") 62 | (data-registry :accessor event-base-data-registry :initarg :data-registry :initform (make-hash-table :test #'eql) 63 | :documentation "Holds all callback data attached to this event loop.") 64 | (exit-functions :accessor event-base-exit-functions :initarg :exit-functions :initform nil 65 | :documentation "Holds functions to be run when the event loop exist (cleanly or otherwise).") 66 | (signal-handlers :accessor event-base-signal-handlers :initarg :signal-handlers :initform nil 67 | :documentation "Holds all signal handlers.") 68 | (dns-base :accessor event-base-dns-base :initarg :dns-base :initform nil 69 | :documentation "Holds the DNS base object used for DNS lookups.") 70 | (dns-ref-count :accessor event-base-dns-ref-count :initarg :dns-ref-count :initform 0 71 | :documentation "Tracks how many open requests are pending on the dns base.") 72 | ;; error handling 73 | (catch-app-errors :accessor event-base-catch-app-errors :initarg :catch-app-errors :initform nil 74 | :documentation "If t (or a function) will trap all errors produced in the event loop and process them internally") 75 | (send-errors-to-eventcb :accessor event-base-send-errors-to-eventcb :initarg :send-errors-to-eventcb :initform nil 76 | :documentation "If t, will send caught errors to the event-cb instead of handle-error") 77 | (lock :accessor event-base-lock :initarg :lock :initform (bt:make-lock) 78 | :documentation "Holds *the* lock for this event base.") 79 | ;; stats 80 | (num-connections-in :accessor event-base-num-connections-in :initform 0) 81 | (num-connections-out :accessor event-base-num-connections-out :initform 0)) 82 | (:documentation 83 | "A class that holds an event loop and all of the state that it manages. 84 | 85 | One object to rule them all, one object to find them. 86 | One object to bring them in and in the darkness bind them.")) 87 | 88 | (defvar *buffer-writes* t 89 | "If T, will buffer writes on the socket until the next loop. This is mainly to 90 | cut down on calls to uv_write, which is fairly slow.") 91 | 92 | ;; WARNING: don't change *buffer-size* unless you want weird data corruption 93 | ;; problems (at least in libuv-1.0.0-rc2) 94 | (defvar *buffer-size* (* 1024 64) 95 | "The amount of data we'll pull from the evbuffers when doing reading/writing.") 96 | (defvar *output-buffer* nil 97 | "A buffer that lives in both C and lisp worlds (static-vector) that lets us 98 | write to sockets.") 99 | (defvar *input-buffer* nil 100 | "A buffer that lives in both C and lisp worlds (static-vector) that lets us 101 | read from sockets.") 102 | 103 | (defvar *data-registry* nil 104 | "A hash table holding C pointer -> lisp data mappings.") 105 | (defvar *function-registry* nil 106 | "A hash table holding C pointer -> lisp function(s) mappings.") 107 | 108 | ;; threading/locking state. i had an internal debate whether or note to include 109 | ;; these inside the event-base class itself, but i'd honestly rather not muddy 110 | ;; it up with threading stuff. 111 | (defvar *enable-threading* nil 112 | "If true, various pieces of the cl-async internals will lock their restecpive 113 | structures before operating to ensure thread safety.") 114 | 115 | (defvar *safe-sldb-quit-restart* nil 116 | "If true, provides a safe default for SLIME debugger quit restart (ABORT-CALLBACK). 117 | This restart causes the callback to be aborted without quitting the event loop. 118 | If false, the default restart is set to EXIT-EVENT-LOOP.") 119 | -------------------------------------------------------------------------------- /src/dns.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async) 2 | 3 | (define-condition dns-error (event-error) () 4 | (:documentation "Passed to a failure callback when a DNS error occurs on a connection.")) 5 | 6 | (defmethod errno-event ((streamish t) (errno (eql (uv:errval :eai-nodata)))) 7 | (make-instance 'dns-error :code errno :msg (error-str errno))) 8 | 9 | (define-c-callback dns-cb :void ((req :pointer) (status :int) (addrinfo :pointer)) 10 | "Callback for DNS lookups." 11 | (let* ((callbacks (get-callbacks req)) 12 | (resolve-cb (getf callbacks :resolve-cb)) 13 | (event-cb (getf callbacks :event-cb))) 14 | (catch-app-errors event-cb 15 | (if (zerop status) 16 | ;; success, pull out address 17 | (multiple-value-bind (addr family err) 18 | (addrinfo-to-string addrinfo) 19 | (if (and addr (not err)) 20 | ;; got an address, call resolve-cb 21 | (funcall resolve-cb addr family) 22 | ;; hmm, didn't get an address. either came back as ipv6 or 23 | ;; there was some horrible, horrible error. 24 | (run-event-cb event-cb 25 | (make-instance 'dns-error 26 | :code -1 27 | :msg err)))) 28 | ;; error, signal 29 | (run-event-cb 'event-handler status event-cb)) 30 | (uv:free-req req) 31 | (free-pointer-data req :preserve-pointer t) 32 | (uv:uv-freeaddrinfo addrinfo)))) 33 | 34 | (defun dns-lookup (host resolve-cb &key event-cb (family +af-inet+)) 35 | "Asynchronously lookup a DNS address. Note that if an IP address is passed, 36 | the lookup happens synchronously. If a lookup is synchronous (and instant) 37 | this returns T, otherwise nil (lookup happening in background). Either way 38 | the resolve-cb is called with the lookup info (so always assume this is 39 | async)." 40 | (check-event-loop-running) 41 | (assert (member family (list +af-inet+ +af-inet6+ +af-unspec+))) 42 | (let ((lookup-c (uv:alloc-req :getaddrinfo)) 43 | (loop-c (event-base-c *event-base*))) 44 | (with-foreign-object* (hints uv:addrinfo) 45 | ((uv-a:addrinfo-ai-family family) 46 | (uv-a:addrinfo-ai-flags 0) ;#x2000 AI_CANONNAME 47 | (uv-a:addrinfo-ai-socktype uv:+sock-stream+) 48 | (uv-a:addrinfo-ai-protocol uv:+ipproto-tcp+)) 49 | (save-callbacks lookup-c (list :resolve-cb resolve-cb 50 | :event-cb event-cb)) 51 | (let ((res (uv:uv-getaddrinfo loop-c lookup-c (cffi:callback dns-cb) host (cffi:null-pointer) hints))) 52 | (if (< res 0) 53 | (event-handler res event-cb :throw t) 54 | t))))) 55 | 56 | (define-c-callback reverse-dns-cb :void ((req :pointer) (status :int) (hostname :string) (service :string)) 57 | "Callback for reverse DNS lookups." 58 | (let* ((callbacks (get-callbacks req)) 59 | (resolve-cb (getf callbacks :resolve-cb)) 60 | (event-cb (getf callbacks :event-cb))) 61 | (catch-app-errors event-cb 62 | (if (zerop status) 63 | (funcall resolve-cb hostname service) 64 | (run-event-cb 'event-handler status event-cb)) 65 | (uv:free-req req) 66 | (free-pointer-data req :preserve-pointer t)))) 67 | 68 | (defun reverse-dns-lookup (ip resolve-cb &key event-cb) 69 | "Perform reverse DNS lookup on IP specifier as string. Call RESOLVE-CB with 70 | resolved HOST and SERVICE as strings. The callback is called once with one 71 | host, even if multiple hosts match the query." 72 | (check-event-loop-running) 73 | (let ((lookup-c (uv:alloc-req :getnameinfo)) 74 | (loop-c (event-base-c *event-base*))) 75 | (flet ((lookup (addr) 76 | (save-callbacks lookup-c (list :resolve-cb resolve-cb :event-cb event-cb)) 77 | (let ((res (uv:uv-getnameinfo loop-c lookup-c (cffi:callback reverse-dns-cb) addr 0))) 78 | (if (< res 0) 79 | (event-handler res event-cb :throw t) 80 | t)))) 81 | (if (and ip (find #\: ip)) 82 | (with-foreign-object* (addr uv:sockaddr-in6) 83 | ((uv-a:sockaddr-in-sin-family +af-inet6+)) 84 | (uv:uv-inet-pton +af-inet6+ ip (cffi:foreign-slot-pointer addr '(:struct uv:sockaddr-in6) 'uv:sin6-addr)) 85 | (lookup addr)) 86 | (with-foreign-object* (addr uv:sockaddr-in) 87 | ((uv-a:sockaddr-in-sin-family +af-inet+)) 88 | (uv:uv-inet-pton +af-inet+ ip (cffi:foreign-slot-pointer addr '(:struct uv:sockaddr-in) 'uv:sin-addr)) 89 | (lookup addr)))))) 90 | -------------------------------------------------------------------------------- /src/event-loop.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async) 2 | 3 | (defparameter *loop-close-iters* 100000 4 | "Maximum number of event loop cleanup iterations") 5 | 6 | (defun add-event-loop-exit-callback (fn) 7 | "Add a function to be run when the event loop exits." 8 | (push fn (event-base-exit-functions *event-base*))) 9 | 10 | (defun process-event-loop-exit-callbacks () 11 | "run and clear out all event loop exit functions." 12 | (dolist (fn (event-base-exit-functions *event-base*)) 13 | (funcall fn)) 14 | (setf (event-base-exit-functions *event-base*) nil)) 15 | 16 | (defun check-event-loop-running () 17 | (unless (and *event-base* (event-base-c *event-base*)) 18 | (error "Event loop not running. Start with function start-event-loop."))) 19 | 20 | (defgeneric ref (handle) 21 | (:documentation 22 | "Reference a libuv handle object (uv_ref)")) 23 | 24 | (defgeneric unref (handle) 25 | (:documentation 26 | "Unreference a libuv handle object (uv_unref)")) 27 | 28 | (defun stats () 29 | "Return statistics about the current event loop." 30 | (list :open-dns-queries (event-base-dns-ref-count *event-base*) 31 | :fn-registry-count (hash-table-count *function-registry*) 32 | :data-registry-count (hash-table-count *data-registry*) 33 | :incoming-tcp-connections (event-base-num-connections-in *event-base*) 34 | :outgoing-tcp-connections (event-base-num-connections-out *event-base*))) 35 | 36 | (define-c-callback walk-cb :void ((handle :pointer) (arg :pointer)) 37 | "Called when we're walking the loop." 38 | (declare (ignore arg)) 39 | (format t "handle: ~s (~a)~%" (uv:handle-type handle) handle) 40 | (force-output)) 41 | 42 | (defun dump-event-loop-status () 43 | "Return the status of the event loop. Really a debug function more than 44 | anything else." 45 | (check-event-loop-running) 46 | (uv:uv-walk (event-base-c *event-base*) (cffi:callback walk-cb) (cffi:null-pointer)) 47 | (values)) 48 | 49 | (defvar *event-base-registry* (make-hash-table :test 'eq) 50 | "Holds ID -> event-base lookups for every active event loop. Mainly used when 51 | grabbing the threading context for a particular event loop.") 52 | 53 | (defvar *event-base-registry-lock* (bt:make-lock) 54 | "Locks the event-base registry.") 55 | 56 | (defgeneric handle-cleanup (handle-type handle) 57 | (:documentation "Perform cleanup for a libuv handle") 58 | (:method ((handle-type t) (handle t)) (values))) 59 | 60 | (define-c-callback loop-exit-walk-cb :void ((handle :pointer) (arg :pointer)) 61 | "Called when we want to close the loop AND IT WONT CLOSE. So we walk each 62 | handle and close them." 63 | (declare (ignore arg)) 64 | (handle-cleanup (uv:handle-type handle) handle)) 65 | 66 | (defun do-close-loop (evloop) 67 | "Close an event loop by looping over its open handles, closing them, rinsing 68 | and repeating until uv-loop-close returns 0, but at most *LOOP-CLOSE-ITERS* 69 | times." 70 | (process-event-loop-exit-callbacks) 71 | (loop repeat *loop-close-iters* 72 | for res = (uv:uv-loop-close evloop) 73 | when (zerop res) 74 | return (values) 75 | else 76 | do (progn 77 | (uv:uv-stop evloop) 78 | (uv:uv-walk evloop (cffi:callback loop-exit-walk-cb) (cffi:null-pointer)) 79 | (uv:uv-run evloop (cffi:foreign-enum-value 'uv:uv-run-mode :run-default)) 80 | (uv:uv-run evloop (cffi:foreign-enum-value 'uv:uv-run-mode :run-default))) 81 | end 82 | finally 83 | (vom:error "failed to do loop cleanup in ~d iterations" *loop-close-iters*) 84 | (dump-event-loop-status))) 85 | 86 | (defun start-event-loop (start-fn &key catch-app-errors (send-errors-to-eventcb t)) 87 | "Simple wrapper function that starts an event loop which runs the given 88 | callback, most likely to init your server/client." 89 | (when *event-base* 90 | (error "Event loop already started. Please wait for it to exit.")) 91 | (cffi:with-foreign-object (loop :unsigned-char (uv:uv-loop-size)) 92 | (uv:uv-loop-init loop) 93 | ;; note the binding of these variable via (let), which means they are thread- 94 | ;; local... so this function can be called in different threads, and the bound 95 | ;; variables won't interfere with each other. 96 | (let* ((*event-base* (make-instance 97 | 'event-base 98 | :c loop 99 | :id *event-base-next-id* 100 | :catch-app-errors catch-app-errors 101 | :send-errors-to-eventcb send-errors-to-eventcb)) 102 | (*buffer-writes* *buffer-writes*) 103 | (*buffer-size* *buffer-size*) 104 | (*output-buffer* (static-vectors:make-static-vector *buffer-size* :element-type 'octet)) 105 | (*input-buffer* (static-vectors:make-static-vector *buffer-size* :element-type 'octet)) 106 | (*data-registry* (event-base-data-registry *event-base*)) 107 | (*function-registry* (event-base-function-registry *event-base*)) 108 | (callbacks nil)) 109 | (incf *event-base-next-id*) 110 | (delay start-fn) 111 | ;; this is the once instance where we assign callbacks to an event loop object 112 | ;; instead of a data-pointer since the callbacks don't take any void* args, 113 | ;; meaning we have to dereference from the global (event-base-c *event-base*) object. 114 | (save-callbacks (event-base-c *event-base*) callbacks) 115 | (bt:with-lock-held (*event-base-registry-lock*) 116 | (setf (gethash (event-base-id *event-base*) *event-base-registry*) *event-base*)) 117 | (unwind-protect 118 | (progn 119 | ;; this will block until all events are processed 120 | (uv:uv-run (event-base-c *event-base*) (cffi:foreign-enum-value 'uv:uv-run-mode :run-default))) 121 | ;; cleanup 122 | (do-close-loop (event-base-c *event-base*)) 123 | (static-vectors:free-static-vector *output-buffer*) 124 | (static-vectors:free-static-vector *input-buffer*) 125 | (free-pointer-data (event-base-c *event-base*) :preserve-pointer t) 126 | (bt:with-lock-held (*event-base-registry-lock*) 127 | (remhash (event-base-id *event-base*) *event-base-registry*)) 128 | (setf *event-base* nil))))) 129 | 130 | (defmacro with-event-loop ((&key catch-app-errors (send-errors-to-eventcb t)) 131 | &body body) 132 | "Makes starting an event loop a tad less annoying. I really couldn't take 133 | typing out `(start-event-loop (lambda () ...) ...) every time. Example: 134 | 135 | (with-event-loop (:catch-app-errors t) 136 | (do-something-one-does-when-an-event-loop-is-running)) 137 | 138 | See how nice that is?" 139 | `(as:start-event-loop (lambda () ,@body) 140 | :catch-app-errors ,catch-app-errors 141 | :send-errors-to-eventcb ,send-errors-to-eventcb)) 142 | 143 | (defun exit-event-loop () 144 | "Exit the event loop if running." 145 | (let ((evloop (event-base-c *event-base*))) 146 | (when evloop 147 | (uv:uv-stop evloop)))) 148 | -------------------------------------------------------------------------------- /src/event.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async) 2 | 3 | (define-condition event-freed (event-error) 4 | ((event :initarg :event :accessor event-freed-event :initform nil)) 5 | (:documentation "Thrown when a freed event is operated on.")) 6 | 7 | (defclass event () 8 | ((c :accessor event-c :initarg :c :initform (cffi:null-pointer)) 9 | (freed :accessor event-freed :reader event-freed-p :initform nil)) 10 | (:documentation "Wraps a C libuv event object.")) 11 | 12 | (defun check-event-unfreed (event) 13 | "Checks that an event being operated on is not freed." 14 | (when (event-freed event) 15 | (error 'event-freed :event event :msg "Freed event being operated on"))) 16 | 17 | (defun free-event (event) 18 | "Free a cl-async event object and any resources it uses." 19 | (check-event-unfreed event) 20 | (setf (event-freed event) t) 21 | (let ((timer-c (event-c event))) 22 | (when (zerop (uv:uv-is-closing timer-c)) 23 | (uv:uv-close timer-c (cffi:callback timer-close-cb))))) 24 | 25 | (defun remove-event (event) 26 | "Remove a pending event from the event loop." 27 | (check-event-unfreed event) 28 | (let ((timer-c (event-c event))) 29 | (uv:uv-timer-stop timer-c)) 30 | t) 31 | 32 | (defmethod ref ((handle event)) 33 | (uv:uv-ref (event-c handle))) 34 | 35 | (defmethod unref ((handle event)) 36 | (uv:uv-unref (event-c handle))) 37 | 38 | (defun add-event (event &key timeout activate) 39 | "Add an event to its specified event loop (make it pending). If given a 40 | :timeout (in seconds) the event will fire after that amount of time, unless 41 | it's removed or freed." 42 | (declare (ignore activate)) ;; compatibility-only 43 | (check-event-unfreed event) 44 | (let ((timer-c (event-c event))) 45 | (uv:uv-timer-start timer-c (cffi:callback timer-cb) (round (* (or timeout 0) 1000)) 0))) 46 | 47 | (define-c-callback timer-cb :void ((timer-c :pointer)) 48 | "Callback used by the async timer system to find and run user-specified 49 | callbacks on timer events." 50 | (let* ((event (deref-data-from-pointer timer-c)) 51 | (callbacks (get-callbacks timer-c)) 52 | (cb (getf callbacks :callback)) 53 | (event-cb (getf callbacks :event-cb))) 54 | (catch-app-errors event-cb 55 | (unwind-protect 56 | (when cb (funcall cb)) 57 | (unless (event-freed-p event) 58 | (free-event event)))))) 59 | 60 | (define-c-callback timer-close-cb :void ((timer-c :pointer)) 61 | "Called when a timer closes." 62 | (free-pointer-data timer-c :preserve-pointer t) 63 | (uv:uv-timer-stop timer-c) 64 | (uv:free-handle timer-c)) 65 | 66 | (defun delay (callback &key time event-cb) 67 | "Run a function, asynchronously, after the specified amount of seconds. An 68 | event loop must be running for this to work. 69 | 70 | If time is nil, callback is still called asynchronously, but is queued in the 71 | event loop with no delay." 72 | (check-event-loop-running) 73 | (let* ((timer-c (uv:alloc-handle :timer)) 74 | (event (make-instance 'event :c timer-c))) 75 | (uv:uv-timer-init (event-base-c *event-base*) timer-c) 76 | (save-callbacks timer-c (list :callback callback :event-cb event-cb)) 77 | (attach-data-to-pointer timer-c event) 78 | (add-event event :timeout time :activate t) 79 | event)) 80 | 81 | (defmacro with-delay ((&optional (seconds 0)) &body body) 82 | "Nicer syntax for delay function." 83 | `(delay (lambda () ,@body) :time ,seconds)) 84 | 85 | (defun interval (callback &key time event-cb) 86 | "Run a function, asynchronously, every `time` seconds. This function returns a 87 | function which, when called, cancels the interval." 88 | ;; TODO: convert to uv-timer w/repeat 89 | (let (event) 90 | (labels ((main () 91 | (funcall callback) 92 | (when event 93 | (setf event (as:delay #'main :time time :event-cb event-cb))))) 94 | (setf event (as:delay #'main :time time :event-cb event-cb)) 95 | (lambda () 96 | (when event 97 | (remove-event event) 98 | (setf event nil)))))) 99 | 100 | (defmacro with-interval ((seconds) &body body) 101 | "Nicer syntax for interval function." 102 | `(interval (lambda () ,@body) :time ,seconds)) 103 | 104 | (defun remove-interval (interval-fn) 105 | "Stops an interval from looping." 106 | (funcall interval-fn)) 107 | 108 | (defun make-event (callback &key event-cb) 109 | "Make an arbitrary event, and add it to the event loop. It *must* be triggered 110 | by (add-event :activate t) or it will sit, idle, for 100 years. 111 | Or you can remove/free it instead. 112 | 113 | This is useful for triggering arbitrary events, and can even be triggered 114 | from a thread outside the libuv loop." 115 | (delay callback :event-cb event-cb :time (* 100 31536000))) 116 | 117 | (defmethod handle-cleanup ((handle-type (eql :timer)) handle) 118 | (let ((event (deref-data-from-pointer handle))) 119 | (unless (event-freed-p event) 120 | (free-event event)))) 121 | -------------------------------------------------------------------------------- /src/filesystem.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async) 2 | 3 | ;; TBD: path encoding 4 | 5 | (define-condition filesystem-error (event-error) () 6 | (:documentation "Base class for filesystem conditions")) 7 | 8 | (define-condition filesystem-enoent (filesystem-error) () 9 | (:documentation "Error: no such file or directory")) 10 | 11 | (define-condition filesystem-eacces (filesystem-error) () 12 | (:documentation "Error: access denied")) 13 | 14 | (define-condition filesystem-eperm (filesystem-error) () 15 | (:documentation "Error: permission denied")) 16 | 17 | (defmethod errno-event ((streamish t) (errno (eql (uv:errval :enoent)))) 18 | (make-instance 'filesystem-enoent :code errno :msg (error-str errno))) 19 | 20 | (defmethod errno-event ((streamish t) (errno (eql (uv:errval :eacces)))) 21 | (make-instance 'filesystem-eacces :code errno :msg (error-str errno))) 22 | 23 | (defmethod errno-event ((streamish t) (errno (eql (uv:errval :eperm)))) 24 | (make-instance 'filesystem-eperm :code errno :msg (error-str errno))) 25 | 26 | (define-c-callback fs-cb :void ((req :pointer)) 27 | (let* ((callbacks (get-callbacks req)) 28 | (cb (getf callbacks :fs-cb)) 29 | (event-cb (getf callbacks :event-cb))) 30 | (catch-app-errors event-cb 31 | (unwind-protect 32 | (let ((res (uv-a:uv-fs-s-result req))) 33 | (if (zerop res) 34 | (funcall cb (uiop:ensure-directory-pathname 35 | (uv-a:uv-fs-s-path req))) 36 | (run-event-cb 'event-handler res event-cb))) 37 | (uv:uv-fs-req-cleanup req) 38 | (free-pointer-data req :preserve-pointer t) 39 | (uv:free-req req))))) 40 | 41 | (defun mkdtemp (template cb &key (event-cb #'error)) 42 | (check-event-loop-running) 43 | (let ((tpl (namestring template))) 44 | (let* ((req (uv:alloc-req :fs)) 45 | (res (uv:uv-fs-mkdtemp (event-base-c *event-base*) 46 | req tpl (cffi:callback fs-cb)))) 47 | (cond ((zerop res) 48 | (save-callbacks req (list :fs-cb cb 49 | :event-cb event-cb))) 50 | (t 51 | (uv:uv-fs-req-cleanup req) 52 | (uv:free-req req) 53 | (event-handler res event-cb :throw t)))))) 54 | 55 | -------------------------------------------------------------------------------- /src/fsevent.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async) 2 | 3 | (defclass fs-monitor () 4 | ((c :accessor fs-monitor-c))) 5 | 6 | (defmethod initialize-instance :after ((fs-monitor fs-monitor) &key &allow-other-keys) 7 | (setf (fs-monitor-c fs-monitor) 8 | (uv:alloc-handle :fs-event))) 9 | 10 | (define-c-callback fs-event-callback :void ((handle :pointer) (path :string) 11 | (events :int) (status :int)) 12 | (let* ((fs-monitor (deref-data-from-pointer handle)) 13 | (callbacks (get-callbacks handle)) 14 | (event-cb (getf callbacks :event-cb)) 15 | (fs-cb (getf callbacks :fs-cb))) 16 | (catch-app-errors event-cb 17 | (if (zerop status) 18 | (funcall fs-cb 19 | fs-monitor path 20 | (plusp (logand events (cffi:foreign-enum-value 'uv:uv-fs-event :rename))) 21 | (plusp (logand events (cffi:foreign-enum-value 'uv:uv-fs-event :change)))) 22 | (run-event-cb 'event-handler status event-cb))))) 23 | 24 | ;; Fixme: copy & paste. Need common handle wrapper superclass 25 | (define-c-callback fs-monitor-close-cb :void ((handle :pointer)) 26 | "Called when a fs-monitor closes." 27 | ;; FIXME: same as streamish-close-cb 28 | (free-pointer-data handle :preserve-pointer t) 29 | (uv:free-handle handle)) 30 | 31 | (defun %fs-monitor-close (handle) 32 | (uv:uv-close handle (cffi:callback fs-monitor-close-cb))) 33 | 34 | (defun fs-monitor-close (fs-monitor) 35 | (%fs-monitor-close (fs-monitor-c fs-monitor)) 36 | (setf (fs-monitor-c fs-monitor) nil)) 37 | 38 | (defun fs-watch (path callback &key (event-cb #'error)) 39 | (let* ((fs-monitor (make-instance 'fs-monitor)) 40 | (handle (fs-monitor-c fs-monitor))) 41 | (let ((res (uv:uv-fs-event-init (event-base-c *event-base*) handle))) 42 | (unless (zerop res) 43 | ;; this shouldn't actually occur as no libuv backends return 44 | ;; non-zero result for uv_fs_event_init() 45 | (uv:free-handle handle) 46 | (event-handler res event-cb :throw t) 47 | (return-from fs-watch)) 48 | (when (zerop res) 49 | (attach-data-to-pointer handle fs-monitor) 50 | (save-callbacks handle (list :fs-cb callback :event-cb event-cb)) 51 | (setf res 52 | (uv:uv-fs-event-start 53 | handle (cffi:callback fs-event-callback) 54 | (namestring path) 55 | #+(or darwin windows) 56 | (cffi:foreign-enum-value 'uv:uv-fs-event-flags :recursive) 57 | #+linux 0)) 58 | (cond ((zerop res) 59 | fs-monitor) 60 | (t 61 | (as:with-delay () 62 | (fs-monitor-close handle)) 63 | (event-handler res event-cb :throw t) 64 | nil)))))) 65 | 66 | ;; FIXME: is this really needed? 67 | (defun fs-unwatch (fs-monitor) 68 | (uv:uv-fs-event-stop (fs-monitor-c fs-monitor))) 69 | 70 | (defmethod handle-cleanup ((handle-type (eql :fs-event)) handle) 71 | (let ((fs-monitor (deref-data-from-pointer handle))) 72 | (%fs-monitor-close handle) 73 | (when fs-monitor 74 | (setf (fs-monitor-c fs-monitor) nil)))) 75 | -------------------------------------------------------------------------------- /src/idle.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async) 2 | 3 | (defclass idler () 4 | ((c :accessor idler-c :initarg :c :initform (cffi:null-pointer)) 5 | (freed :accessor idler-freed :reader idler-freed-p :initform nil)) 6 | (:documentation "Wraps a libuv idle handle.")) 7 | 8 | (defun free-idler (idler) 9 | "Stop and free an idler." 10 | (unless (idler-freed-p idler) 11 | (setf (idler-freed idler) t) 12 | (let ((idle-c (idler-c idler))) 13 | (when idle-c 14 | (uv:uv-idle-stop idle-c) 15 | (uv:uv-close idle-c (cffi:callback idle-close-cb)))))) 16 | 17 | (define-c-callback idle-close-cb :void ((idle-c :pointer)) 18 | "Called when an idler closes." 19 | (free-pointer-data idle-c :preserve-pointer t) 20 | (uv:free-handle idle-c)) 21 | 22 | (define-c-callback idle-cb :void ((handle :pointer)) 23 | "Called when an idle handler fires." 24 | (let* ((callbacks (get-callbacks handle)) 25 | (idle-cb (getf callbacks :idle-cb)) 26 | (event-cb (getf callbacks :event-cb))) 27 | (catch-app-errors event-cb 28 | (when idle-cb (funcall idle-cb))))) 29 | 30 | (defun idle (callback &key event-cb) 31 | "Calls `callback` once per event loop." 32 | (check-event-loop-running) 33 | (let* ((idle-c (uv:alloc-handle :idle)) 34 | (idler (make-instance 'idler :c idle-c))) 35 | (uv:uv-idle-init (event-base-c *event-base*) idle-c) 36 | (save-callbacks idle-c (list :idle-cb callback 37 | :event-cb event-cb)) 38 | (uv:uv-idle-start idle-c (cffi:callback idle-cb)) 39 | idler)) 40 | 41 | -------------------------------------------------------------------------------- /src/notify.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async) 2 | 3 | (define-condition notifier-freed (event-error) 4 | ((notifier :initarg :notifier :accessor notifier-freed-notifier :initform nil)) 5 | (:documentation "Thrown when a freed notifier is operated on.")) 6 | 7 | (defclass notifier () 8 | ((c :accessor notifier-c :initarg :c :initform (cffi:null-pointer)) 9 | (freed :accessor notifier-freed :reader notifier-freed-p :initform nil) 10 | (single-shot :accessor notifier-single-shot :reader notifier-single-shot-p 11 | :initarg :single-shot :initform t)) 12 | (:documentation "Wraps a threading-enabled notifier.")) 13 | 14 | (defun check-notifier-unfreed (notifier) 15 | "Checks that an notifier being operated on is not freed." 16 | (when (notifier-freed notifier) 17 | (error 'notifier-freed :notifier notifier :msg "Freed notifier being operated on"))) 18 | 19 | (defun free-notifier (notifier) 20 | "Free a cl-async notifier object and any resources it uses." 21 | (check-notifier-unfreed notifier) 22 | (setf (notifier-freed notifier) t) 23 | (let ((async-c (notifier-c notifier))) 24 | (when (zerop (uv:uv-is-closing async-c)) 25 | (uv:uv-close async-c (cffi:callback async-close-cb)) 26 | (setf (notifier-c notifier) nil)))) 27 | 28 | (defmethod ref ((handle notifier)) 29 | (uv:uv-ref (notifier-c handle))) 30 | 31 | (defmethod unref ((handle notifier)) 32 | (uv:uv-unref (notifier-c handle))) 33 | 34 | (define-c-callback async-close-cb :void ((async-c :pointer)) 35 | "Called when an async handle is closed." 36 | (free-pointer-data async-c :preserve-pointer t) 37 | (uv:free-handle async-c)) 38 | 39 | (define-c-callback async-cb :void ((async-c :pointer)) 40 | "Called when an async notifier is triggered." 41 | (let* ((notifier (deref-data-from-pointer async-c)) 42 | (callbacks (get-callbacks async-c)) 43 | (callback (getf callbacks :main-cb)) 44 | (event-cb (getf callbacks :event-cb))) 45 | (catch-app-errors event-cb 46 | (unwind-protect 47 | (when callback (funcall callback)) 48 | (when (and (notifier-single-shot-p notifier) 49 | (not (notifier-freed-p notifier))) 50 | (free-notifier notifier)))))) 51 | 52 | (defun make-notifier (callback &key event-cb (single-shot t)) 53 | "Makes a notifier, an object that can trigger a callback from a thread other 54 | than the event loop thread. If single-shot is true (the default), 55 | free the notifier after it's triggered." 56 | (check-event-loop-running) 57 | (let* ((async-c (uv:alloc-handle :async)) 58 | (notifier (make-instance 'notifier :c async-c 59 | :single-shot single-shot))) 60 | (let ((r (uv:uv-async-init (event-base-c *event-base*) async-c (cffi:callback async-cb)))) 61 | (if (< r 0) 62 | (event-handler r event-cb :throw t) 63 | (progn 64 | (save-callbacks async-c (list :main-cb callback 65 | :event-cb event-cb)) 66 | (attach-data-to-pointer async-c notifier) 67 | notifier))))) 68 | 69 | (defun trigger-notifier (notifier) 70 | "Fires the callback attached to a notifier. Can be called from any thread." 71 | (check-notifier-unfreed notifier) 72 | (let ((async-c (notifier-c notifier))) 73 | (uv:uv-async-send async-c))) 74 | 75 | (defmethod handle-cleanup ((handle-type (eql :async)) handle) 76 | (let ((notifier (deref-data-from-pointer handle))) 77 | (unless (notifier-freed-p notifier) 78 | (free-notifier notifier)))) 79 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-async 2 | (:use :cl :cl-async-base :cl-async-util :trivial-gray-streams) 3 | (:nicknames :as) 4 | (:shadow cl-async-util:exit-event-loop) 5 | (:export #:octet 6 | #:octet-vector 7 | 8 | #:handle-error 9 | 10 | #:bytes 11 | 12 | #:+af-inet+ 13 | #:+af-inet6+ 14 | #:+af-unspec+ 15 | #:+af-unix+ 16 | 17 | #:*buffer-writes* 18 | #:*buffer-size* 19 | 20 | ;; common conditions/accessors 21 | #:event-info 22 | #:event-error 23 | #:event-errcode 24 | #:event-errmsg 25 | ;; common functions 26 | #:stats 27 | #:dump-event-loop-status 28 | #:add-event-loop-exit-callback 29 | #:ref 30 | #:unref 31 | #:start-event-loop 32 | #:with-event-loop 33 | #:exit-event-loop 34 | 35 | ;; event functions 36 | #:event-freed 37 | #:event 38 | #:event-c 39 | #:event-freed-p 40 | #:free-event 41 | #:remove-event 42 | #:add-event 43 | #:delay 44 | #:with-delay 45 | #:interval 46 | #:with-interval 47 | #:remove-interval 48 | #:make-event 49 | 50 | ;; notifier exports 51 | #:notifier 52 | #:notifier-freed-p 53 | #:free-notifier 54 | #:make-notifier 55 | #:trigger-notifier 56 | 57 | ;; signal numbers 58 | #:+sighup+ 59 | #:+sigint+ 60 | #:+sigquit+ 61 | #:+sigill+ 62 | #:+sigtrap+ 63 | #:+sigabrt+ 64 | #:+sigemt+ 65 | #:+sigfpe+ 66 | #:+sigkill+ 67 | #:+sigbus+ 68 | #:+sigsegv+ 69 | #:+sigsys+ 70 | #:+sigpipe+ 71 | #:+sigalrm+ 72 | #:+sigterm+ 73 | #:+sigurg+ 74 | #:+sigstop+ 75 | #:+sigtstp+ 76 | #:+sigcont+ 77 | #:+sigchld+ 78 | #:+sigttin+ 79 | #:+sigttou+ 80 | #:+sigio+ 81 | #:+sigxcpu+ 82 | #:+sigxfsz+ 83 | #:+sigvtalrm+ 84 | #:+sigprof+ 85 | #:+sigwinch+ 86 | #:+siginfo+ 87 | #:+sigusr1+ 88 | #:+sigusr2+ 89 | ;; signal handling functions 90 | #:signal-handler 91 | #:free-signal-handler 92 | #:clear-signal-handlers 93 | 94 | ;; dns conditions 95 | #:dns-error 96 | ;; dns functions 97 | #:dns-lookup 98 | #:reverse-dns-lookup 99 | 100 | ;; streamish/socket/tcp/pipe conditions/accessors 101 | #:streamish 102 | #:close-streamish 103 | #:streamish-info 104 | #:streamish-error 105 | #:streamish-enoent 106 | #:streamish-eof 107 | #:streamish-broken-pipe 108 | #:streamish-canceled 109 | #:streamish-closed 110 | #:check-streamish-open 111 | #:streamish-closed-p 112 | #:close-streamish 113 | #:streamish-write 114 | 115 | #:socket-info 116 | #:socket-socket 117 | #:socket-error 118 | #:socket-eof 119 | #:socket-reset 120 | #:socket-timeout 121 | #:socket-refused 122 | #:socket-aborted 123 | #:socket-address-in-use 124 | #:socket-accept-error 125 | #:socket-accept-error-listener 126 | #:socket-accept-error-tcp-server 127 | #:tcp-info 128 | #:tcp-socket 129 | #:tcp-error 130 | #:tcp-eof 131 | #:tcp-reset 132 | #:tcp-timeout 133 | #:tcp-refused 134 | #:tcp-accept-error 135 | #:socket-closed 136 | #:tcp-server-bind-error 137 | ;; socket class/accessors 138 | #:socket 139 | #:socket-c 140 | #:socket-data 141 | ;; tcp functions 142 | #:socket-closed-p 143 | #:close-socket 144 | #:close-socket-server 145 | #:close-tcp-server 146 | #:write-socket-data 147 | #:set-socket-timeouts 148 | #:enable-socket 149 | #:disable-socket 150 | #:init-tcp-socket 151 | #:connect-tcp-socket 152 | #:tcp-connect 153 | #:tcp-server 154 | 155 | #:pipe-connect 156 | #:pipe-server 157 | #:pipe-not-found 158 | 159 | ;; tcp stream 160 | #:async-stream 161 | #:stream-socket 162 | #:async-input-stream 163 | #:async-output-stream 164 | #:async-io-stream 165 | 166 | ;; idler 167 | #:idler 168 | #:idler-freed-p 169 | #:free-idler 170 | #:idle 171 | 172 | #:poller 173 | #:poller-freed-p 174 | #:free-poller 175 | #:poll 176 | 177 | #:mkdtemp 178 | #:filesystem-error 179 | #:filesystem-enoent 180 | #:filesystem-eacces 181 | #:filesystem-eperm 182 | 183 | #:spawn 184 | #:process-input 185 | #:process-output 186 | #:process-error-output 187 | #:process-kill 188 | 189 | #:fs-watch 190 | #:fs-unwatch 191 | #:fs-monitor-close)) 192 | -------------------------------------------------------------------------------- /src/pipe.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async) 2 | 3 | (defclass pipe-mixin () ()) 4 | (defclass pipe (pipe-mixin socket) ()) 5 | (defclass pipe-server (pipe-mixin socket-server) ()) 6 | 7 | (defmethod server-socket-class ((server pipe-server)) 'tcp-socket) 8 | 9 | (defmethod make-socket-handle ((socket-or-server pipe-mixin)) 10 | (let ((s (uv:alloc-handle :named-pipe))) 11 | ;; TBD: support passing descriptors via pipe (ipc != 0) 12 | (uv:uv-pipe-init (event-base-c *event-base*) s 0) 13 | s)) 14 | 15 | (defmethod socket-server-bind ((server pipe-server) address fd) 16 | (if fd 17 | (uv:uv-pipe-open (socket-server-c server) fd) 18 | (uv:uv-pipe-bind (socket-server-c server) address))) 19 | 20 | (defun %pipe-connect (socket/stream name) 21 | "Connect a pipe initialized with init-client-socket." 22 | (let* ((socket (if (subtypep (type-of socket/stream) 'async-stream) 23 | (streamish socket/stream) 24 | socket/stream)) 25 | (uvstream (socket-c socket))) 26 | ;; track the connection 27 | (incf (event-base-num-connections-out *event-base*)) 28 | (let ((req (uv:alloc-req :connect))) 29 | ;; make sure we can grab the original uvstream from the req 30 | (attach-data-to-pointer req uvstream) 31 | (uv:uv-pipe-connect req uvstream name (cffi:callback socket-connect-cb)) 32 | socket/stream))) 33 | 34 | (defun pipe-connect (name read-cb 35 | &key data stream event-cb connect-cb write-cb 36 | (read-timeout -1) 37 | (write-timeout -1) 38 | (dont-drain-read-buffer nil dont-drain-read-buffer-supplied-p)) 39 | "Open a pipe connection asynchronously. Optionally send data out once connected 40 | via the :data keyword (can be a string or byte array)." 41 | (check-type data (or null (simple-array octet (*)) string)) 42 | (let ((socket/stream (apply #'init-client-socket 43 | 'pipe 44 | (append (list :read-cb read-cb 45 | :event-cb event-cb 46 | :data data 47 | :stream stream 48 | :connect-cb connect-cb 49 | :write-cb write-cb 50 | :read-timeout read-timeout 51 | :write-timeout write-timeout) 52 | (when dont-drain-read-buffer-supplied-p 53 | (list :dont-drain-read-buffer dont-drain-read-buffer)))))) 54 | (%pipe-connect socket/stream (namestring name)))) 55 | 56 | (defun pipe-server (name read-cb &key event-cb connect-cb backlog stream fd) 57 | "Start a pipe listener on the current event loop. Returns a tcp-server class 58 | which can be closed with close-tcp-server" 59 | (socket-server 'pipe-server 60 | (namestring name) read-cb 61 | :event-cb event-cb 62 | :connect-cb connect-cb 63 | :backlog backlog 64 | :stream stream 65 | :fd fd)) 66 | 67 | (defmethod handle-cleanup ((handle-type (eql :named-pipe)) handle) 68 | (handle-cleanup :async-socket handle)) 69 | 70 | ;; TBD: export socket/streamish (...closed-p etc. stuff, too) 71 | ;; TBD: stream-socket replacement!!! 72 | ;; TBD: export socket conditions 73 | ;; TBD: refactor test 74 | ;; TBD: use mkdtemp for pipe tests (available via libuv) 75 | ;; TBD: loop-exit-walk-cb (use generics, separate case for plain streams) 76 | ;; TBD: to issues: uv_tcp_connect() errors not checked in tcp 77 | ;; TBD: utf-8 streams 78 | -------------------------------------------------------------------------------- /src/poll.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async) 2 | 3 | (defclass poller () 4 | ((c :accessor poller-c :initarg :c :initform (cffi:null-pointer)) 5 | (freed :accessor poller-freed :reader poller-freed-p :initform nil)) 6 | (:documentation "Wraps a polling handle.")) 7 | 8 | (defun free-poller (poller) 9 | "Stop and free a poller." 10 | (unless (poller-freed-p poller) 11 | (setf (poller-freed poller) t) 12 | (let ((poll-c (poller-c poller))) 13 | (when poll-c 14 | (uv:uv-poll-stop poll-c) 15 | (uv:uv-close poll-c (cffi:callback poll-close-cb)))))) 16 | 17 | (define-c-callback poll-close-cb :void ((poll-c :pointer)) 18 | "Called when a poller closes." 19 | (free-pointer-data poll-c :preserve-pointer t) 20 | (uv:free-handle poll-c)) 21 | 22 | (define-c-callback poll-cb :void ((poll-c :pointer) (status :int) (events :int)) 23 | "Called when something happens on a polled FD." 24 | (let* ((callbacks (get-callbacks poll-c)) 25 | (poll-cb (getf callbacks :poll-cb)) 26 | (event-cb (getf callbacks :event-cb))) 27 | (catch-app-errors event-cb 28 | (if (< status 0) 29 | ;; got an error, pass it along 30 | (event-handler status event-cb) 31 | ;; kewl, forward the event(s) along 32 | (let ((events-named nil)) 33 | (when (< 0 (logand events (cffi:foreign-enum-value 'uv:uv-poll-event :readable))) 34 | (push :readable events-named)) 35 | (when (< 0 (logand events (cffi:foreign-enum-value 'uv:uv-poll-event :writable))) 36 | (push :writable events-named)) 37 | (funcall poll-cb events-named)))))) 38 | 39 | (defun poll (fd poll-cb &key event-cb (poll-for '(:readable :writable)) socket) 40 | "Poll an OS FD. If the FD is a socket, :socket t must be passed." 41 | (check-event-loop-running) 42 | (let* ((poll-c (uv:alloc-handle :poll)) 43 | (poller (make-instance 'poller :c poll-c)) 44 | (fn (if socket 45 | 'uv:uv-poll-init-socket 46 | 'uv:uv-poll-init))) 47 | (funcall fn (event-base-c *event-base*) poll-c fd) 48 | (let ((events 0)) 49 | (dolist (event poll-for) 50 | (let ((event-val (case event 51 | (:readable (cffi:foreign-enum-value 'uv:uv-poll-event :readable)) 52 | (:writable (cffi:foreign-enum-value 'uv:uv-poll-event :writable))))) 53 | (setf events (logior events event-val)))) 54 | (save-callbacks poll-c (list :poll-cb poll-cb 55 | :event-cb event-cb)) 56 | (uv:uv-poll-start poll-c events (cffi:callback poll-cb))) 57 | poller)) 58 | 59 | -------------------------------------------------------------------------------- /src/process.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async) 2 | 3 | ;; TBD: separate tcp-stream from async-stream. 4 | ;; Also, need to rename (?) socket in tcp.lisp 5 | ;; TBD: support inheritance of custom fds 6 | ;; TBD: utf-8 pipe support 7 | ;; TBD: check process handles during walk using generic function 8 | ;; TBD: custom process name 9 | ;; TBD: custom string encoding 10 | ;; TBD: process flags (detached etc.) 11 | 12 | ;; TBD: use common superclass for libuv handle wrappers 13 | 14 | (defclass process () 15 | ((c :accessor process-c :initarg :c) 16 | (input :accessor process-input :initarg :input) 17 | (output :accessor process-output :initarg :output) 18 | (error-output :accessor process-error-output :initarg :error-output))) 19 | 20 | (defmethod initialize-instance :after ((process process) &key exit-cb event-cb &allow-other-keys) 21 | (attach-data-to-pointer (process-c process) process) 22 | (save-callbacks (process-c process) 23 | (list :exit-cb exit-cb :event-cb event-cb))) 24 | 25 | (define-c-callback process-close-cb :void ((process-handle :pointer)) 26 | "Called when a process closes." 27 | ;; FIXME: same as streamish-close-cb 28 | (free-pointer-data process-handle :preserve-pointer t) 29 | (uv:free-handle process-handle)) 30 | 31 | (defun process-close (process-handle) 32 | (uv:uv-close process-handle (cffi:callback process-close-cb))) 33 | 34 | (define-c-callback process-exit-cb :void ((process-handle :pointer) 35 | (exit-status :int64) 36 | (term-signal :int)) 37 | (let* ((process (deref-data-from-pointer process-handle)) 38 | (callbacks (get-callbacks process-handle)) 39 | (event-cb (getf callbacks :event-cb)) 40 | (exit-cb (getf callbacks :exit-cb))) 41 | (catch-app-errors event-cb 42 | (when exit-cb 43 | (funcall exit-cb process exit-status term-signal)) 44 | (process-close process-handle) 45 | (setf (process-c process) nil)))) 46 | 47 | (defun init-stdio-container (container out-p type fd pipe-args) 48 | (setf (uv-a:uv-stdio-container-t-flags container) 49 | (flet ((v (name) 50 | (cffi:foreign-enum-value 'uv:uv-stdio-flags name))) 51 | (ecase type 52 | (:ignore (v :ignore)) 53 | (:inherit (v :inherit-fd)) 54 | ((:pipe :stream) 55 | (logior (v :create-pipe) 56 | (if out-p 57 | (v :writable-pipe) 58 | (v :readable-pipe))))))) 59 | (case type 60 | (:inherit 61 | (setf (cffi:foreign-slot-value 62 | (cffi:foreign-slot-pointer container '(:struct uv:uv-stdio-container-t) 'uv::data) 63 | '(:union uv:uv-stdio-container-s-data) 64 | 'uv::fd) 65 | fd) 66 | nil) 67 | ((:stream :pipe) 68 | (let ((pipe-or-stream (apply #'init-client-socket 'pipe 69 | :stream (eq :stream type) 70 | :allow-other-keys t pipe-args))) 71 | (setf (uv-a:uv-stdio-container-t-data container) 72 | (streamish-c (streamish pipe-or-stream))) 73 | pipe-or-stream)))) 74 | 75 | (defun spawn (path args &key exit-cb 76 | (event-cb #'error) 77 | (input :ignore) 78 | (output :ignore) 79 | (error-output :ignore) 80 | env 81 | working-directory) 82 | "Run the program specified by PATH with specified ARGS. 83 | ARGS don't include the executable path (argv[0]). Return process 84 | object and pipes or streams for input, output and error output file 85 | descriptors of the child process (NIL for file descriptors that 86 | aren't redirected via :PIPE or :STREAM, see below). 87 | 88 | EXIT-CB specifies the callback that should be called when the 89 | program terminates. It should be a function taking three arguments: 90 | process object, exit status and signal number that caused program 91 | termination (0 if the program wasn't terminated by signal). 92 | 93 | EVENT-CB specifies error handler to be used. 94 | 95 | INPUT, OUTPUT and ERROR-OUTPUT specify process input/output/error 96 | redirection. For each of these, the following values are 97 | supported: 98 | 99 | :IGNORE the corresponding file descriptor isn't used 100 | :INHERIT inherit file descriptor from this process 101 | (:PIPE [:READ-CB ...] ...) use pipe-based redirection of the 102 | corresponding file descriptor (see PIPE-CONNECT for the set 103 | of supported keyword arguments). 104 | (:STREAM [:READ-CB ...] ...) same as PIPE, but uses async 105 | stream instead of a pipe. 106 | 107 | ENV is an alist of (VAR . VALUE) pairs specifying the environment variables 108 | of the spawned process. Note that both VAR and VALUE must be strings. 109 | 110 | WORKING-DIRECTORY specifies the current working directory of the spawned 111 | program. Defaults to the current working directory of its parent process 112 | (viz. the process SPAWN is called from)." 113 | (check-event-loop-running) 114 | (let ((handle (uv:alloc-handle :process))) 115 | (cffi:with-foreign-objects ((stdio '(:struct uv:uv-stdio-container-t) 3) 116 | (c-args :pointer (+ 2 (length args)))) 117 | (cffi:with-foreign-strings ((file (namestring path))) 118 | (let ((stdios 119 | (loop for fd from 0 below 3 120 | for (type . other-args) in (mapcar #'alexandria:ensure-list 121 | (list input output error-output)) 122 | for out-p = nil then t 123 | collect (init-stdio-container 124 | (cffi:mem-aptr stdio '(:struct uv:uv-stdio-container-t) fd) 125 | out-p type fd other-args))) 126 | (c-env (cffi:null-pointer)) 127 | (cwd (cffi:null-pointer))) 128 | (setf (cffi:mem-aref c-args :pointer) file 129 | (cffi:mem-aref c-args :pointer (1+ (length args))) (cffi:null-pointer)) 130 | (loop for i from 1 131 | for arg in args 132 | do (setf (cffi:mem-aref c-args :pointer i) 133 | (cffi:foreign-string-alloc arg))) 134 | (when env 135 | (setf c-env (cffi:foreign-alloc :pointer :count (length env) :null-terminated-p t)) 136 | (loop for i from 0 137 | for (var . value) in env 138 | do (setf (cffi:mem-aref c-env :pointer i) 139 | (cffi:foreign-string-alloc (concatenate 'string var "=" value))))) 140 | (when working-directory 141 | (setf cwd (cffi:foreign-string-alloc (namestring (truename working-directory))))) 142 | (with-foreign-object* (options uv:uv-process-options-t) 143 | ((uv-a:uv-process-options-t-exit-cb (cffi:callback process-exit-cb)) 144 | (uv-a:uv-process-options-t-file file) 145 | (uv-a:uv-process-options-t-args c-args) 146 | (uv-a:uv-process-options-t-env c-env) 147 | (uv-a:uv-process-options-t-cwd cwd) 148 | #++ 149 | (uv-a:uv-process-options-t-flags 0) 150 | (uv-a:uv-process-options-t-stdio-count 3) 151 | (uv-a:uv-process-options-t-stdio stdio) 152 | #++ 153 | (uv-a:uv-process-options-t-uid 0) 154 | #++ 155 | (uv-a:uv-process-options-t-gid 0)) 156 | (let ((res (uv:uv-spawn (event-base-c *event-base*) handle options))) 157 | (cond ((zerop res) 158 | (loop for i from 1 upto (length args) 159 | do (cffi:foreign-string-free (cffi:mem-aref c-args :pointer i))) 160 | (when env 161 | (loop for i from 0 to (1- (length env)) 162 | do (cffi:foreign-string-free (cffi:mem-aref c-env :pointer i))) 163 | (cffi:foreign-free c-env)) 164 | (when working-directory 165 | (cffi:foreign-string-free cwd)) 166 | (loop for pipe-or-stream in stdios 167 | for in-p = t then nil 168 | when pipe-or-stream 169 | do (let ((pipe (streamish pipe-or-stream))) 170 | (when (or in-p (streamish-read-start pipe)) 171 | (setf (socket-connected (streamish pipe)) t)))) 172 | (apply #'values 173 | (make-instance 'process 174 | :c handle 175 | :exit-cb exit-cb 176 | :event-cb event-cb 177 | :input (first stdios) 178 | :output (second stdios) 179 | :error-output (third stdios)) 180 | stdios)) 181 | (t 182 | ;; destroying the handle immediately causes assertion failure 183 | ;; (FIXME: why? seems like it shouldn't be so, looking 184 | ;; at libuv tests) 185 | (as:with-delay () 186 | (process-close handle)) 187 | (event-handler res event-cb :throw t)))))))))) 188 | 189 | (defmethod handle-cleanup ((handle-type (eql :process)) handle) 190 | (let ((process (deref-data-from-pointer handle))) 191 | (process-close handle) 192 | (when process 193 | (setf (process-c process) nil)))) 194 | 195 | (defun process-kill (process signal &key (event-cb #'error)) 196 | "If PROCESS is active, send the specified signal (an integer) to it and return true. 197 | If PROCESS is not active or an error occurs (and EVENT-CB doesn't 198 | signal an error), return false. If EVENT-CB is specified, use it 199 | to handle errors, otherwise signal them via ERROR." 200 | (alexandria:when-let ((handle (process-c process))) 201 | (let ((res (uv:uv-process-kill handle signal))) 202 | (cond ((zerop res) t) 203 | (t 204 | (event-handler res event-cb :throw t) 205 | nil))))) 206 | -------------------------------------------------------------------------------- /src/repl.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-async-repl 2 | (:use :cl) 3 | (:nicknames :as-repl) 4 | (:export #:event-thread-running-p 5 | #:start-async-repl 6 | #:ensure-async-repl 7 | #:stop-async-repl)) 8 | 9 | (in-package :cl-async-repl) 10 | 11 | (defparameter *globals* 12 | '(*debug-io* *query-io* *terminal-io* *standard-output* 13 | *standard-input* *error-output* *trace-output* 14 | *print-array* *print-base* *print-radix* 15 | *print-case* *print-circle* *print-escape* 16 | *print-gensym* *print-level* *print-length* 17 | *print-lines* *print-miser-width* *print-pretty* 18 | *print-readably* *print-right-margin* 19 | *package*) 20 | "Special variables whose values are copied to the event thread.") 21 | 22 | (defvar *event-thread* nil 23 | "Current event thread, or NIL if event thread isn't running.") 24 | (defvar *notifier* nil 25 | "Notifier object that is used to execute actions in the event thread") 26 | (defvar *lock* (bt:make-lock) 27 | "Action queue mutex.") 28 | (defvar *pending-actions* '() 29 | "The list of pending actions to be executed inside the event thread.") 30 | (defvar *sync-action-done* (bt:make-condition-variable) 31 | "Condition variable used for synchronous actions in the event thread.") 32 | (defvar *sync-action-lock* (bt:make-lock) 33 | "Mutex used synchronous actions in the event thread.") 34 | 35 | (defun wrap-action (action) 36 | "Wrap ACTION (a function) by establishing ABORT-CALLBACK and EXIT-EVENT-LOOP restarts." 37 | #'(lambda () 38 | (cl-async-util:call-with-callback-restarts 39 | action 40 | :abort-restart-description "Abort the current action."))) 41 | 42 | (defun schedule-action (action) 43 | "Asynchronously schedule the action to be executed in the 44 | event thread. ACTION should be a function." 45 | (bt:with-lock-held (*lock*) 46 | (assert *event-thread* () "event thread not started") 47 | (setf *pending-actions* 48 | (nconc *pending-actions* (list action)))) 49 | (as:trigger-notifier *notifier*) 50 | (values)) 51 | 52 | (defun stop-event-thread () 53 | "Terminate event thread" 54 | (schedule-action #'as:exit-event-loop) 55 | (values)) 56 | 57 | (defun start-event-thread (&key exit-callback on-startup) 58 | "Start event thread. ON-STARTUP is called in the event loop thread 59 | after it's started. EXIT-CALLBACK is called upon the event loop 60 | termination." 61 | (assert (not *event-thread*) () "event thread already started") 62 | (let ((global-values (mapcar #'symbol-value *globals*)) 63 | (loop-ready-lock (bt:make-lock)) 64 | (loop-ready (bt:make-condition-variable))) 65 | (setf *event-thread* 66 | (bt:make-thread 67 | #'(lambda () 68 | (loop for var in *globals* 69 | for value in global-values 70 | do (setf (symbol-value var) value)) 71 | (unwind-protect 72 | (as:with-event-loop () 73 | (as:add-event-loop-exit-callback 74 | (lambda () 75 | (when exit-callback 76 | (funcall exit-callback)) 77 | (bt:with-lock-held (*lock*) 78 | (unless (as:notifier-freed-p *notifier*) 79 | (as:free-notifier *notifier*)) 80 | (setf *event-thread* nil 81 | *notifier* nil 82 | *pending-actions* '())))) 83 | (format *debug-io* "~&;; event thread started.~%") 84 | (bt:with-lock-held (loop-ready-lock) 85 | (setf *notifier* (as:make-notifier 86 | #'(lambda () 87 | (let ((actions 88 | (bt:with-lock-held (*lock*) 89 | (shiftf *pending-actions* '())))) 90 | (mapc #'funcall actions))) 91 | :single-shot nil)) 92 | (bt:condition-notify loop-ready)) 93 | (when on-startup 94 | (funcall on-startup))) 95 | (format *debug-io* "~&;; event thread exited.~%"))) 96 | :name "event-thread")) 97 | (bt:with-lock-held (loop-ready-lock) 98 | (loop until *notifier* 99 | do (bt:condition-wait loop-ready loop-ready-lock)))) 100 | (values)) 101 | 102 | (defun sync-action (action) 103 | "Perform an action synchronously in the event thread, returning 104 | its result. ACTION should be a function; multiple return values 105 | are supported." 106 | (let ((result nil) 107 | (done-p nil)) 108 | (setf action (wrap-action action)) 109 | (schedule-action 110 | #'(lambda () 111 | (setf result (multiple-value-list (funcall action))) 112 | (bt:with-lock-held (*sync-action-lock*) 113 | (setf done-p t) 114 | (bt:condition-notify *sync-action-done*)))) 115 | (bt:with-lock-held (*sync-action-lock*) 116 | (loop until done-p 117 | do (bt:condition-wait *sync-action-done* *sync-action-lock*))) 118 | (apply #'values result))) 119 | 120 | (defun sync-eval (form) 121 | "Evaluate the form synchronously in the event thread, returning 122 | its result." 123 | (let ((package *package*)) 124 | (multiple-value-prog1 125 | (sync-action #'(lambda () 126 | (unwind-protect 127 | (eval form) 128 | (setf package *package*)))) 129 | (setf *package* package)))) 130 | 131 | (defun repl-hook-sym () 132 | (assert (find-package "SWANK") () "SWANK package not found") 133 | (or (find-symbol "*SLIME-REPL-EVAL-HOOKS*" "SWANK") () 134 | (error "Cannot initialize *SLIME-REPL-EVAL-HOOKS*, ~ 135 | use (eval-in-gui-thread ...) form."))) 136 | 137 | (defun install-repl-hook (func) 138 | "Install FUNC as SLIME REPL hook." 139 | (pushnew func (symbol-value (repl-hook-sym)))) 140 | 141 | (defun uninstall-repl-hook (func) 142 | "Remove FUNC from the list of SLIME REPL hooks." 143 | (setf (symbol-value (repl-hook-sym)) 144 | (delete func (symbol-value (repl-hook-sym))))) 145 | 146 | (defun event-thread-running-p () 147 | "Returns true if the event thread used by async REPL is running" 148 | (bt:with-lock-held (*lock*) 149 | (when *event-thread* t))) 150 | 151 | (defun start-async-repl (&optional on-startup) 152 | "Start event thread and install SLIME REPL hook so that everything is 153 | evaluated in that thread. Stopping the event loop via (as:stop-event-thread) 154 | removes the hook. 155 | If ON-STARTUP function is specified, it's executed in the event loop 156 | thread after it's started. 157 | 158 | Sets *safe-sldb-quit-restart* to true." 159 | (start-event-thread :on-startup on-startup 160 | :exit-callback #'(lambda () (uninstall-repl-hook 'sync-eval))) 161 | (install-repl-hook 'sync-eval) 162 | (setf cl-async-base:*safe-sldb-quit-restart* t) 163 | (values)) 164 | 165 | (defun ensure-async-repl (&optional on-startup) 166 | "If event loop is not started, calls START-ASYNC-REPL 167 | passing ON-STARTUP to it. If it's already started, 168 | calls ON-STARTUP if it's not null." 169 | (cond ((not (event-thread-running-p)) 170 | (start-async-repl on-startup)) 171 | (on-startup 172 | (funcall on-startup)))) 173 | 174 | (defun stop-async-repl () 175 | "Stop event thread and uninstall SLIME REPL hook. 176 | Sets *safe-sldb-quit-restart* to false." 177 | (stop-event-thread) 178 | (setf cl-async-base:*safe-sldb-quit-restart* nil)) 179 | -------------------------------------------------------------------------------- /src/signal.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async) 2 | 3 | (defconstant +sighup+ 1) 4 | (defconstant +sigint+ 2) 5 | (defconstant +sigquit+ 3) 6 | (defconstant +sigill+ 4) 7 | (defconstant +sigtrap+ 5) 8 | (defconstant +sigabrt+ 6) 9 | (defconstant +sigemt+ 7) 10 | (defconstant +sigfpe+ 8) 11 | (defconstant +sigkill+ 9) 12 | (defconstant +sigbus+ 10) 13 | (defconstant +sigsegv+ 11) 14 | (defconstant +sigsys+ 12) 15 | (defconstant +sigpipe+ 13) 16 | (defconstant +sigalrm+ 14) 17 | (defconstant +sigterm+ 15) 18 | (defconstant +sigurg+ 16) 19 | (defconstant +sigstop+ 17) 20 | (defconstant +sigtstp+ 18) 21 | (defconstant +sigcont+ 19) 22 | (defconstant +sigchld+ 20) 23 | (defconstant +sigttin+ 21) 24 | (defconstant +sigttou+ 22) 25 | (defconstant +sigio+ 23) 26 | (defconstant +sigxcpu+ 24) 27 | (defconstant +sigxfsz+ 25) 28 | (defconstant +sigvtalrm+ 26) 29 | (defconstant +sigprof+ 27) 30 | (defconstant +sigwinch+ 28) 31 | (defconstant +siginfo+ 29) 32 | (defconstant +sigusr1+ 30) 33 | (defconstant +sigusr2+ 31) 34 | 35 | (defun signal-pointer (signo) 36 | "Creates a pointer from a signal number. Not that this doesn't need to be 37 | freed since we're not allocating anything...just creating a pointer object 38 | with a specific address (which can be GCed)." 39 | (cffi:make-pointer signo)) 40 | 41 | (defun free-signal-handler (signo) 42 | "Clear a signal handler and unbind it." 43 | (when (find signo (event-base-signal-handlers *event-base*)) 44 | (let* ((signo-pt (signal-pointer signo)) 45 | (watcher (deref-data-from-pointer signo-pt))) 46 | (uv:uv-signal-stop watcher) 47 | (uv:uv-close watcher (cffi:callback signal-close-cb))) 48 | (setf (event-base-signal-handlers *event-base*) (remove signo (event-base-signal-handlers *event-base*))))) 49 | 50 | (defun clear-signal-handlers () 51 | "Clear all bound signal handlers. Great for cleaning up when exiting an app." 52 | (dolist (signo (copy-list (event-base-signal-handlers *event-base*))) 53 | (free-signal-handler signo)) 54 | (setf (event-base-signal-handlers *event-base*) nil)) 55 | 56 | (define-c-callback signal-close-cb :void ((watcher :pointer)) 57 | "Called when a signal handler closes." 58 | (let* ((sig-data (deref-data-from-pointer watcher)) 59 | (signo (getf sig-data :signo)) 60 | (signo-pt (signal-pointer signo)) 61 | (original-lisp-signal-handler (getf sig-data :original-handler))) 62 | (free-pointer-data watcher :preserve-pointer t) 63 | (uv:free-handle watcher) 64 | (cffi:foreign-funcall "signal" :int signo :pointer original-lisp-signal-handler :pointer) 65 | (free-pointer-data signo-pt :preserve-pointer t))) 66 | 67 | (define-c-callback signal-cb :void ((watcher :pointer) (signo :int)) 68 | "All signals come through here." 69 | (let* ((callbacks (get-callbacks watcher)) 70 | (signal-cb (getf callbacks :signal-cb)) 71 | (event-cb (getf callbacks :event-cb))) 72 | (catch-app-errors event-cb 73 | (funcall signal-cb signo)))) 74 | 75 | (define-c-callback lisp-signal-cb :void ((signo :int)) 76 | "Generic callback for lisp signal handling." 77 | (declare (optimize (speed 3))) 78 | ;; grab the callback from set-lisp-signal-handler 79 | (let* ((signo-pt (signal-pointer signo)) 80 | (callback (car (get-callbacks signo-pt)))) 81 | (when (functionp callback) 82 | ;; trigger the callback to run async 83 | (as:delay callback)))) 84 | 85 | (defun set-lisp-signal-handler (signo fn) 86 | "Replace the current handler for the signal number under signo, and return a 87 | pointer to the handler that is being replaced." 88 | (save-callbacks (signal-pointer signo) (list fn)) 89 | (cffi:foreign-funcall "signal" :int signo :pointer (cffi:callback lisp-signal-cb) :pointer)) 90 | 91 | (defun signal-handler (signo signal-cb &key event-cb) 92 | "Setup a one-time signal handler for the given signo. This also sets up a 93 | lisp signal handler, so if a signal comes through while lisp is running 94 | instead of the event loop, it will run the same callback. All signal handlers 95 | are restored on event loop exit." 96 | (check-event-loop-running) 97 | ;; un-bind this signal handler if it is already bound. this ensures we don't 98 | ;; lose the original lisp signal handler when we overwrite it. 99 | (free-signal-handler signo) 100 | (let* ((watcher (uv:alloc-handle :signal)) 101 | (lisp-signal-handler (set-lisp-signal-handler signo (lambda () (signal-cb watcher signo)))) 102 | (signo-pt (signal-pointer signo))) 103 | (let ((res (uv:uv-signal-init (event-base-c *event-base*) watcher))) 104 | (unless (zerop res) 105 | (uv:free-handle watcher) 106 | (event-handler res event-cb :throw t) 107 | (return-from signal-handler))) 108 | (let ((res (uv:uv-signal-start watcher (cffi:callback signal-cb) signo))) 109 | (unless (zerop res) 110 | (uv:free-handle watcher) 111 | (event-handler res event-cb :throw t) 112 | (return-from signal-handler))) 113 | (save-callbacks watcher (list :signal-cb signal-cb 114 | :event-cb event-cb)) 115 | (attach-data-to-pointer watcher (list :signo signo :original-handler lisp-signal-handler)) 116 | ;; make sure we can find the event/original handler from just the signo 117 | (attach-data-to-pointer signo-pt watcher) 118 | ;; add this signal to the list of active signals 119 | (push signo (event-base-signal-handlers *event-base*)) 120 | (add-event-loop-exit-callback (lambda () (free-signal-handler signo))))) 121 | 122 | -------------------------------------------------------------------------------- /src/ssl/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-async-ssl 2 | (:use :cl :cl-async-base :cl-async :cl-async-util) 3 | (:nicknames :as-ssl) 4 | (:shadow cl-async-util:exit-event-loop) 5 | (:export #:+ssl-op-all+ 6 | #:+ssl-op-no-query-mtu+ 7 | #:+ssl-op-cookie-exchange+ 8 | #:+ssl-op-no-ticket+ 9 | #:+ssl-op-cisco-anyconnect+ 10 | #:+ssl-op-no-session-resumption-on-renegotiation+ 11 | #:+ssl-op-no-compression+ 12 | #:+ssl-op-allow-unsafe-legacy-renegotiation+ 13 | #:+ssl-op-single-ecdh-use+ 14 | #:+ssl-op-single-dh-use+ 15 | #:+ssl-op-ephemeral-rsa+ 16 | #:+ssl-op-cipher-server-preference+ 17 | #:+ssl-op-tls-rollback-bug+ 18 | #:+ssl-op-no-sslv2+ 19 | #:+ssl-op-no-sslv3+ 20 | #:+ssl-op-no-tlsv1+ 21 | #:+ssl-op-no-tlsv1-2+ 22 | #:+ssl-op-no-tlsv1-1+ 23 | 24 | #:+ssl-verify-none+ 25 | #:+ssl-verify-peer+ 26 | #:+ssl-verify-fail-if-no-peer-cert+ 27 | #:+ssl-verify-client-once+ 28 | 29 | #:ssl-socket 30 | #:tcp-ssl-error 31 | #:tcp-ssl-connect 32 | #:tcp-ssl-server) 33 | (:import-from :cl-async 34 | #:*output-buffer* 35 | #:*input-buffer* 36 | #:event-handler 37 | #:socket-connected 38 | #:socket-buffer 39 | #:socket-buffering-p 40 | #:socket-direction 41 | #:check-socket-open 42 | #:check-event-loop-running 43 | #:socket-drain-read-buffer 44 | #:write-to-uvstream 45 | #:write-socket-data 46 | #:write-pending-socket-data 47 | #:init-incoming-socket 48 | #:stream-append-bytes)) 49 | (in-package :cl-async-ssl) 50 | 51 | ;; NOTE: the loading code is verbatim from cl+ssl 52 | 53 | (eval-when (:compile-toplevel :load-toplevel) 54 | (cffi:define-foreign-library libcrypto 55 | (:openbsd "libcrypto.so") 56 | (:linux (:or "libcrypto.so.1.1" 57 | "libcrypto.so.1.0.2" 58 | "libcrypto.so")) 59 | (:windows (:or #+(and windows x86-64) "libcrypto-3-x64.dll" 60 | #+(and windows x86) "libcrypto-3.dll" 61 | #+(and windows x86-64) "libcrypto-1_1-x64.dll" 62 | #+(and windows x86) "libcrypto-1_1.dll" 63 | "libeay32.dll")) 64 | (:darwin (:or "/opt/local/lib/libcrypto.dylib" ;; MacPorts 65 | "/sw/lib/libcrypto.dylib" ;; Fink 66 | "/usr/local/opt/openssl/lib/libcrypto.dylib" ;; Homebrew 67 | "/opt/homebrew/opt/openssl/lib/libcrypto.dylib" ;; Homebrew Arm64 68 | "/usr/local/lib/libcrypto.dylib" ;; personalized install 69 | ;; System-provided libraries. Must be loaded from files with 70 | ;; names that include version explicitly, instead of any 71 | ;; versionless symlink file. Otherwise macOS crushes the 72 | ;; process (starting from macOS > 10.15 that was just a 73 | ;; warning, and finally macOS >= 11 crashes the process with a 74 | ;; fatal error) Please note that in macOS >= 11.0, these paths 75 | ;; may not exist in the file system anymore, but trying to 76 | ;; load them via dlopen will work. This is because macOS ships 77 | ;; all system-provided libraries as a single dyld_shared_cache 78 | ;; bundle. 79 | "/usr/lib/libcrypto.46.dylib" 80 | "/usr/lib/libcrypto.44.dylib" 81 | "/usr/lib/libcrypto.42.dylib" 82 | "/usr/lib/libcrypto.41.dylib" 83 | "/usr/lib/libcrypto.35.dylib" 84 | 85 | ;; The default old system libcrypto, versionless file name, 86 | ;; which may have insufficient crypto and can cause process 87 | ;; crash on macOS >= 11. Currently we are protected from the 88 | ;; crash by the presence of the versioned paths above, but in 89 | ;; a few years, when those versions are not available anymore, 90 | ;; the crash may re-appear. So eventually we will need to 91 | ;; delete the unversioned paths. Keeping them for a while for 92 | ;; compatibility. See 93 | ;; https://github.com/cl-plus-ssl/cl-plus-ssl/pull/115 94 | "libcrypto.dylib" 95 | "/usr/lib/libcrypto.dylib")) 96 | ((and :unix (not :cygwin)) (:or "libcrypto.so.1.1" 97 | "libcrypto.so.1.0.0" 98 | "libcrypto.so.3" 99 | "libcrypto.so")) 100 | (:cygwin (:or "cygcrypto-1.1.dll" "cygcrypto-1.0.0.dll"))) 101 | (cffi:use-foreign-library libcrypto) 102 | 103 | (cffi:define-foreign-library libssl 104 | (:windows (:or #+(and windows x86-64) "libssl-3-x64.dll" 105 | #+(and windows x86) "libssl-3.dll" 106 | #+(and windows x86-64) "libssl-1_1-x64.dll" 107 | #+(and windows x86) "libssl-1_1.dll" 108 | "libssl32.dll" 109 | "ssleay32.dll")) 110 | ;; The default OS-X libssl seems have had insufficient crypto algos 111 | ;; (missing TLSv1_[1,2]_XXX methods, 112 | ;; see https://github.com/cl-plus-ssl/cl-plus-ssl/issues/56) 113 | ;; so first try to load possible custom installations of libssl 114 | (:darwin (:or "/opt/local/lib/libssl.dylib" ;; MacPorts 115 | "/sw/lib/libssl.dylib" ;; Fink 116 | "/usr/local/opt/openssl/lib/libssl.dylib" ;; Homebrew 117 | "/opt/homebrew/opt/openssl/lib/libssl.dylib" ;; Homebrew Arm64 118 | "/usr/local/lib/libssl.dylib" ;; personalized install 119 | ;; System-provided libraries, with version in the file name. 120 | ;; See the comment for the libcryto equivalents above. 121 | "/usr/lib/libssl.48.dylib" 122 | "/usr/lib/libssl.46.dylib" 123 | "/usr/lib/libssl.44.dylib" 124 | "/usr/lib/libssl.43.dylib" 125 | "/usr/lib/libssl.35.dylib" 126 | ;; Default system libssl, versionless file name. 127 | ;; See the coment for the corresponding libcrypto. 128 | ;; default system libssl, which may have insufficient crypto 129 | "libssl.dylib" 130 | "/usr/lib/libssl.dylib")) 131 | (:solaris (:or "/lib/64/libssl.so" 132 | "libssl.so.0.9.8" "libssl.so" "libssl.so.4")) 133 | ;; Unlike some other systems, OpenBSD linker, 134 | ;; when passed library name without versions at the end, 135 | ;; will locate the library with highest macro.minor version, 136 | ;; so we can just use just "libssl.so". 137 | ;; More info at https://github.com/cl-plus-ssl/cl-plus-ssl/pull/2. 138 | (:openbsd "libssl.so") 139 | ((and :unix (not :cygwin)) (:or "libssl.so.1.1" 140 | "libssl.so.1.0.2m" 141 | "libssl.so.1.0.2k" 142 | "libssl.so.1.0.2" 143 | "libssl.so.1.0.1l" 144 | "libssl.so.1.0.1j" 145 | "libssl.so.1.0.1f" 146 | "libssl.so.1.0.1e" 147 | "libssl.so.1.0.1" 148 | "libssl.so.1.0.0q" 149 | "libssl.so.1.0.0" 150 | "libssl.so.0.9.8ze" 151 | "libssl.so.0.9.8" 152 | "libssl.so.10" 153 | "libssl.so.4" 154 | "libssl.so")) 155 | (:cygwin (:or "cygssl-1.1.dll" "cygssl-1.0.0.dll")) 156 | (t (:default "libssl3"))) 157 | 158 | (cffi:use-foreign-library libssl) 159 | 160 | (when (cffi:foreign-symbol-pointer "TLS_method") 161 | (pushnew ':tls-method *features*))) 162 | -------------------------------------------------------------------------------- /src/ssl/util.lisp: -------------------------------------------------------------------------------- 1 | ;;; this file is sort of our makeshift openssl bindings. i'd generate them as i 2 | ;;; usually do via swig, but kind of don't care to because we're only going to 3 | ;;; use a fraction of the exported functionality. 4 | 5 | (in-package :cl-async-ssl) 6 | 7 | (defun zero-buffer (buff) 8 | "Zero out a buffer. Not 100% perfect because of the GC, but better than 9 | letting stale plaintext data sit around." 10 | (dotimes (i (length buff)) 11 | (setf (aref buff i) 0))) 12 | 13 | (defconstant +ssl-error-none+ 0) 14 | (defconstant +ssl-error-ssl+ 1) 15 | (defconstant +ssl-error-want-read+ 2) 16 | (defconstant +ssl-error-want-write+ 3) 17 | (defconstant +ssl-error-want-x509-lookup+ 4) 18 | (defconstant +ssl-error-syscall+ 5) 19 | (defconstant +ssl-error-zero-return+ 6) 20 | (defconstant +ssl-error-want-connect+ 7) 21 | (defconstant +ssl-error-want-accept+ 8) 22 | 23 | (defconstant +ssl-st-connect+ #x1000) 24 | (defconstant +ssl-st-accept+ #x2000) 25 | (defconstant +ssl-st-mask+ #x0FFF) 26 | (defconstant +ssl-st-init+ (logior +ssl-st-connect+ +ssl-st-accept+)) 27 | (defconstant +ssl-st-before+ #x4000) 28 | (defconstant +ssl-st-ok+ #x03) 29 | (defconstant +ssl-st-renegotiate+ (logior #x04 +ssl-st-init+)) 30 | 31 | (defconstant +ssl-cb-loop+ #x01) 32 | (defconstant +ssl-cb-exit+ #x02) 33 | (defconstant +ssl-cb-read+ #x04) 34 | (defconstant +ssl-cb-write+ #x08) 35 | (defconstant +ssl-cb-alert+ #x4000) 36 | (defconstant +ssl-cb-read-alert+ (logior +ssl-cb-alert+ +ssl-cb-read+)) 37 | (defconstant +ssl-cb-write-alert+ (logior +ssl-cb-alert+ +ssl-cb-write+)) 38 | (defconstant +ssl-cb-accept-loop+ (logior +ssl-st-accept+ +ssl-cb-loop+)) 39 | (defconstant +ssl-cb-accept-exit+ (logior +ssl-st-accept+ +ssl-cb-exit+)) 40 | (defconstant +ssl-cb-connect-loop+ (logior +ssl-st-connect+ +ssl-cb-loop+)) 41 | (defconstant +ssl-cb-connect-exit+ (logior +ssl-st-connect+ +ssl-cb-exit+)) 42 | (defconstant +ssl-cb-handshake-start+ #x10) 43 | (defconstant +ssl-cb-handshake-done+ #x20) 44 | (defconstant +ssl-received-shutdown+ 2) 45 | 46 | (defconstant +ssl-verify-none+ #x00) 47 | (defconstant +ssl-verify-peer+ #x01) 48 | (defconstant +ssl-verify-fail-if-no-peer-cert+ #x02) 49 | (defconstant +ssl-verify-client-once+ #x04) 50 | 51 | (defconstant +ssl-filetype-asn1+ 2) 52 | (defconstant +ssl-filetype-pem+ 1) 53 | (defconstant +ssl-x509-filetype-default+ 3) 54 | 55 | (defconstant +ssl-op-all+ #x80000BFF) 56 | ;; DTLS options 57 | (defconstant +ssl-op-no-query-mtu+ #x00001000) 58 | ;; Turn on Cookie Exchange (on relevant for servers) 59 | (defconstant +ssl-op-cookie-exchange+ #x00002000) 60 | ;; Don't use RFC4507 ticket extension 61 | (defconstant +ssl-op-no-ticket+ #x00004000) 62 | ;; Use Cisco's "speshul" version of DTLS_BAD_VER (as client) 63 | (defconstant +ssl-op-cisco-anyconnect+ #x00008000) 64 | ;; As server, disallow session resumption on renegotiation 65 | (defconstant +ssl-op-no-session-resumption-on-renegotiation+ #x00010000) 66 | ;; Don't use compression even if supported 67 | (defconstant +ssl-op-no-compression+ #x00020000) 68 | ;; Permit unsafe legacy renegotiation 69 | (defconstant +ssl-op-allow-unsafe-legacy-renegotiation+ #x00040000) 70 | ;; If set, always create a new key when using tmp_ecdh parameters 71 | (defconstant +ssl-op-single-ecdh-use+ #x00080000) 72 | ;; If set, always create a new key when using tmp_dh parameters 73 | (defconstant +ssl-op-single-dh-use+ #x00100000) 74 | ;; Set to always use the tmp_rsa key when doing RSA operations, 75 | ;; even when this violates protocol specs 76 | (defconstant +ssl-op-ephemeral-rsa+ #x00200000) 77 | ;; Set on servers to choose the cipher according to the server's 78 | ;; preferences 79 | (defconstant +ssl-op-cipher-server-preference+ #x00400000) 80 | ;; If set, a server will allow a client to issue a SSLv3.0 version number 81 | ;; as latest version supported in the premaster secret, even when TLSv1.0 82 | ;; (version 3.1) was announced in the client hello. Normally this is 83 | ;; forbidden to prevent version rollback attacks. 84 | (defconstant +ssl-op-tls-rollback-bug+ #x00800000) 85 | 86 | (defconstant +ssl-op-no-sslv2+ #x01000000) 87 | (defconstant +ssl-op-no-sslv3+ #x02000000) 88 | (defconstant +ssl-op-no-tlsv1+ #x04000000) 89 | (defconstant +ssl-op-no-tlsv1-2+ #x08000000) 90 | (defconstant +ssl-op-no-tlsv1-1+ #x10000000) 91 | 92 | (defconstant +ssl-ctrl-options+ 32) 93 | 94 | #+tls-method (defconstant +tls-st-ok+ 1) 95 | 96 | (defconstant +bio-ctrl-reset+ 1) 97 | (defconstant +bio-ctrl-eof+ 2) 98 | (defconstant +bio-ctrl-info+ 3) 99 | (defconstant +bio-ctrl-set+ 4) 100 | (defconstant +bio-ctrl-get+ 5) 101 | (defconstant +bio-ctrl-push+ 6) 102 | (defconstant +bio-ctrl-pop+ 7) 103 | (defconstant +bio-ctrl-get-close+ 8) 104 | (defconstant +bio-ctrl-set-close+ 9) 105 | (defconstant +bio-ctrl-pending+ 10) 106 | (defconstant +bio-ctrl-flush+ 11) 107 | (defconstant +bio-ctrl-dup+ 12) 108 | (defconstant +bio-ctrl-wpending+ 13) 109 | (defconstant +bio-ctrl-set-callback+ 14) 110 | (defconstant +bio-ctrl-get-callback+ 15) 111 | (defconstant +bio-c-set-buf-mem-eof-return+ 130) 112 | 113 | (cffi:defcfun ("SSL_get_error" ssl-get-error) :int 114 | (ssl :pointer) 115 | (ret :int)) 116 | (cffi:defcfun ("SSL_shutdown" ssl-shutdown) :int 117 | (ssl :pointer)) 118 | (cffi:defcfun ("SSL_CTX_free" ssl-ctx-free) :void 119 | (ctx :pointer)) 120 | (cffi:defcfun ("SSL_free" ssl-free) :void 121 | (ssl :pointer)) 122 | (cffi:defcfun ("ERR_get_error" ssl-err-get-error) :int) 123 | (cffi:defcfun ("ERR_error_string" ssl-err-error-string) :string 124 | (e :unsigned-long) 125 | (buf :pointer)) 126 | (cffi:defcfun ("ERR_reason_error_string" ssl-err-reason-error-string) :string 127 | (errcode :int)) 128 | (cffi:defcfun ("SSL_alert_type_string_long" ssl-alert-type-string-long) :string 129 | (err :int)) 130 | (cffi:defcfun ("SSL_alert_desc_string_long" ssl-alert-desc-string-long) :string 131 | (err :int)) 132 | (cffi:defcfun ("SSL_state_string_long" ssl-state-string-long) :string 133 | (ssl :pointer)) 134 | (cffi:defcfun ("TLSv1_method" ssl-tlsv1-method) :pointer) 135 | (cffi:defcfun ("TLSv1_client_method" ssl-tlsv1-client-method) :pointer) 136 | (cffi:defcfun ("TLSv1_server_method" ssl-tlsv1-server-method) :pointer) 137 | 138 | ;; this is copied virtually verbatim from cl+ssl 139 | (cffi:defcfun ("SSL_ctrl" ssl-ctrl) :long 140 | (ssl :pointer) 141 | (cmd :int) 142 | (larg :long) 143 | (parg :pointer)) 144 | 145 | (defun ssl-set-tlsext-host-name (ctx hostname) 146 | (ssl-ctrl ctx 55 #|SSL_CTRL_SET_TLSEXT_HOSTNAME|# 0 #|TLSEXT_NAMETYPE_host_name|# hostname)) 147 | 148 | #+:tls-method 149 | (progn (cffi:defcfun ("TLS_method" ssl-sslv23-method) :pointer) 150 | (cffi:defcfun ("TLS_client_method" ssl-sslv23-client-method) :pointer) 151 | (cffi:defcfun ("TLS_server_method" ssl-sslv23-server-method) :pointer)) 152 | #-:tls-method 153 | (progn (cffi:defcfun ("SSLv23_method" ssl-sslv23-method) :pointer) 154 | (cffi:defcfun ("SSLv23_client_method" ssl-sslv23-client-method) :pointer) 155 | (cffi:defcfun ("SSLv23_server_method" ssl-sslv23-server-method) :pointer)) 156 | (cffi:defcfun ("SSL_CTX_new" ssl-ctx-new) :pointer 157 | (method :pointer)) 158 | (cffi:defcfun ("SSL_CTX_ctrl" ssl-ctx-ctrl) :long 159 | (ctx :pointer) 160 | (cmd :int) 161 | (larg :unsigned-long) 162 | (parg :pointer)) 163 | (cffi:defcfun ("SSL_CTX_use_certificate_chain_file" ssl-ctx-use-certificate-chain-file) :int 164 | (ctx :pointer) 165 | (file :string)) 166 | (cffi:defcfun ("SSL_CTX_use_PrivateKey_file" ssl-ctx-use-privatekey-file) :int 167 | (ctx :pointer) 168 | (file :string) 169 | (type :int)) 170 | (cffi:defcfun ("SSL_CTX_use_RSAPrivateKey_file" ssl-ctx-use-rsaprivatekey-file) :int 171 | (ctx :pointer) 172 | (file :string) 173 | (type :int)) 174 | (cffi:defcfun ("SSL_CTX_set_default_verify_paths" ssl-ctx-set-default-verify-paths) :int 175 | (ctx :pointer)) 176 | (cffi:defcfun ("SSL_CTX_set_verify" ssl-ctx-set-verify) :int 177 | (ctx :pointer) 178 | (mode :int) 179 | (verify-callback :pointer)) 180 | (cffi:defcfun ("SSL_new" ssl-new) :pointer 181 | (ctx :pointer)) 182 | (cffi:defcfun ("BIO_new" ssl-bio-new) :pointer 183 | (type :pointer)) 184 | (cffi:defcfun ("SSL_set_cipher_list" ssl-set-cipher-list) :int 185 | (ssl :pointer) 186 | (ciphers :string)) 187 | (cffi:defcfun ("SSL_set_bio" ssl-set-bio) :int 188 | (ssl :pointer) 189 | (bio-read :pointer) 190 | (bio-write :pointer)) 191 | (cffi:defcfun ("SSL_set_info_callback" ssl-set-info-callback) :void 192 | (ssl :pointer) 193 | (callback :pointer)) 194 | (cffi:defcfun ("SSL_set_msg_callback" ssl-set-msg-callback) :void 195 | (ssl :pointer) 196 | (callback :pointer)) 197 | (cffi:defcfun ("SSL_state" ssl-state) :int 198 | (ssl :pointer)) 199 | (cffi:defcfun ("SSL_set_accept_state" ssl-set-accept-state) :void 200 | (ssl :pointer)) 201 | (cffi:defcfun ("SSL_set_connect_state" ssl-set-connect-state) :void 202 | (ssl :pointer)) 203 | (cffi:defcfun ("SSL_connect" ssl-connect) :int 204 | (ssl :pointer)) 205 | (cffi:defcfun ("SSL_accept" ssl-accept) :int 206 | (ssl :pointer)) 207 | (cffi:defcfun ("BIO_ctrl" ssl-bio-ctrl) :long 208 | (bio :pointer) 209 | (cmd :int) 210 | (arg :long) 211 | (parg :pointer)) 212 | (cffi:defcfun ("BIO_ctrl_pending" ssl-bio-ctrl-pending) :unsigned-int 213 | (bio :pointer)) 214 | (cffi:defcfun ("BIO_s_mem" ssl-bio-s-mem) :pointer) 215 | (cffi:defcfun ("BIO_read" ssl-bio-read) :int 216 | (bio :pointer) 217 | (buf :pointer) 218 | (len :int)) 219 | (cffi:defcfun ("BIO_write" ssl-bio-write) :int 220 | (bio :pointer) 221 | (buf :pointer) 222 | (len :int)) 223 | (cffi:defcfun ("SSL_pending" ssl-pending) :int 224 | (ssl :pointer)) 225 | (cffi:defcfun ("SSL_read" ssl-read) :int 226 | (ssl :pointer) 227 | (buf :pointer) 228 | (len :int)) 229 | (cffi:defcfun ("SSL_write" ssl-write) :int 230 | (ssl :pointer) 231 | (buf :pointer) 232 | (len :int)) 233 | 234 | (defun & (&rest vals) (not (zerop (apply 'logand vals)))) 235 | 236 | #-tls-method 237 | (progn 238 | (defun ssl-is-init-finished (ssl) (& (ssl-state ssl) +ssl-st-ok+)) 239 | (defun ssl-in-init (ssl) (& (ssl-state ssl) +ssl-st-init+)) 240 | (defun ssl-in-before (ssl) (& (ssl-state ssl) +ssl-st-before+)) 241 | (defun ssl-in-connect-init (ssl) (& (ssl-state ssl) +ssl-st-connect+)) 242 | (defun ssl-in-accept-init (ssl) (& (ssl-state ssl) +ssl-st-accept+))) 243 | 244 | #+tls-method 245 | (progn 246 | (cffi:defcfun ("SSL_get_state" ssl-get-state) :int (ssl :pointer)) 247 | (cffi:defcfun ("SSL_in_init" ssl-in-init) :int (ssl :pointer)) 248 | (cffi:defcfun ("SSL_in_before" ssl-in-before) :int (ssl :pointer)) 249 | (cffi:defcfun ("SSL_is_server" ssl-is-server) :int (ssl :pointer)) 250 | 251 | (defun ssl-is-init-finished (ssl) (= (ssl-get-state ssl) +tls-st-ok+)) 252 | (defun ssl-in-connect-init (ssl) (& (ssl-in-init ssl) (not (ssl-is-server ssl)))) 253 | (defun ssl-in-accept-init (ssl) (& (ssl-in-init ssl) (ssl-is-server ssl))) 254 | (defun ssl-bio-set-mem-eof-return (bio v) 255 | (ssl-bio-ctrl 256 | bio +bio-c-set-buf-mem-eof-return+ v (cffi:null-pointer)))) 257 | 258 | (defun ssl-ctx-set-options (ctx options) 259 | "Function version of the openssl macro." 260 | (ssl-ctx-ctrl ctx +ssl-ctrl-options+ options (cffi:null-pointer))) 261 | -------------------------------------------------------------------------------- /src/streamish.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async) 2 | 3 | (defgeneric streamish (thing) 4 | (:documentation "Returned associated streamish for THING or THING itself 5 | if THING is a streamish.")) 6 | 7 | (defgeneric errno-event (streamish errno) 8 | (:documentation "Make an event based on errno and streamish.")) 9 | 10 | (defmethod errno-event ((streamish t) (errno t)) 11 | (make-instance 'event-error :code errno :msg (error-str errno))) 12 | 13 | (defmethod errno-event ((streamish t) (errno (eql (uv:errval :eai-noname)))) 14 | (make-instance 'dns-error :code errno :msg "DNS lookup fail")) 15 | 16 | (defmethod errno-event ((streamish t) (errno (eql (uv:errval :efault)))) 17 | (make-instance 'event-error :code errno :msg "bad address in system call argument")) 18 | 19 | (defun event-handler (error event-cb &key streamish throw) 20 | "Called when an event (error, mainly) occurs." 21 | ;; here we check if errno is actually an event/error object passed in 22 | ;; directly. if so, we kindly forward it along to the event-cb. 23 | (let* ((errno (when (numberp error) error)) 24 | (event (if (numberp error) 25 | (errno-event streamish errno) 26 | error))) 27 | (macrolet ((closing-streamish-afterwards (&body body) 28 | `(unwind-protect 29 | (if (subtypep (type-of event) 'streamish-error) 30 | (as:delay (lambda () ,@body)) 31 | (progn ,@body)) 32 | ;; if the app closed the streamish in the event cb (perfectly fine), 33 | ;; make sure we don't trigger an error trying to close it again. 34 | (when (and streamish (not (streamish-closed-p streamish))) 35 | (close-streamish streamish :force t))))) 36 | (if throw 37 | (error event) 38 | (closing-streamish-afterwards 39 | (when event-cb 40 | (funcall event-cb event))))))) 41 | 42 | ;; TBD: seems like streamish-info/socket-info/tcp-info/event-info isn't actually used? 43 | (define-condition streamish-info (event-info) 44 | ;; initarg :socket is added compatibility 45 | ((streamish :initarg :streamish 46 | :initarg :socket 47 | :accessor streamish 48 | :accessor tcp-socket ;; compatibility 49 | :initform nil)) 50 | (:report (lambda (c s) 51 | (print-unreadable-object (c s :type t :identity t) 52 | (format s "~a" (streamish c))))) 53 | (:documentation "Base streamish condition. Holds the streamish object.")) 54 | 55 | (define-condition streamish-error (event-error streamish-info) () 56 | (:report (lambda (c s) 57 | (print-unreadable-object (c s :type t :identity t) 58 | (format s "~a: ~a: ~a" (streamish c) (event-errcode c) (event-errmsg c))))) 59 | (:documentation "Describes a general streamish error.")) 60 | 61 | (define-condition streamish-enoent (streamish-error) () 62 | (:documentation "Passed to an event callback on Error: no such file or directory.")) 63 | 64 | (define-condition streamish-eof (streamish-info) () 65 | (:documentation "Passed to an event callback when stream EOF is reached.")) 66 | 67 | (define-condition streamish-closed (streamish-error) () 68 | (:report (lambda (c s) (format s "Closed streamish being operated on: ~a." (streamish c)))) 69 | (:documentation "Thrown when a closed streamish is being operated on.")) 70 | 71 | (define-condition streamish-broken-pipe (streamish-error) () 72 | (:report (lambda (c s) (format s "Broken pipe: ~a" (streamish c)))) 73 | (:documentation "Broken pipe.")) 74 | 75 | (define-condition streamish-canceled (streamish-error) () 76 | (:report (lambda (c s) (format s "Operation canceled: ~a" (streamish c)))) 77 | (:documentation "Operation canceled.")) 78 | 79 | (defclass streamish () 80 | ((c :accessor streamish-c :initarg :c :initform (cffi:null-pointer)) 81 | (data :accessor streamish-data :initarg data :initform nil 82 | :documentation "Used to store arbitrary (app-defined) data with a streamish.") 83 | (closed :accessor streamish-closed :initarg :closed :initform nil) 84 | (drain-read-buffer :accessor streamish-drain-read-buffer :initarg :drain-read-buffer :initform t)) 85 | (:documentation "Wraps around a streamish.")) 86 | 87 | (defmethod streamish ((streamish streamish)) 88 | streamish) 89 | 90 | (defmethod errno-event ((streamish streamish) (errno t)) 91 | (make-instance 'streamish-error 92 | :streamish streamish 93 | :code errno 94 | :msg (error-str errno))) 95 | 96 | (defmethod errno-event ((streamish streamish) (errno (eql (uv:errval :enoent)))) 97 | (make-instance 'streamish-enoent :streamish streamish)) 98 | 99 | (defmethod errno-event ((streamish streamish) (errno (eql (uv:errval :eof)))) 100 | (make-instance 'streamish-eof :streamish streamish)) 101 | 102 | (defmethod errno-event ((streamish streamish) (errno (eql (uv:errval :epipe)))) 103 | (make-instance 'streamish-broken-pipe :streamish streamish)) 104 | 105 | (defmethod errno-event ((streamish streamish) (errno (eql (uv:errval :ecanceled)))) 106 | (make-instance 'streamish-canceled :streamish streamish)) 107 | 108 | (defun check-streamish-open (streamish) 109 | "Throw a streamish-closed condition if given a streamish that's closed." 110 | (when (and (typep streamish 'streamish) 111 | (or (streamish-closed streamish))) 112 | (error 'streamish-closed :code -1 :msg "Trying to operate on a closed streamish" :streamish streamish))) 113 | 114 | (defun streamish-closed-p (streamish) 115 | "Return whether a streamish is closed or not." 116 | (streamish-closed streamish)) 117 | 118 | (defgeneric close-streamish (streamish &key &allow-other-keys) 119 | (:documentation 120 | "Free a streamish (uvstream) and clear out all associated data.")) 121 | 122 | (defun do-close-streamish (uvstream &key force) 123 | "Close an UV stream." 124 | (unless (zerop (uv:uv-is-closing uvstream)) 125 | (return-from do-close-streamish)) 126 | (uv:uv-read-stop uvstream) 127 | (cond ((or force (zerop (uv:uv-is-writable uvstream))) 128 | (uv:uv-close uvstream (cffi:callback streamish-close-cb))) 129 | (t 130 | (let* ((shutdown-req (uv:alloc-req :shutdown)) 131 | (r (uv:uv-shutdown shutdown-req uvstream (cffi:callback streamish-shutdown-cb)))) 132 | (if (zerop r) 133 | (attach-data-to-pointer shutdown-req (list uvstream)) 134 | (uv:uv-close uvstream (cffi:callback streamish-close-cb))))))) 135 | 136 | (defmethod close-streamish ((streamish streamish) &key force) 137 | "Close and free a streamish and all of it's underlying structures." 138 | (when (streamish-closed-p streamish) 139 | (return-from close-streamish)) 140 | (check-streamish-open streamish) 141 | (let* ((uvstream (streamish-c streamish)) 142 | (data (deref-data-from-pointer uvstream)) 143 | (read-timeout (car (getf data :read-timeout))) 144 | (write-timeout (car (getf data :write-timeout)))) 145 | (dolist (timeout (list read-timeout 146 | write-timeout)) 147 | (when (and timeout 148 | (not (event-freed-p timeout))) 149 | (free-event timeout))) 150 | (setf (streamish-closed streamish) t) 151 | (do-close-streamish uvstream 152 | :force force))) 153 | 154 | (defun write-to-uvstream (uvstream data &key start end) 155 | "Util function to write data directly to a uv stream object." 156 | (let* ((start (or start 0)) 157 | (end (or end (length data))) 158 | (bufsize (- end start)) 159 | (buffer (static-vectors:make-static-vector bufsize))) 160 | (replace buffer data :start2 start :end2 end) 161 | (let ((req (uv:alloc-req :write)) 162 | (buf (uv:alloc-uv-buf (static-vectors:static-vector-pointer buffer) bufsize))) 163 | (let ((res (uv:uv-write req uvstream buf 1 (cffi:callback streamish-write-cb)))) 164 | (uv:free-uv-buf buf) 165 | (unless (zerop res) 166 | (let ((streamish (getf (deref-data-from-pointer uvstream) :streamish))) 167 | (uv:free-req req) 168 | (error (errno-event streamish res)))) 169 | (attach-data-to-pointer req (list :uvstream uvstream :buffer buffer)))))) 170 | 171 | (define-c-callback streamish-shutdown-cb :void ((req :pointer) (status :int)) 172 | "Called when a streamish shuts down." 173 | (declare (ignore status)) 174 | (uv:free-req req) 175 | (let ((uvstream (car (deref-data-from-pointer req)))) 176 | (free-pointer-data req :preserve-pointer t) 177 | (when (zerop (uv:uv-is-closing uvstream)) 178 | (uv:uv-close uvstream (cffi:callback streamish-close-cb))))) 179 | 180 | (defgeneric streamish-write (streamish data &key start end &allow-other-keys) 181 | (:documentation 182 | "Write data into a streamish. Allows specifying read/write/event 183 | callbacks. Any callback left nil will use that current callback from the 184 | streamish (so they only override when specified, otherwise keep the current 185 | callback). 186 | 187 | Note that libuv doesn't buffer output for non-connected sockets, so we have 188 | to do it ourselves by checking if the socket is connected and buffering 189 | accordingly.")) 190 | 191 | (defun streamish-convert-data (data) 192 | (if (stringp data) 193 | (babel:string-to-octets data :encoding :utf-8) 194 | data)) 195 | 196 | (defmethod streamish-write ((streamish streamish) data &key start end &allow-other-keys) 197 | (unless (streamish-closed-p streamish) 198 | (write-to-uvstream (streamish-c streamish) 199 | (streamish-convert-data data) 200 | :start start :end end))) 201 | 202 | (defmethod streamish-write :around ((streamish streamish) data 203 | &key read-cb write-cb event-cb 204 | &allow-other-keys) 205 | (if (or read-cb write-cb event-cb) 206 | ;; we're specifying callbacks. since we're most likely calling this from 207 | ;; inside a streamish callback and we don't necessarily want to overwrite 208 | ;; that streamish' callbacks until it finishes, we set a delay here so the 209 | ;; callback binding happens after the caller returns to the event loop. 210 | (as:delay 211 | (lambda () 212 | (let ((callbacks (get-callbacks (streamish-c streamish)))) 213 | (save-callbacks (streamish-c streamish) 214 | (list :read-cb (or read-cb (getf callbacks :read-cb)) 215 | :write-cb (or write-cb (getf callbacks :write-cb)) 216 | :event-cb (or event-cb (getf callbacks :event-cb)))) 217 | (call-next-method)))) 218 | 219 | ;; we're not setting callbacks, so just enable the streamish and send the 220 | ;; data 221 | (call-next-method))) 222 | 223 | (define-c-callback streamish-alloc-cb :void ((handle :pointer) (size :unsigned-int) (buf :pointer)) 224 | "Called when we want to allocate data to be filled for stream reading." 225 | (declare (ignore handle)) 226 | (uv:alloc-uv-buf (static-vectors:static-vector-pointer *input-buffer*) (min size *buffer-size*) buf)) 227 | 228 | (define-c-callback streamish-read-cb :void ((uvstream :pointer) (nread :int) (buf :pointer)) 229 | "Called when a stream has been read into a buffer returned by alloc-cb." 230 | (declare (ignore buf)) 231 | (let* ((stream-data (deref-data-from-pointer uvstream)) 232 | (read-timeout (getf stream-data :read-timeout)) 233 | (timeout (car read-timeout)) 234 | (streamish (getf stream-data :streamish)) 235 | (stream (getf stream-data :stream)) 236 | (drain-read (streamish-drain-read-buffer streamish)) 237 | (callbacks (get-callbacks uvstream)) 238 | (read-cb (getf callbacks :read-cb)) 239 | (event-cb (getf callbacks :event-cb))) 240 | (catch-app-errors event-cb 241 | (when (< nread 0) 242 | ;; we got an error 243 | (run-event-cb 'event-handler nread event-cb :streamish streamish) 244 | (return-from streamish-read-cb)) 245 | 246 | ;; reset the read timeout 247 | (when timeout 248 | (remove-event timeout) 249 | (add-event timeout :timeout (cdr read-timeout))) 250 | 251 | ;; read the buffer 252 | (let ((bytes (make-array nread :element-type 'octet))) 253 | ;; input buffer was given to libuv in the alloc-cb, so we can just pull 254 | ;; data directly out of it now 255 | (replace bytes *input-buffer*) 256 | (cond ((and read-cb drain-read) 257 | ;; we're draining here, so call our read callback 258 | (funcall read-cb streamish bytes)) 259 | (read-cb 260 | ;; we're not draining and we have a read CB, so stream 261 | (stream-append-bytes stream bytes) 262 | (when read-cb (funcall read-cb streamish stream)))))))) 263 | 264 | (define-c-callback streamish-write-cb :void ((req :pointer) (status :int)) 265 | "Called when data is finished being written to a streamish." 266 | (let* ((data (deref-data-from-pointer req)) 267 | (uvstream (getf data :uvstream)) 268 | (buffer (getf data :buffer)) 269 | (streamish (getf (deref-data-from-pointer uvstream) :streamish)) 270 | (callbacks (get-callbacks uvstream)) 271 | (write-cb (getf callbacks :write-cb)) 272 | (event-cb (getf callbacks :event-cb))) 273 | (catch-app-errors event-cb 274 | (static-vectors:free-static-vector buffer) 275 | (free-pointer-data req :preserve-pointer t) 276 | (uv:free-req req) 277 | (if (zerop status) 278 | (when write-cb 279 | (funcall write-cb streamish)) 280 | (run-event-cb 'event-handler status event-cb :streamish streamish))))) 281 | 282 | (define-c-callback streamish-close-cb :void ((uvstream :pointer)) 283 | "Called when a streamish closes." 284 | ;; !!NOTE!! This callback is used for both tcp clients AND servers! if either 285 | ;; ever needs special treatment, split out the callbacks 286 | (free-pointer-data uvstream :preserve-pointer t) 287 | (uv:free-handle uvstream)) 288 | 289 | (defun streamish-read-start (streamish) 290 | "Start reading on the socket, return true on success. 291 | Invoke streamish' event handler callback on error, 292 | returning NIL." 293 | (let* ((uvstream (streamish-c streamish)) 294 | (event-cb (getf (get-callbacks uvstream) :event-cb)) 295 | (res (uv:uv-read-start uvstream 296 | (cffi:callback streamish-alloc-cb) 297 | (cffi:callback streamish-read-cb)))) 298 | (if (zerop res) 299 | t 300 | (run-event-cb 'event-handler res event-cb :streamish streamish)))) 301 | -------------------------------------------------------------------------------- /src/tcp.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async) 2 | 3 | ;; compatibility 4 | (define-condition-alias tcp-eof socket-eof) 5 | (define-condition-alias tcp-info socket-info) 6 | (define-condition-alias tcp-error socket-error) 7 | (define-condition-alias tcp-reset socket-reset) 8 | (define-condition-alias tcp-timeout socket-timeout) 9 | (define-condition-alias tcp-refused socket-refused) 10 | (define-condition-alias tcp-accept-error socket-accept-error) 11 | 12 | ;; TBD: tcp-server-bind-error is not actually used currently 13 | (define-condition tcp-server-bind-error (socket-error) 14 | ((addr :accessor tcp-server-bind-error-addr :initarg :addr :initform nil) 15 | (port :accessor tcp-server-bind-error-port :initarg :port :initform nil)) 16 | (:report (lambda (c s) (format s "Error binding TCP server (~a:~a)" 17 | (tcp-server-bind-error-addr c) 18 | (tcp-server-bind-error-port c)))) 19 | (:documentation "Thrown when a server fails to bind (generally, the port is already in use).")) 20 | 21 | (defclass tcp-mixin () ()) 22 | (defclass tcp-socket (tcp-mixin socket) 23 | ((direction :accessor socket-direction :initarg :direction :initform :out))) 24 | (defclass tcp-server (tcp-mixin socket-server) ()) 25 | 26 | (defmethod server-socket-class ((server tcp-server)) 'tcp-socket) 27 | 28 | (defmethod initialize-instance :after ((socket tcp-socket) &key direction &allow-other-keys) 29 | (ecase direction 30 | (:in 31 | (incf (event-base-num-connections-in *event-base*))) 32 | (:out 33 | (incf (event-base-num-connections-out *event-base*))))) 34 | 35 | (defmethod close-streamish :after ((socket tcp-socket) &key &allow-other-keys) 36 | (ecase (socket-direction socket) 37 | (:in 38 | (decf (event-base-num-connections-in *event-base*))) 39 | (:out 40 | (decf (event-base-num-connections-out *event-base*))))) 41 | 42 | (defmethod make-socket-handle ((socket-or-server tcp-mixin)) 43 | (let ((s (uv:alloc-handle :tcp))) 44 | (uv:uv-tcp-init (event-base-c *event-base*) s) 45 | s)) 46 | 47 | (defun connect-tcp-socket (socket/stream host port &key event-cb) 48 | "Connect a tcp socket initialized with init-client-socket." 49 | (let* ((socket (if (subtypep (type-of socket/stream) 'async-stream) 50 | (streamish socket/stream) 51 | socket/stream)) 52 | (uvstream (socket-c socket))) 53 | ;; only connect if we didn't get an existing fd passed in 54 | (flet ((do-connect (ip port) 55 | (with-ip-to-sockaddr ((sockaddr) ip port) 56 | (let ((req (uv:alloc-req :connect))) 57 | ;; make sure we can grab the original uvstream from the req 58 | (attach-data-to-pointer req uvstream) 59 | (if (zerop (uv:uv-is-closing uvstream)) 60 | (uv:uv-tcp-connect req uvstream sockaddr (cffi:callback socket-connect-cb)) 61 | (warn "aborting connection to ~a:~s on a tcp socket that is being closed: ~ 62 | ~s (uvstream ~s)~%" host port socket/stream uvstream)))))) 63 | (if (ip-address-p host) 64 | ;; got an IP so just connect directly 65 | (do-connect host port) 66 | 67 | ;; get a DNS base and do an async lookup 68 | (dns-lookup 69 | host 70 | (lambda (ip family) 71 | (declare (ignore family)) 72 | (do-connect ip port)) 73 | :event-cb event-cb 74 | :family +af-inet+)))) 75 | socket/stream) 76 | 77 | (defun tcp-connect-new (host port read-cb &key data stream event-cb connect-cb write-cb (read-timeout -1) (write-timeout -1) (dont-drain-read-buffer nil dont-drain-read-buffer-supplied-p)) 78 | "Open a TCP connection asynchronously. Optionally send data out once connected 79 | via the :data keyword (can be a string or byte array)." 80 | (check-type data (or null (simple-array octet (*)) string)) 81 | (let* ((socket/stream (apply #'init-client-socket 82 | 'tcp-socket 83 | (append (list :read-cb read-cb 84 | :event-cb event-cb 85 | :data data 86 | :stream stream 87 | :connect-cb connect-cb 88 | :write-cb write-cb 89 | :read-timeout read-timeout 90 | :write-timeout write-timeout) 91 | (when dont-drain-read-buffer-supplied-p 92 | (list :dont-drain-read-buffer dont-drain-read-buffer)))))) 93 | (connect-tcp-socket socket/stream host port :event-cb event-cb) 94 | socket/stream)) 95 | 96 | (defun tcp-connect (host port read-cb &rest args) 97 | "Open a TCP connection asynchronously. Optionally send data out once connected 98 | via the :data keyword (can be a string or byte array)." 99 | (let ((event-cb-dep (car args))) 100 | (unless (or (keywordp event-cb-dep) 101 | (null event-cb-dep)) 102 | (push :event-cb args) 103 | (warn "Passing event-cb as the fourth argument to tcp-connect is now deprecated. Please use the :event-cb keyword instead.")) 104 | (apply 'tcp-connect-new 105 | host port read-cb 106 | args))) 107 | 108 | (defmethod socket-server-bind ((server tcp-server) address fd) 109 | (destructuring-bind (bind-address port) address 110 | (if fd 111 | (uv:uv-tcp-open (socket-server-c server) fd) 112 | (with-ip-to-sockaddr ((sockaddr) bind-address port) 113 | (uv:uv-tcp-bind (socket-server-c server) sockaddr 0))))) 114 | 115 | (defun tcp-server-new (bind-address port read-cb &key event-cb connect-cb backlog stream fd) 116 | "Start a TCP listener on the current event loop. Returns a tcp-server class 117 | which can be closed with close-tcp-server" 118 | (socket-server 'tcp-server 119 | (list bind-address port) read-cb 120 | :event-cb event-cb 121 | :connect-cb connect-cb 122 | :backlog backlog 123 | :stream stream 124 | :fd fd)) 125 | 126 | (defun tcp-server (bind-address port read-cb &rest args) 127 | "Open a TCP connection asynchronously. Optionally send data out once connected 128 | via the :data keyword (can be a string or byte array)." 129 | (let ((event-cb-dep (car args))) 130 | (unless (or (keywordp event-cb-dep) 131 | (null event-cb-dep)) 132 | (push :event-cb args) 133 | (warn "Passing event-cb as the fourth argument to tcp-server is now deprecated. Please use the :event-cb keyword instead.")) 134 | (apply 'tcp-server-new 135 | bind-address port read-cb 136 | args))) 137 | 138 | ;; compatiblity funcs 139 | (defun close-tcp-server (server) 140 | (close-socket-server server)) 141 | 142 | (defun tcp-server-closed (server) 143 | (socket-server-closed server)) 144 | 145 | (defmethod handle-cleanup ((handle-type (eql :tcp)) handle) 146 | (handle-cleanup :async-socket handle)) 147 | -------------------------------------------------------------------------------- /src/util/error.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async-util) 2 | 3 | (defvar *passthrough-errors* '()) 4 | 5 | (defun passthrough-error-p (e) 6 | "Return true if the specified error condition should not 7 | be intercepted by cl-async error handling mechanism." 8 | (loop for type in *passthrough-errors* 9 | thereis (typep e type))) 10 | 11 | (defgeneric handle-error (error) 12 | (:documentation 13 | "Default error handler responsible for handling uncaught errors.")) 14 | 15 | (defmethod handle-error ((error t)) 16 | (vom:warn "handle-error: ~a" error)) 17 | 18 | (defun call-with-callback-restarts (thunk &key continue-fn (abort-restart-description "Abort cl-async callback.")) 19 | "Call thunk with restarts that make it possible to ignore the callback 20 | in case of an error or safely terminate the event loop. 21 | 22 | If SWANK is active, set SLDB's quit restart to ABORT-CALLBACK restart 23 | if *safe-sldb-quit-restart* is true or EXIT-EVENT-LOOP otherwise." 24 | (restart-case 25 | ;; have to use the ugly symbol-value hack instead of #+swank / #-swank 26 | ;; in order to avoid compiling in SWANK (in)dependency 27 | (let* ((swank-package (find-package :swank)) 28 | (quit-restart-sym (when swank-package 29 | (find-symbol (symbol-name '#:*sldb-quit-restart*) 30 | swank-package)))) 31 | (if quit-restart-sym 32 | (let ((old-quit-restart (symbol-value quit-restart-sym))) 33 | (setf (symbol-value quit-restart-sym) 34 | (if *safe-sldb-quit-restart* 35 | 'abort-callback 36 | 'exit-event-loop)) 37 | (unwind-protect 38 | (funcall thunk) 39 | (setf (symbol-value quit-restart-sym) old-quit-restart))) 40 | (funcall thunk))) 41 | (continue-event-loop () 42 | :report "Continue the event loop, passing the error to the default handler." 43 | (format *debug-io* "~&;; event loop continued (main handler)~%") 44 | (funcall continue-fn) 45 | (values)) 46 | (abort-callback () 47 | :report (lambda (stream) (write-string abort-restart-description stream)) 48 | (format *debug-io* "~&;; callback aborted~%") 49 | (values)) 50 | (exit-event-loop () 51 | :report "Exit the current event loop." 52 | (format *debug-io* "~&;; exiting the event loop.~%") 53 | (uv:uv-stop (event-base-c *event-base*))))) 54 | 55 | (defvar *evcb-err*) 56 | 57 | (defmacro catch-app-errors (event-cb &body body) 58 | "Handle error conditions by directing them to the specified event 59 | callback or default event handler of the current event loop, if 60 | catching app errors is enabled for the current event loop via 61 | EVENT-BASE-CATCH-APP-ERRORS, otherwise just evaluate the BODY. 62 | 63 | If event-cbs are called via run-event-cb, make sure the event-cb 64 | is NOT double-called with the same condition twice." 65 | (alexandria:once-only (event-cb) 66 | (alexandria:with-gensyms (err last-err thunk-fn continue-fn blk) 67 | `(let ((*evcb-err* '()) 68 | (,last-err nil)) 69 | (labels ((,continue-fn (error) 70 | (let* ((handler (when (event-base-send-errors-to-eventcb *event-base*) 71 | ,event-cb)) 72 | (handler (or handler 73 | (event-base-catch-app-errors *event-base*))) 74 | (handler (if (and handler 75 | (not (typep handler 'boolean))) 76 | handler 77 | 'handle-error))) 78 | (when (and handler error) 79 | (funcall handler error)))) 80 | (,thunk-fn () 81 | (call-with-callback-restarts 82 | (lambda () ,@body) 83 | :continue-fn (lambda () (,continue-fn ,last-err))))) 84 | (block ,blk 85 | (handler-bind 86 | ((error (lambda (,err) 87 | (setf ,last-err ,err) 88 | ;; check whether the error was already sent to eventcb 89 | (unless (or (member ,err *evcb-err*) 90 | (passthrough-error-p ,err)) 91 | (when (event-base-catch-app-errors *event-base*) 92 | (,continue-fn ,err) 93 | (return-from ,blk)))))) 94 | (,thunk-fn)))))))) 95 | 96 | (defun run-event-cb (event-cb &rest args) 97 | "When used in the dynamic context of catch-app-errors, wraps the 98 | calling of an event-cb with args such that errors are caught and 99 | saved, ensuring that an event-cb isn't called twice with the same 100 | condition. When used outside the dynamic context of 101 | catch-app-errors, just invokes event-cb with args." 102 | (if (boundp '*evcb-err*) 103 | (handler-bind 104 | ;; catch any errors and track them 105 | ((error #'(lambda (err) 106 | ;; track the error so we don't re-fire (*evcb-err* is bound in 107 | ;; catch-app-errors) 108 | (pushnew err *evcb-err*)))) 109 | ;; run the event handler 110 | (apply event-cb args)) 111 | (apply event-cb args))) 112 | 113 | -------------------------------------------------------------------------------- /src/util/foreign.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async-util) 2 | 3 | (defconstant +af-inet+ uv:+af-inet+) 4 | (defconstant +af-inet6+ uv:+af-inet-6+) 5 | (defconstant +af-unspec+ uv:+af-unspec+) 6 | (defconstant +af-unix+ uv:+af-unix+) 7 | 8 | (defmacro define-c-callback (name return-val (&rest args) &body body) 9 | "Define a top-level function with the given and also define a C callback that 10 | calls the function directly. The idea is that CFFI callbacks aren't directly 11 | callable/debuggable, but it's obnoxious to have to define and callback *and* 12 | a function right next to each other." 13 | (let ((arg-names (loop for x in args collect (car x)))) 14 | `(progn 15 | (defun ,name ,arg-names 16 | ,@body) 17 | (cffi:defcallback ,name ,return-val ,args 18 | (,name ,@arg-names))))) 19 | 20 | (defmacro with-foreign-object* ((var type &key (zero t) (initial (when zero #x0))) bindings &body body) 21 | "Convenience macro, makes creation and initialization of CFFI types easier. 22 | Emphasis on initialization." 23 | (let ((type-size (cffi:foreign-type-size (list :struct type)))) 24 | `(cffi:with-foreign-object (,var :unsigned-char ,type-size) 25 | ,(when initial 26 | `(cffi:foreign-funcall "memset" :pointer ,var :unsigned-char ,initial :unsigned-char ,(if type-size type-size `(cffi:foreign-type-size '(:struct ,type))))) 27 | ,@(loop for binding in bindings collect 28 | `(setf (,(car binding) ,var) ,(cadr binding))) 29 | ,@body))) 30 | 31 | (defun error-str (uv-errno) 32 | "Given a libuv error number, return the error string." 33 | ;; a lot of times errors come through that aren't known by libuv, and if we 34 | ;; ask libuv about it, it aborts (in all its wisdom). these errors seems to 35 | ;; always be > 0, while the libuv error codes always seem to be < 0. 36 | (or (ignore-errors (cffi:foreign-enum-keyword 'uv:uv-errno-t uv-errno)) 37 | "(unknown error)")) 38 | 39 | (defun ip-str-to-sockaddr (address port) 40 | "Convert a string IP address and port into a sockaddr-in struct. Must be freed 41 | by the app!" 42 | (cond 43 | ((or (null address) 44 | (ipv4-address-p address)) 45 | (let ((sockaddr (cffi:foreign-alloc '(:struct uv:sockaddr-in)))) 46 | (uv:uv-ip-4-addr (or address "0.0.0.0") port sockaddr) 47 | sockaddr)) 48 | ((ipv6-address-p address) 49 | (let ((sockaddr (cffi:foreign-alloc '(:struct uv:sockaddr-in6)))) 50 | (uv:uv-ip-6-addr address port sockaddr) 51 | sockaddr)) 52 | (t 53 | (error (format nil "Invalid address passed (not IPv4 or IPV6): ~s~%" address))))) 54 | 55 | (defmacro with-ip-to-sockaddr (((bind) address port) &body body) 56 | "Wraps around ipv4-str-to-sockaddr. Converts a string address and port and 57 | creates a sockaddr-in object, runs the body with it bound, and frees it." 58 | `(let ((,bind (ip-str-to-sockaddr ,address ,port))) 59 | (unwind-protect 60 | (progn ,@body) 61 | (cffi:foreign-free ,bind)))) 62 | 63 | (defun addrinfo-to-string (addrinfo) 64 | "Given a (horrible) addrinfo C object pointer, grab either an IP4 or IP6 65 | address and return is as a string." 66 | (let* ((family (uv-a:addrinfo-ai-family addrinfo)) 67 | (err nil)) 68 | (cffi:with-foreign-object (buf :unsigned-char 128) 69 | (let ((ai-addr (uv-a:addrinfo-ai-addr addrinfo))) 70 | (if (cffi:null-pointer-p ai-addr) 71 | (error "the addrinfo->ai_addr object was null (stinks of a memory alignment issue)") 72 | (cond ((eq family +af-inet+) 73 | (let ((sin-addr (cffi:foreign-slot-pointer ai-addr '(:struct uv:sockaddr-in) 'uv:sin-addr))) 74 | (uv:uv-inet-ntop family sin-addr buf 128))) 75 | ((eq family +af-inet6+) 76 | (let ((sin6-addr (cffi:foreign-slot-pointer ai-addr '(:struct uv:sockaddr-in6) 'uv:sin6-addr))) 77 | (uv:uv-inet-ntop family sin6-addr buf 128))) 78 | (t 79 | (setf err (format nil "unsupported DNS family: ~a" family)))))) 80 | (values (cffi:foreign-string-to-lisp buf) family err)))) 81 | 82 | (defun set-socket-nonblocking (fd) 83 | "Sets an FD into non-blocking mode." 84 | (let ((FIONBIO -2147195266) 85 | (F_GETFL 3) 86 | (F_SETFL 4) 87 | (O_NONBLOCK 2048)) 88 | (cond ((cffi:foreign-symbol-pointer "ioctlsocket") 89 | (cffi:with-foreign-object (nonblocking :unsigned-long) 90 | (setf (cffi:mem-aref nonblocking :unsigned-long) 1) 91 | (cffi:foreign-funcall "ioctlsocket" 92 | :int fd 93 | :long FIONBIO 94 | :pointer nonblocking 95 | :int))) 96 | ((cffi:foreign-symbol-pointer "fcntl") 97 | (let ((flags (cffi:foreign-funcall "fcntl" 98 | :int fd 99 | :int F_GETFL 100 | :pointer (cffi:null-pointer) 101 | :int))) 102 | (cffi:foreign-funcall "fcntl" 103 | :int fd 104 | :int F_SETFL 105 | :int (logior flags O_NONBLOCK) 106 | :int)))))) 107 | 108 | (defun fd-connected-p (fd) 109 | "Check if an FD is connected." 110 | (cffi:with-foreign-objects ((error :int) 111 | (len :int)) 112 | (setf (cffi:mem-aref len :int) (cffi:foreign-type-size :int)) 113 | (let* ((SOL_SOCKET #+windows 65535 #-windows 1) 114 | (SO_ERROR #+windows 4103 #-windows 4) 115 | (res (cffi:foreign-funcall "getsockopt" 116 | :int fd 117 | :int SOL_SOCKET 118 | :int SO_ERROR 119 | :pointer error 120 | :pointer len 121 | :int))) 122 | (zerop res)))) 123 | 124 | -------------------------------------------------------------------------------- /src/util/helpers.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async-util) 2 | 3 | (deftype octet () '(unsigned-byte 8)) 4 | (deftype octet-vector () '(simple-array octet (*))) 5 | (deftype bytes-or-string () '(or octet-vector string)) 6 | (deftype callback () '(or null function symbol)) 7 | 8 | (defun bytes (vector) 9 | "Convert any vector/string into a byte array. Useful for sending direct byte 10 | data into write-socket-data." 11 | (coerce vector '(vector octet))) 12 | 13 | (declaim (inline buffer-output)) 14 | (defun buffer-output (buffer) 15 | "Grab the output from a buffer created with (make-buffer)." 16 | (declare (type fast-io::output-buffer buffer)) 17 | (fast-io:finish-output-buffer buffer)) 18 | 19 | (declaim (inline write-to-buffer)) 20 | (defun write-to-buffer (seq buffer &optional start end) 21 | "Write data to a buffer created with (make-buffer)." 22 | (declare (type octet-vector seq) 23 | (type fast-io::output-buffer buffer)) 24 | (fast-io:fast-write-sequence seq buffer (or start 0) end)) 25 | 26 | (defun make-buffer (&optional data) 27 | "Create an octet buffer, optoinally filled with the given data." 28 | (declare (type (or null octet-vector) data)) 29 | (let ((buffer (fast-io:make-output-buffer))) 30 | (when data 31 | (write-to-buffer data buffer)) 32 | buffer)) 33 | 34 | (defun do-chunk-data (data buffer write-cb &key start end new-buffer) 35 | "Util function that splits data into the (length buffer) chunks and calls 36 | write-cb for each chunk." 37 | (cond ((streamp data) 38 | (loop for read-buffer = (if new-buffer 39 | (static-vectors:make-static-vector (length buffer)) 40 | buffer) 41 | for n = (read-sequence read-buffer data) 42 | while (< 0 n) do 43 | (funcall write-cb read-buffer n))) 44 | (t 45 | (let* ((len (length data)) 46 | (start (or start 0)) 47 | (end (min (or end len) len)) 48 | (data-length (- end start)) 49 | (data-index start) 50 | (buffer-length (length buffer))) 51 | (loop while (< 0 data-length) do 52 | (let ((bufsize (min data-length buffer-length)) 53 | ;; create a new buffer if we ask for one. 54 | ;; NOTE: the newly created buffer MUST be freed elsewhere 55 | (read-buffer (if new-buffer 56 | (static-vectors:make-static-vector buffer-length) 57 | buffer))) 58 | (replace read-buffer data :start2 data-index :end2 end) 59 | (funcall write-cb read-buffer bufsize) 60 | (decf data-length bufsize) 61 | (incf data-index bufsize))))))) 62 | 63 | (defmacro with-lock (&body body) 64 | "If threading is enabled, locks the current event loop before processing body 65 | and releases the lock after body is finished." 66 | `(if *enable-threading* 67 | (bt:with-lock-held ((event-base-lock *event-base*)) 68 | ,@body) 69 | (progn ,@body))) 70 | 71 | (defun make-pointer-eql-able (pointer) 72 | "Abstraction to make a CFFI pointer #'eql to itself. Does its best to be the 73 | most performant for the current implementation." 74 | (when pointer 75 | #+(or ccl) 76 | pointer 77 | #-(or ccl) 78 | (if (cffi:pointerp pointer) 79 | (cffi:pointer-address pointer) 80 | pointer))) 81 | 82 | (defun create-data-pointer () 83 | "Creates a pointer in C land that can be used to attach data/callbacks to. 84 | Note that this must be freed via clear-pointer-data." 85 | (cffi:foreign-alloc :char :count 1)) 86 | 87 | (defun save-callbacks (pointer callbacks) 88 | "Save a set of callbacks, keyed by the given pointer." 89 | (with-lock 90 | (let ((callbacks (alexandria:ensure-list callbacks))) 91 | (setf (gethash (make-pointer-eql-able pointer) *function-registry*) callbacks)))) 92 | 93 | (defun get-callbacks (pointer) 94 | "Get all callbacks for the given pointer." 95 | (with-lock 96 | (when *function-registry* 97 | (gethash (make-pointer-eql-able pointer) *function-registry*)))) 98 | 99 | (defun clear-callbacks (pointer) 100 | "Clear out all callbacks for the given pointer." 101 | (with-lock 102 | (when *function-registry* 103 | (remhash (make-pointer-eql-able pointer) *function-registry*)))) 104 | 105 | (defun attach-data-to-pointer (pointer data) 106 | "Attach a lisp object to a foreign pointer." 107 | (with-lock 108 | (setf (gethash (make-pointer-eql-able pointer) *data-registry*) data))) 109 | 110 | (defun deref-data-from-pointer (pointer) 111 | "Grab data attached to a CFFI pointer." 112 | (with-lock 113 | (when (and pointer *data-registry*) 114 | (gethash (make-pointer-eql-able pointer) *data-registry*)))) 115 | 116 | (defun clear-pointer-data (pointer) 117 | "Clear the data attached to a CFFI pointer." 118 | (with-lock 119 | (when (and pointer *data-registry*) 120 | (remhash (make-pointer-eql-able pointer) *data-registry*)))) 121 | 122 | (defun free-pointer-data (pointer &key preserve-pointer) 123 | "Clears out all data attached to a foreign pointer, and frees the pointer 124 | (unless :preserve-pointer is t)." 125 | (when pointer 126 | (unwind-protect 127 | (progn 128 | (clear-callbacks pointer) 129 | (clear-pointer-data pointer)) 130 | (unless preserve-pointer 131 | (with-lock 132 | (when (cffi:pointerp pointer) 133 | (cffi:foreign-free pointer))))))) 134 | 135 | (defun append-array (arr1 arr2) 136 | "Create an array, made up of arr1 followed by arr2." 137 | (warn "cl-async-util:append-array is worthless. please consider using make-buffer/write-to-buffer/buffer-output instead") 138 | (let ((arr1-length (length arr1)) 139 | (arr2-length (length arr2))) 140 | (let ((arr (make-array (+ arr1-length arr2-length) 141 | :element-type (array-element-type arr1)))) 142 | (replace arr arr1 :start1 0) 143 | (replace arr arr2 :start1 arr1-length) 144 | arr))) 145 | 146 | (defparameter *ipv4-scanner* 147 | (cl-ppcre:create-scanner 148 | "^((25[0-5]|2[0-4][0-9]|1[0-9][0-9]|[0-9]{2}|[0-9])\\.){3}(25[0-5]|2[0-4][0-9]|1[0-9][0-9]|[0-9]{2}|[0-9])$" 149 | :case-insensitive-mode t) 150 | "Scanner that detects if a string is an IPV4 address.") 151 | 152 | (defparameter *ipv6-scanner* 153 | (cl-ppcre:create-scanner 154 | "^\s*((([0-9A-Fa-f]{1,4}:){7}([0-9A-Fa-f]{1,4}|:))|(([0-9A-Fa-f]{1,4}:){6}(:[0-9A-Fa-f]{1,4}|((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3})|:))|(([0-9A-Fa-f]{1,4}:){5}(((:[0-9A-Fa-f]{1,4}){1,2})|:((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3})|:))|(([0-9A-Fa-f]{1,4}:){4}(((:[0-9A-Fa-f]{1,4}){1,3})|((:[0-9A-Fa-f]{1,4})?:((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3}))|:))|(([0-9A-Fa-f]{1,4}:){3}(((:[0-9A-Fa-f]{1,4}){1,4})|((:[0-9A-Fa-f]{1,4}){0,2}:((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3}))|:))|(([0-9A-Fa-f]{1,4}:){2}(((:[0-9A-Fa-f]{1,4}){1,5})|((:[0-9A-Fa-f]{1,4}){0,3}:((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3}))|:))|(([0-9A-Fa-f]{1,4}:){1}(((:[0-9A-Fa-f]{1,4}){1,6})|((:[0-9A-Fa-f]{1,4}){0,4}:((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3}))|:))|(:(((:[0-9A-Fa-f]{1,4}){1,7})|((:[0-9A-Fa-f]{1,4}){0,5}:((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3}))|:)))(%.+)?\s*$" 155 | :case-insensitive-mode t) 156 | "Scanner that detects if a string is an IPV6 address.") 157 | 158 | (defun ipv4-address-p (addr) 159 | "Determine if the given host is an IPV4 addr or a hostname." 160 | (cl-ppcre:scan *ipv4-scanner* addr)) 161 | 162 | (defun ipv6-address-p (addr) 163 | "Determine if the given host is an IPV6 addr or a hostname." 164 | (cl-ppcre:scan *ipv6-scanner* addr)) 165 | 166 | (defun ip-address-p (addr) 167 | "Determine if the given host is an IP or a hostname." 168 | (or (ipv4-address-p addr) 169 | (ipv6-address-p addr))) 170 | 171 | (defmacro define-condition-alias (alias name) 172 | "Define an alias for the specified condition." 173 | `(define-condition ,alias (,name) 174 | ())) 175 | -------------------------------------------------------------------------------- /src/util/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-async-util 2 | (:use :cl :cl-async-base) 3 | (:export #:octet 4 | #:octet-vector 5 | #:bytes-or-string 6 | #:callback 7 | 8 | #:bytes 9 | #:make-buffer 10 | #:buffer-output 11 | #:write-to-buffer 12 | 13 | #:do-chunk-data 14 | 15 | #:+af-inet+ 16 | #:+af-inet6+ 17 | #:+af-unspec+ 18 | #:+af-unix+ 19 | 20 | #:+sockaddr-size+ 21 | #:+sockaddr6-size+ 22 | #:+addrinfo-size+ 23 | 24 | #:*passthrough-errors* 25 | #:passthrough-error-p 26 | #:handle-error 27 | #:abort-callback 28 | #:exit-event-loop 29 | #:continue-event-loop 30 | #:call-with-callback-restarts 31 | #:catch-app-errors 32 | #:run-event-cb 33 | 34 | #:define-c-callback 35 | 36 | #:with-foreign-object* 37 | 38 | #:with-lock 39 | 40 | #:make-pointer-eql-able 41 | #:create-data-pointer 42 | #:save-callbacks 43 | #:get-callbacks 44 | #:clear-callbacks 45 | #:attach-data-to-pointer 46 | #:deref-data-from-pointer 47 | #:clear-pointer-data 48 | #:free-pointer-data 49 | 50 | #:with-struct-timeval 51 | #:split-usec-time 52 | 53 | #:append-array 54 | 55 | #:*ipv4-scanner* 56 | #:*ipv6-scanner* 57 | 58 | #:error-str 59 | 60 | #:ipv4-address-p 61 | #:ipv6-address-p 62 | #:ip-address-p 63 | #:ip-str-to-sockaddr 64 | #:with-ip-to-sockaddr 65 | #:addrinfo-to-string 66 | 67 | #:set-socket-nonblocking 68 | #:fd-connected-p 69 | 70 | #:define-condition-alias)) 71 | 72 | -------------------------------------------------------------------------------- /test/async-stream.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async-test) 2 | (in-suite cl-async-test-core) 3 | 4 | ;; TODO: read/write-byte 5 | 6 | (defparameter *stream-buffer* (make-array 8096 :element-type '(unsigned-byte 8))) 7 | 8 | (test stream-read-write-sequence 9 | "Test both tcp stream read-sequence and write-sequence" 10 | (multiple-value-bind (server-data client-data) 11 | (async-let ((server-data nil) 12 | (client-data nil)) 13 | ;(test-timeout 3) 14 | 15 | (let ((server (as:tcp-server nil 31388 16 | (lambda (sock data) 17 | (setf server-data (babel:octets-to-string data)) 18 | ;; for good measure, test writing to a new stream from server 19 | (write-sequence (babel:string-to-octets "don't say that") 20 | (make-instance 'as:async-io-stream :socket sock)))))) 21 | ;; launch a client, which will write its data to a stream 22 | (as:with-delay () 23 | (let ((stream (as:tcp-connect "127.0.0.1" 31388 24 | (lambda (sock stream) 25 | ;; got a response, read from the stream 26 | (let ((num-bytes (read-sequence *stream-buffer* stream))) 27 | (setf client-data (babel:octets-to-string (subseq *stream-buffer* 0 num-bytes))) 28 | (as:close-socket sock) 29 | (as:close-tcp-server server))) 30 | :stream t))) 31 | (write-sequence (babel:string-to-octets "can i have your coat?") stream))))) 32 | (is (string= server-data "can i have your coat?")) 33 | (is (string= client-data "don't say that")))) 34 | -------------------------------------------------------------------------------- /test/base.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async-test) 2 | (in-suite cl-async-test-core) 3 | 4 | ;; TODO: test non-exit on events existing 5 | 6 | (test event-loop-starts 7 | "Test that the event loop actually starts" 8 | (is (eq (async-let ((started nil)) 9 | (setf started t)) 10 | t))) 11 | 12 | (test event-loop-exit 13 | "Test that an event loop can be exited (unnaturally)" 14 | (is (eq (async-let ((delayed :no)) 15 | (as:delay (lambda () (setf delayed :yes)) 16 | :time 1) 17 | (as:exit-event-loop)) 18 | :no))) 19 | 20 | (test catch-app-errors 21 | "Test the global event handler works appropriately" 22 | (let ((err nil)) 23 | (handler-case 24 | (as:with-event-loop (:catch-app-errors nil) 25 | (error "lool")) 26 | (error (e) (setf err e))) 27 | (is (subtypep (type-of err) 'error))) 28 | (let ((err nil)) 29 | (as:with-event-loop (:catch-app-errors (lambda (e) (setf err e))) 30 | (error "oh noo")) 31 | (is-true (subtypep (type-of err) 'error)))) 32 | 33 | (test data-and-fn-pointers 34 | "Test for the correct number of data/function pointers for a set of operations" 35 | (multiple-value-bind (data-pt fn-pt) 36 | (async-let ((data-pt nil) 37 | (fn-pt nil)) 38 | (as:delay (lambda ()) :time 2) 39 | (as:delay (lambda ()) :time 2) 40 | (as:delay (lambda ()) :time 2) 41 | (let ((stats (as:stats))) 42 | (setf data-pt (getf stats :data-registry-count)) 43 | (setf fn-pt (getf stats :fn-registry-count)))) 44 | (is (= data-pt 4)) 45 | (is (= fn-pt 5)))) 46 | 47 | (test exit-callbacks 48 | "Test that functions assigned to be called when event loop exits are run" 49 | (multiple-value-bind (yes-ran) 50 | (async-let ((yes-ran nil)) 51 | (cl-async::add-event-loop-exit-callback 52 | (lambda () 53 | (setf yes-ran :omglolwtf))) 54 | (as:delay (lambda () nil) :time .2)) 55 | (is (eq yes-ran :omglolwtf)))) 56 | -------------------------------------------------------------------------------- /test/benchmarks.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async-test) 2 | 3 | ;; profiling shortcuts 4 | #+sbcl 5 | (defun setup-profile () 6 | (sb-profile:reset) 7 | (sb-profile:profile 8 | as::start-event-loop 9 | as::write-to-evbuffer 10 | as::drain-evbuffer 11 | as::socket-drain-read-buffer 12 | as::init-incoming-socket 13 | as::set-socket-timeouts 14 | as::check-socket-open 15 | as::add-event 16 | as::free-event 17 | as::delay 18 | as::check-event-unfreed 19 | cl-async-util::attach-data-to-pointer 20 | cl-async-util::deref-data-from-pointer 21 | cl-async-util::free-pointer-data 22 | cl-async-util::clear-callbacks 23 | cl-async-util::clear-pointer-data 24 | cl-async-util::get-callbacks 25 | cl-async-util::save-callbacks 26 | cl-async-util::split-usec-time 27 | cl-async-util::create-data-pointer 28 | cl-async-util::make-pointer-eql-able 29 | cl-async-util::append-array 30 | cl-async-util::get-free-timeval 31 | cl-async-util::release-timeval)) 32 | 33 | (defparameter *http-response* 34 | (babel:string-to-octets 35 | (with-output-to-string (s) 36 | (format s "HTTP/1.1 200 OK~c~c" #\return #\newline) 37 | (format s "Date: Wed, 03 Oct 2012 23:43:10 GMT~c~c" #\return #\newline) 38 | (format s "Content-Type: text/plain~c~c" #\return #\newline) 39 | (format s "Content-Length: 9~c~c" #\return #\newline) 40 | (format s "~c~c" #\return #\newline) 41 | (format s "omglolwtf")))) 42 | 43 | (defun benchmark-server (&key (port 9009) (request-delay 0) (num-requests 40000)) 44 | (as:start-event-loop 45 | (lambda () 46 | (let ((server nil) 47 | (finished-requests 0) 48 | (last-finished 0) 49 | (last-time 0)) 50 | (labels ((show-stats () 51 | (let* ((stats (as:stats)) 52 | (incoming (getf stats :incoming-tcp-connections)) 53 | (outgoing (getf stats :outgoing-tcp-connections)) 54 | (fn-count (getf stats :fn-registry-count)) 55 | (data-count (getf stats :data-registry-count)) 56 | (now (get-internal-real-time)) 57 | (sec (/ (- now last-time) internal-time-units-per-second)) 58 | (rate (/ (- finished-requests last-finished) sec))) 59 | (setf last-finished finished-requests 60 | last-time now) 61 | (format t "fn/data: ~a/~a~%incoming: ~a~%outgoing: ~a~%finished: ~a / ~a~%rate: ~f req/s~%" fn-count data-count incoming outgoing finished-requests num-requests rate) 62 | ;(room) 63 | (format t "---------------~%")) 64 | (unless (as::tcp-server-closed server) 65 | (as:delay #'show-stats :time 2))) 66 | (read-cb (socket data) 67 | (declare (ignore data)) 68 | (flet ((delay-fn () 69 | (unless (as:socket-closed-p socket) 70 | (as:write-socket-data 71 | socket *http-response* 72 | :write-cb (lambda (socket) 73 | (as:close-socket socket) 74 | (incf finished-requests) 75 | (when (<= num-requests finished-requests) 76 | (as:close-tcp-server server) 77 | (as:free-signal-handler 2))))))) 78 | (if (< 0 request-delay) 79 | (as:delay #'delay-fn :time request-delay) 80 | (funcall #'delay-fn))))) 81 | (setf server (as:tcp-server nil port 82 | #'read-cb 83 | (lambda (err) 84 | (format t "(benchmark server): ~a~%" err)))) 85 | (as:signal-handler 2 86 | (lambda (signo) 87 | (declare (ignore signo)) 88 | (format t "Got sigint, closing server.~%") 89 | (as:exit-event-loop))) 90 | (show-stats)))) 91 | :catch-app-errors t)) 92 | 93 | (defun benchmark-client (&key (server "127.0.0.1") (port 9009) (num-requests 40000) (delay 1) (client-id 0)) 94 | (as:start-event-loop 95 | (lambda () 96 | (labels ((do-client (client-id) 97 | (as:tcp-connect server port 98 | (lambda (sock data) 99 | (declare (ignore sock data))) 100 | (lambda (e) 101 | (unless (subtypep (type-of e) 'as:tcp-eof) 102 | (format t "(benchmark client): ~a~%" e))) 103 | :data (format nil "GET /~c~c~c~c" #\return #\newline #\return #\newline)) 104 | (when (< (1+ client-id) num-requests) 105 | (as:delay 106 | (lambda () 107 | (do-client (1+ client-id))) 108 | :time delay)))) 109 | (do-client client-id))))) 110 | 111 | (defun benchmark-delays (&key (num-delays 40000) (delay .0000000000001)) 112 | (let ((delay-num 0)) 113 | (time 114 | (as:start-event-loop 115 | (lambda () 116 | (labels ((do-delay () 117 | (when (< delay-num num-delays) 118 | (incf delay-num) 119 | (as:delay #'do-delay :time delay)))) 120 | (do-delay))))))) 121 | 122 | (defun benchmark-data-pointers (&key (num-pointers 10000)) 123 | (as:start-event-loop 124 | (lambda () 125 | (time 126 | (let ((pointers (make-array num-pointers)) 127 | (sink1 nil) 128 | (sink2 nil)) 129 | (dotimes (i num-pointers) 130 | (setf (aref pointers i) (cl-async-util::create-data-pointer)) 131 | (let ((pt (aref pointers i)) 132 | (obj (random 9999999)) 133 | (cb (list :read (lambda () (format t "omg!~%")) :write (lambda () (format t "lol~%"))))) 134 | (cl-async-util::attach-data-to-pointer pt obj) 135 | (cl-async-util::save-callbacks pt cb))) 136 | (dotimes (i 999999) 137 | (let* ((idx (random num-pointers)) 138 | (pt (aref pointers idx))) 139 | (setf sink1 (deref-data-from-pointer pt) 140 | sink2 (get-callbacks pt)))) 141 | (loop for pointer across pointers do 142 | (cl-async-util::free-pointer-data pointer))))))) 143 | 144 | (defun lol () (format t "hai...~%")) 145 | (defun simple-test () 146 | (as:start-event-loop 147 | (lambda () 148 | (as:delay 'lol :time 1)))) 149 | -------------------------------------------------------------------------------- /test/dns.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async-test) 2 | (in-suite cl-async-test-core) 3 | 4 | (test dns-simple 5 | "Test a simple DNS request" 6 | (is (string= 7 | (async-let ((lookup nil)) 8 | (test-timeout 3) 9 | (as:dns-lookup "localhost" 10 | (lambda (addr fam) 11 | (declare (ignore fam)) 12 | (setf lookup addr)) 13 | :event-cb (lambda (ev) (error ev)) 14 | :family as:+af-inet+)) 15 | "127.0.0.1"))) 16 | 17 | (test dns-multi 18 | "Test multiple DNS requests" 19 | (multiple-value-bind (dns1 dns2) 20 | (async-let ((addr1 nil) 21 | (addr2 nil)) 22 | (test-timeout 5) 23 | (as:dns-lookup "google.com" 24 | (lambda (addr fam) 25 | (declare (ignore fam)) 26 | (setf addr1 addr)) 27 | :event-cb (lambda (ev) (error ev))) 28 | (as:dns-lookup "localhost" 29 | (lambda (addr fam) 30 | (declare (ignore fam)) 31 | (setf addr2 addr)) 32 | :event-cb (lambda (ev) (error ev)))) 33 | (is (stringp dns1)) 34 | (is (stringp dns2)))) 35 | 36 | (test dns-lookup-ipv4 37 | "Test IPV4 family" 38 | (multiple-value-bind (ipv4) 39 | (async-let ((ipv4 nil)) 40 | (test-timeout 3) 41 | (as:dns-lookup "google.com" 42 | (lambda (addr fam) 43 | (declare (ignore fam)) 44 | (setf ipv4 addr)) 45 | :event-cb (lambda (ev) (error ev)) 46 | :family as:+af-inet+)) 47 | (is (cl-async-util::ipv4-address-p ipv4)))) 48 | 49 | (test dns-lookup-ipv6 50 | "Test IPV6 family (can fail in *nix)" 51 | (multiple-value-bind (ipv6) 52 | (handler-case 53 | (async-let ((ipv6 nil)) 54 | (test-timeout 3) 55 | (as:dns-lookup "google.com" 56 | (lambda (addr fam) 57 | (declare (ignore fam)) 58 | (setf ipv6 addr)) 59 | :event-cb (lambda (ev) (error ev)) 60 | :family as:+af-inet6+)) 61 | (error (e) (format nil "(~a) ~a" (as:event-errcode e) (as:event-errmsg e)))) 62 | (is (cl-async-util::ipv6-address-p ipv6)))) 63 | 64 | (test dns-fail 65 | "Tests DNS failure on fake host, makes sure event-cb gets fires once" 66 | (let ((num-err 0)) 67 | (signals as:dns-error 68 | (async-let ((lookup nil)) 69 | (test-timeout 3) 70 | (as:dns-lookup "all your children are poor unfortunate victims of lies you believe." 71 | (lambda (addr fam) (list addr fam)) 72 | :event-cb (lambda (ev) 73 | (incf num-err) 74 | (error ev))))) 75 | (is (= num-err 1)))) 76 | 77 | (test reverse-dns-lookup-ipv4 78 | "Test IPV4 family" 79 | (multiple-value-bind (host) 80 | (async-let ((host nil)) 81 | (test-timeout 3) 82 | (as:reverse-dns-lookup "8.8.8.8" 83 | (lambda (host* service) 84 | (declare (ignore service)) 85 | (setf host host*)) 86 | :event-cb (lambda (ev) (error ev)))) 87 | (is (string= host "dns.google")))) 88 | 89 | (test reverse-dns-lookup-ipv6 90 | "Test IPV6 family" 91 | (multiple-value-bind (host) 92 | (handler-case 93 | (async-let ((host nil)) 94 | (test-timeout 3) 95 | (as:reverse-dns-lookup "2001:4860:4860::8888" 96 | (lambda (host* service) 97 | (declare (ignore service)) 98 | (setf host host*)) 99 | :event-cb (lambda (ev) (error ev)))) 100 | (error (e) (format nil "(~a) ~a" (as:event-errcode e) (as:event-errmsg e)))) 101 | (is (string= host "dns.google")))) 102 | 103 | (test dns-lookup-mem-leak 104 | "Test dns-lookup memory leaks" 105 | (is (async-let ((counts-equal nil)) 106 | (test-timeout 3) 107 | (let ((old-count (hash-table-count cl-async-base:*function-registry*))) 108 | (as:dns-lookup "localhost" 109 | (lambda (addr fam) 110 | (declare (ignore addr fam)) 111 | (as:delay 112 | (lambda () 113 | (setf counts-equal 114 | (= old-count 115 | (hash-table-count cl-async-base:*function-registry*)))))) 116 | :event-cb (lambda (ev) (error ev)) 117 | :family as:+af-inet+))))) 118 | 119 | (test reverse-dns-lookup-mem-leak 120 | "Test reverse-dns-lookup memory leaks" 121 | (is (async-let ((counts-equal nil)) 122 | (test-timeout 3) 123 | (let ((old-count (hash-table-count cl-async-base:*function-registry*))) 124 | (as:reverse-dns-lookup "8.8.8.8" 125 | (lambda (host service) 126 | (declare (ignore host service)) 127 | (as:delay 128 | (lambda () 129 | (setf counts-equal 130 | (= old-count 131 | (hash-table-count cl-async-base:*function-registry*)))))) 132 | :event-cb (lambda (ev) (error ev))))))) 133 | -------------------------------------------------------------------------------- /test/event.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async-test) 2 | (in-suite cl-async-test-core) 3 | 4 | (test delay-simple 5 | "Test a simple delay" 6 | (is (eq (async-let ((ran nil)) 7 | (as:delay (lambda () (setf ran :lol)))) 8 | :lol))) 9 | 10 | (test delay-timer 11 | "Test the time accuracy of delay" 12 | (multiple-value-bind (start end) 13 | (async-let ((start (get-internal-real-time)) 14 | (end :blank)) 15 | (as:delay (lambda () (setf end (get-internal-real-time))) 16 | :time 2)) 17 | (is (<= 1.98 (/ (- end start) internal-time-units-per-second) 2.02)))) 18 | 19 | (test delay-multi 20 | "Test multiple timers" 21 | (multiple-value-bind (timer1 timer2 timer3) 22 | (async-let ((timer1 nil) 23 | (timer2 nil) 24 | (timer3 nil)) 25 | (as:delay (lambda () (setf timer1 t)) :time 1) 26 | (as:delay (lambda () (setf timer2 t)) :time 1) 27 | (as:delay (lambda () (setf timer3 t)) :time 1)) 28 | (is (identity timer1)) 29 | (is (identity timer2)) 30 | (is (identity timer3)))) 31 | 32 | (test interval 33 | "Test intervals" 34 | (is (eq (async-let ((c 0)) 35 | (let ((interval (as:interval (lambda () (incf c)) :time .1))) 36 | (as:with-delay (.32) 37 | (as:remove-interval interval)))) 38 | 3))) 39 | 40 | -------------------------------------------------------------------------------- /test/filesystem.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async-test) 2 | (in-suite cl-async-test-core) 3 | 4 | (test mkdtemp 5 | (with-test-event-loop () 6 | (as:mkdtemp (uiop:merge-pathnames* 7 | "tstXXXXXX" 8 | (uiop:temporary-directory)) 9 | (called-once 10 | #'(lambda (path) 11 | (let ((temp-p (uiop:subpathp path (uiop:temporary-directory)))) 12 | (is-true temp-p) 13 | (when temp-p 14 | (uiop:delete-empty-directory path)))))))) 15 | 16 | (test mkdtemp-fail 17 | (signals as:filesystem-enoent 18 | (with-test-event-loop () 19 | (as:mkdtemp (format nil "/whatever-~36r/abcXXXXXX" (random (expt 2 256))) 20 | #'never)))) 21 | -------------------------------------------------------------------------------- /test/fsevent.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async-test) 2 | 3 | (in-suite cl-async-test-core) 4 | 5 | (test fs-monitor ; no support for recursive flag on linux, but works anyways without 6 | (with-test-event-loop () 7 | (test-timeout 3) 8 | (with-temporary-directory (dir) 9 | (let ((got-callback-p nil) 10 | (num-events 0) 11 | fs-monitor) 12 | (setf fs-monitor 13 | (as:fs-watch dir 14 | #'(lambda (monitor path rename-p change-p) 15 | ;; Unfortunately uv_fs_event stuff is pretty random, 16 | ;; so these arguments aren't supported across all 17 | ;; the platforms and are pretty random anyway. 18 | ;; Also, the callback can be invoked several 19 | ;; times for the single change. 20 | (declare (ignore path rename-p change-p)) 21 | (is (eq fs-monitor monitor)) 22 | (setf got-callback-p t)))) 23 | (macrolet ((expecting-callback (&body body) 24 | `(progn 25 | (setf got-callback-p nil) 26 | ,@body 27 | (wait (when got-callback-p 28 | (if (= (incf num-events) 3) 29 | (as:fs-unwatch fs-monitor) 30 | t)))))) 31 | (expecting-callback 32 | (ensure-directories-exist 33 | (uiop:merge-pathnames* #p"42/" dir))) 34 | (expecting-callback 35 | (alexandria:with-output-to-file (s (uiop:merge-pathnames* "4242" dir)) 36 | (princ 42 s))) 37 | (expecting-callback 38 | (uiop:delete-empty-directory 39 | (uiop:merge-pathnames* #p"42/" dir)))))))) 40 | 41 | (test fs-watch-failure () 42 | (signals as:filesystem-enoent 43 | (with-test-event-loop () 44 | (with-path-under-tmpdir (path "blabla") 45 | (as:fs-watch path #'never) 46 | (as:with-delay (1) nil))))) 47 | -------------------------------------------------------------------------------- /test/http.lisp: -------------------------------------------------------------------------------- 1 | ;;; DEPRECATED. these tests should work with the current version of cl-async's 2 | ;;; HTTP implementation, but will no longer be updated. Use drakma-async to 3 | ;;; replace http-client. 4 | 5 | (in-package :cl-async-test) 6 | (in-suite cl-async-test-core) 7 | 8 | ;; TODO: timeouts (integer, float) 9 | 10 | (test http-simple-client-server 11 | "Test both http-client and http-server" 12 | (multiple-value-bind (server-reqs server-data client-replies client-data) 13 | (async-let ((server-reqs 0) 14 | (server-data "") 15 | (client-replies 0) 16 | (client-data "")) 17 | (test-timeout 2) 18 | 19 | (as:http-server nil 31388 20 | (lambda (req) 21 | (incf server-reqs) 22 | (let ((body (or (as:http-request-body req) (make-array 0 :element-type '(unsigned-byte 8))))) 23 | (setf server-data (concat server-data (babel:octets-to-string body)))) 24 | (as:http-response req :body "thxlol ")) 25 | nil) 26 | 27 | (dolist (addr '("http://127.0.0.1:31388/" "http://localhost:31388/")) 28 | ;; split request "hai " up between http-client and write-socket-data 29 | (as:http-client addr 30 | (lambda (status headers body) 31 | (declare (ignore status headers)) 32 | (incf client-replies) 33 | (setf client-data (concat client-data (babel:octets-to-string body)))) 34 | (lambda (ev) (error ev)) 35 | ;; NOTE: disabled until i figure out how to force http-server to 36 | ;; read the body of GET requests. in other words, this test SHOULD 37 | ;; fail until the server is fixed. 38 | ;:method :post 39 | :body "hai ")) 40 | 41 | (as:delay (lambda () (as:exit-event-loop)) 42 | :time 1)) 43 | (is (= server-reqs 2) "number of server requests") 44 | (is (string= server-data "hai hai ") "Wrong data recieved by server (known bug: https://github.com/orthecreedence/cl-async/issues/39)") 45 | (is (= client-replies 2) "number of replies sent to client") 46 | (is (string= client-data "thxlol thxlol ") "received client data"))) 47 | 48 | (test http-connect-fail 49 | "Make sure a http connection fails" 50 | (let ((num-err 0)) 51 | (signals as:http-refused 52 | (async-let () 53 | (test-timeout 2) 54 | (as:http-client "http://1.24.3.4:3" 55 | (lambda (status headers body) (declare (ignore status headers body))) 56 | (lambda (ev) 57 | (incf num-err) 58 | (error ev)) 59 | :body "hai" 60 | :timeout 1))) 61 | (is (= num-err 1)))) 62 | 63 | (test http-server-close 64 | "Make sure a http-server closes gracefully" 65 | (multiple-value-bind (closedp) 66 | (async-let ((closedp nil)) 67 | (test-timeout 3) 68 | (let* ((server (as:http-server nil 41818 69 | (lambda (req) 70 | (as:http-response req :body "lol")) 71 | (lambda (ev) (declare (ignore ev)))))) 72 | (as:http-client "http://127.0.0.1:41818" 73 | (lambda (status headers body) 74 | (declare (ignore status headers body)) 75 | (as:delay 76 | (lambda () 77 | (let ((closed-pre (as::http-server-closed server))) 78 | (as:delay 79 | (lambda () 80 | (setf closedp (and closed-pre 81 | (as::http-server-closed server))))))) 82 | :time 1)) 83 | (lambda (ev) (declare (ignore ev)))) 84 | (as:delay (lambda () (as:close-http-server server)) :time .1))) 85 | (is-true closedp))) 86 | 87 | -------------------------------------------------------------------------------- /test/idle.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async-test) 2 | (in-suite cl-async-test-core) 3 | 4 | (test idle 5 | "Test idling." 6 | (multiple-value-bind (count) 7 | (async-let ((count 0)) 8 | (test-timeout 5) 9 | (let* ((idler nil) 10 | (idle-cb (lambda () 11 | (incf count) 12 | (when (<= 517 count) 13 | (as:free-idler idler))))) 14 | (setf idler (as:idle idle-cb)))) 15 | (is (= count 517)))) 16 | 17 | -------------------------------------------------------------------------------- /test/pipe.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async-test) 2 | (in-suite cl-async-test-core) 3 | 4 | (test pipe-simple-client-server 5 | "Test both pipe-connect and pipe-server" 6 | (multiple-value-bind (server-reqs server-data connect-num client-replies client-data) 7 | (async-let ((server-reqs 0) 8 | (server-data "") 9 | (connect-num 0) 10 | (client-replies 0) 11 | (client-data "")) 12 | (test-timeout 3) 13 | (with-path-under-tmpdir (path "blabla") 14 | (as:pipe-server 15 | path 16 | (lambda (sock data) 17 | (incf server-reqs) 18 | (setf server-data (concat server-data (babel:octets-to-string data))) 19 | (as:write-socket-data sock "thxlol ")) 20 | :connect-cb (lambda (sock) 21 | (declare (ignore sock)) 22 | (incf connect-num))) 23 | 24 | (loop repeat 2 25 | ;; split request "hai " up between pipe-connect and write-socket-data 26 | do (let ((sock (as:pipe-connect 27 | path 28 | (lambda (sock data) 29 | (incf client-replies) 30 | (unless (as:socket-closed-p sock) 31 | (as:close-socket sock)) 32 | (setf client-data (concat client-data (babel:octets-to-string data)))) 33 | :event-cb (lambda (ev) (error ev)) 34 | :data "ha"))) 35 | (as:write-socket-data sock "i ")))) 36 | 37 | (as:delay (lambda () (as:exit-event-loop)) 38 | :time 1)) 39 | (is (= server-reqs 2) "number of server requests") 40 | (is (string= server-data "hai hai ") "received server data") 41 | (is (= connect-num 2) "number of connections (from connect-cb)") 42 | (is (= client-replies 2) "number of replies sent to client") 43 | (is (string= client-data "thxlol thxlol ") "received client data"))) 44 | 45 | (test pipe-connect-fail 46 | "Make sure a pipe connection fails" 47 | (let ((num-err 0)) 48 | (signals as:streamish-enoent 49 | (async-let () 50 | (test-timeout 2) 51 | (with-path-under-tmpdir (path "nosuchpipe") 52 | (as:pipe-connect 53 | path 54 | (lambda (sock data) (declare (ignore sock data))) 55 | :event-cb (lambda (ev) 56 | (incf num-err) 57 | (error ev)) 58 | :data "hai" 59 | :read-timeout 1)))) 60 | (is (= num-err 1)))) 61 | 62 | (test pipe-server-close 63 | "Make sure a pipe-server closes gracefully" 64 | (multiple-value-bind (closedp) 65 | (async-let ((closedp nil)) 66 | (test-timeout 3) 67 | (with-path-under-tmpdir (path "blabla") 68 | (let* ((server (as:pipe-server 69 | path 70 | (lambda (sock data) (declare (ignore sock data))) 71 | :event-cb (lambda (ev) (declare (ignore ev)))))) 72 | (assert server () "failed to listen at port 41818") 73 | (as:pipe-connect 74 | path 75 | (lambda (sock data) (declare (ignore sock data))) 76 | :event-cb (lambda (ev) (declare (ignore ev))) 77 | :connect-cb 78 | (lambda (sock) 79 | (as:delay 80 | (lambda () 81 | (let ((closed-pre (as::socket-server-closed server))) 82 | (as:close-socket sock) 83 | (as:delay 84 | (lambda () 85 | (setf closedp (and closed-pre 86 | (as::socket-server-closed server))))))) 87 | :time 1))) 88 | (as:delay (lambda () (as:close-socket-server server)) :time .1)))) 89 | (is-true closedp))) 90 | 91 | (test pipe-server-stream 92 | "Make sure a pipe-server stream functions properly" 93 | (multiple-value-bind (server-data) 94 | (async-let ((server-data nil)) 95 | (test-timeout 3) 96 | (with-path-under-tmpdir (path "blabla") 97 | (as:pipe-server 98 | path 99 | (lambda (sock stream) 100 | (let ((buff (make-array 1024 :element-type '(unsigned-byte 8)))) 101 | (loop for n = (read-sequence buff stream) 102 | while (< 0 n) do 103 | (setf server-data (concat server-data (babel:octets-to-string (subseq buff 0 n)))))) 104 | (as:close-socket sock) 105 | (as:exit-event-loop)) 106 | :event-cb (lambda (ev) (declare (ignore ev))) 107 | :stream t) 108 | (as:pipe-connect 109 | path 110 | (lambda (sock data) (declare (ignore sock data))) 111 | :event-cb (lambda (ev) (declare (ignore ev))) 112 | :data "HELLO!"))) 113 | (is (string= server-data "HELLO!")))) 114 | -------------------------------------------------------------------------------- /test/poll.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async-test) 2 | (in-suite cl-async-test-core) 3 | 4 | (defun get-usocket-fd (connection) 5 | "Gets the fd from a usocket connection." 6 | (let* ((type (type-of connection)) 7 | (stream (cond ((subtypep type 'usocket:stream-usocket) 8 | (usocket:socket-stream connection)) 9 | ((subtypep type 'stream) 10 | connection)))) 11 | (when stream 12 | #+sbcl 13 | (sb-sys:fd-stream-fd stream) 14 | #+cmu 15 | (system:fd-stream-fd stream) 16 | #+ccl 17 | (ccl::ioblock-device (ccl::stream-ioblock stream t)) 18 | #+clisp 19 | (ext:stream-handles stream)))) 20 | 21 | (test poll-fd 22 | "Make sure polling a file descriptor works." 23 | (multiple-value-bind (response) 24 | (async-let ((response nil)) 25 | (test-timeout 5) 26 | (let (server) 27 | (setf server (as:tcp-server nil 31311 28 | (lambda (sock data) 29 | (as:write-socket-data sock (concat (babel:octets-to-string data) " lol")) 30 | (as:close-tcp-server server)) 31 | :event-cb (lambda (ev) (declare (ignore ev))))) 32 | (as:with-delay (.1) 33 | (let* ((sock (usocket:socket-connect "127.0.0.1" 31311 :element-type 'octet)) 34 | (stream (usocket:socket-stream sock)) 35 | (fd (get-usocket-fd sock)) 36 | (poller nil) 37 | (poll-cb (lambda (events) 38 | (declare (ignore events)) 39 | (as:with-delay () 40 | (usocket:socket-close sock) 41 | (as:free-poller poller)) 42 | (when (listen stream) 43 | (let* ((buff (make-array 7 :element-type 'octet)) 44 | (len (read-sequence buff stream))) 45 | (setf response (babel:octets-to-string (subseq buff 0 len)))))))) 46 | (setf poller (as:poll fd poll-cb :poll-for '(:readable) :socket t)) 47 | (write-sequence (babel:string-to-octets "omg") stream) 48 | (force-output stream))))) 49 | (is (string= response "omg lol")))) 50 | -------------------------------------------------------------------------------- /test/process.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async-test) 2 | (in-suite cl-async-test-core) 3 | 4 | (test spawn-simple 5 | (with-test-event-loop () 6 | (test-timeout 3) 7 | (with-path-under-tmpdir (path "blabla") 8 | (let (process) 9 | (setf process 10 | (as:spawn "touch" (list (namestring path)) 11 | :exit-cb (called-once 12 | #'(lambda (act-process exit-status term-signal) 13 | (is-true (uiop:file-exists-p path)) 14 | (is (eq process act-process)) 15 | (is (= 0 exit-status)) 16 | (is (= 0 term-signal)))))))))) 17 | 18 | (test spawn-redirect-output 19 | (with-test-event-loop () 20 | (test-timeout 3) 21 | (let ((bytes (make-array 0 :element-type 'octet)) 22 | process input output error-output) 23 | (multiple-value-setq (process input output error-output) 24 | (as:spawn "cat" '() 25 | :input (list :pipe :data "hello") 26 | :exit-cb (called-once 27 | #'(lambda (proc exit-status term-signal) 28 | (is (eq process proc)) 29 | (is (= 0 exit-status)) 30 | (is (= 0 term-signal)))) 31 | :output (list :pipe 32 | :read-cb #'(lambda (pipe data) 33 | (is (eq output pipe)) 34 | (setf bytes (concatenate '(vector octet) data)))))) 35 | (is (null error-output)) 36 | (is (not (null output))) 37 | (is (eq input (as:process-input process))) 38 | (is (eq output (as:process-output process))) 39 | (is (eq error-output (as:process-error-output process))) 40 | (as:write-socket-data input (format nil "--42--")) 41 | (wait (string= "hello--42--" (babel:octets-to-string bytes))) 42 | (as:close-socket input)))) 43 | 44 | (test spawn-redirect-error-output 45 | (with-test-event-loop () 46 | (test-timeout 3) 47 | (let ((bytes (make-array 0 :element-type 'octet)) 48 | process input output error-output) 49 | (multiple-value-setq (process input output error-output) 50 | (as:spawn "bash" '("-c" "cat 1>&2") 51 | :input (list :pipe :data "hello") 52 | :exit-cb (called-once 53 | #'(lambda (proc exit-status term-signal) 54 | (is (eq process proc)) 55 | (is (= 0 exit-status)) 56 | (is (= 0 term-signal)))) 57 | :error-output (list :pipe 58 | :read-cb #'(lambda (pipe data) 59 | (is (eq error-output pipe)) 60 | (setf bytes (concatenate '(vector octet) data)))))) 61 | (is (not (null error-output))) 62 | (is (null output)) 63 | (is (eq input (as:process-input process))) 64 | (is (eq output (as:process-output process))) 65 | (is (eq error-output (as:process-error-output process))) 66 | (as:write-socket-data input (format nil "--42--")) 67 | (wait (string= "hello--42--" (babel:octets-to-string bytes))) 68 | (as:close-socket input)))) 69 | 70 | (test spawn-redirect-stream 71 | (with-test-event-loop () 72 | (test-timeout 3) 73 | (let ((bytes (make-array 0 :element-type 'octet)) 74 | process input output error-output) 75 | (multiple-value-setq (process input output error-output) 76 | (as:spawn "cat" '() 77 | :input (list :stream :data "hello") 78 | :exit-cb (called-once 79 | #'(lambda (proc exit-status term-signal) 80 | (is (eq process proc)) 81 | (is (= 0 exit-status)) 82 | (is (= 0 term-signal)))) 83 | :output (list :stream 84 | :read-cb #'(lambda (pipe stream) 85 | (is (eq (as:streamish output) pipe)) 86 | (let ((buf (make-array 128 :element-type 'octet))) 87 | (loop for n = (read-sequence buf stream) 88 | while (plusp n) do 89 | (setf bytes (concatenate 90 | '(vector octet) 91 | bytes 92 | (subseq buf 0 n))))))))) 93 | (is (null error-output)) 94 | (is (not (null output))) 95 | (is (eq input (as:process-input process))) 96 | (is (eq output (as:process-output process))) 97 | (is (eq error-output (as:process-error-output process))) 98 | (write-sequence (babel:string-to-octets (format nil "--42--")) input) 99 | (wait (string= "hello--42--" (babel:octets-to-string bytes))) 100 | (close input)))) 101 | 102 | (test spawn-exec-failure () 103 | (signals as:filesystem-enoent 104 | (with-test-event-loop () 105 | (with-path-under-tmpdir (path "blabla") 106 | (as:spawn path '() :exit-cb #'never) 107 | (as:with-delay (1) nil))))) 108 | 109 | (test process-kill () 110 | (with-test-event-loop () 111 | (let (process) 112 | (test-timeout 3) 113 | (setf process (as:spawn "cat" '() 114 | :exit-cb (called-once 115 | #'(lambda (proc exit-status term-signal) 116 | (is (eq process proc)) 117 | (is (= 0 exit-status)) 118 | (is (= 2 term-signal)))) 119 | :input (list :pipe))) 120 | ;; send SIGINT 121 | (as:process-kill process 2)))) 122 | 123 | (test process-env 124 | (with-test-event-loop () 125 | (with-temporary-directory (dir) 126 | (test-timeout 3) 127 | (let ((env "$HOME/.shinit") 128 | (dir-without-final-slash 129 | (subseq (namestring dir) 0 (1- (length (namestring dir))))) 130 | (bytes (make-array 0 :element-type 'octet))) 131 | (as:spawn "bash" '("-c" "echo -n $ENV $PWD") 132 | :output (list :pipe 133 | :read-cb #'(lambda (pipe data) 134 | (declare (ignore pipe)) 135 | (setf bytes (concatenate '(vector octet) data)))) 136 | :env `(("ENV" . ,env)) 137 | :working-directory dir) 138 | 139 | ;; the folder on macOS has a '/private' prefixed when it got the data from the process. 140 | ;; i.e: 141 | ;; /private/var/folders/2z/831jl36d01317d4pz3g2_j100000gn/T/as-tst-rXjQJL 142 | ;; /var/folders/2z/831jl36d01317d4pz3g2_j100000gn/T/as-tst-rXjQJL 143 | (wait (let* ((actual-string (babel:octets-to-string bytes)) 144 | (expected-string (format nil "$HOME/.shinit ~A" dir-without-final-slash)) 145 | (mac-expected-string (format nil "$HOME/.shinit /private~A" dir-without-final-slash))) 146 | (or (string= expected-string actual-string) 147 | (string= mac-expected-string actual-string)))))))) 148 | -------------------------------------------------------------------------------- /test/run.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async-test) 2 | 3 | (defun run-tests (&key ssl threading) 4 | (run! 'cl-async-test-core) 5 | (when ssl 6 | (unless (find-package :cl-async-ssl) 7 | (asdf:oos 'asdf:load-op :cl-async-ssl)) 8 | (load (asdf:system-relative-pathname :cl-async #P"test/tcp-ssl")) 9 | (run! 'cl-async-ssl-test)) 10 | (when threading 11 | (run! 'cl-async-threading-test))) 12 | 13 | -------------------------------------------------------------------------------- /test/signal.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async-test) 2 | (in-suite cl-async-test-core) 3 | 4 | ;;; signals are a bitch because 5 | ;;; a) lisp has no native way of sending signals 6 | ;;; b) windows doesn't really support them. 7 | ;;; 8 | ;;; so, testing signal handlers is going to take some extra thought. in the 9 | ;;; meantime, we can make sure the functions at least run... 10 | 11 | (test signal-handler-add-remove 12 | "Test a signal handler adds, and removing it ends the event loop" 13 | (multiple-value-bind (start end) 14 | (async-let ((start (get-internal-real-time)) 15 | (end :blank)) 16 | (as:signal-handler as:+sigint+ 17 | (lambda (sig) (declare (ignore sig)))) 18 | (as:delay (lambda () (as:free-signal-handler as:+sigint+)) 19 | :time 1)) 20 | (setf end (get-internal-real-time)) 21 | (is (<= 0.98 (/ (- end start) internal-time-units-per-second) 1.02)))) 22 | -------------------------------------------------------------------------------- /test/ssl/certkey: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE----- 2 | MIIDdjCCAl4CCQCOUKWNNfr6WjANBgkqhkiG9w0BAQUFADB9MQswCQYDVQQGEwJV 3 | UzETMBEGA1UECAwKQ2FsaWZvcm5pYTETMBEGA1UEBwwKU2FudGEgQ3J1ejEkMCIG 4 | A1UECgwbTHlvbiBCcm9zLiBFbnRlcnByaXNlcywgTExDMR4wHAYDVQQDDBVjbC1h 5 | c3luYy5seW9uYnJvcy5jb20wHhcNMTQxMTI5MDQzNDIyWhcNMjQxMTI2MDQzNDIy 6 | WjB9MQswCQYDVQQGEwJVUzETMBEGA1UECAwKQ2FsaWZvcm5pYTETMBEGA1UEBwwK 7 | U2FudGEgQ3J1ejEkMCIGA1UECgwbTHlvbiBCcm9zLiBFbnRlcnByaXNlcywgTExD 8 | MR4wHAYDVQQDDBVjbC1hc3luYy5seW9uYnJvcy5jb20wggEiMA0GCSqGSIb3DQEB 9 | AQUAA4IBDwAwggEKAoIBAQDJ0CVb85esDfPTI4AYBvjEin5fhT4np3AiBb8yen8I 10 | VE3i0357YCleHiVekrHkyQdWHF2CkPjse9D3ryoQH+eBX/eu3EAA30hfdhhfzWED 11 | 1WHJO0GnxKwWaFQ5cWNaPYgQatUh/yc8MJ796DcXnrXidEOO7dJeK+PWjeL5HETo 12 | V72zh1lhSbajKx/G/t+0NNLVM3jMJ5AuCry9raLRzUFEoyt97kPg21IaMWWYQpUP 13 | gHxRuNwerXfyC7T4rJDR2ijOiG6IT6tBG+5yTS7bAnlQj7TVP3bSbeQ0tZIjH0TU 14 | 2wkNVYofSqqh0goBESG/f1YKuNDa/7jyWTrFz/QtnGRxAgMBAAEwDQYJKoZIhvcN 15 | AQEFBQADggEBAMiv0T5MZ2ouTUPZC3aoniZfeRotIIUjEiJXtqAARYG/PD9gChKz 16 | 4FBgARZjST8bB7+anW96ZZQs0WVwspCc54zctct0De5uvdtc/P6ZXWPV68/HJySZ 17 | 4jSJIl1USzHcHzTBp8m3gjqURQgV+B2yKC296y6nqSr9lqsxIB6JwCMb2QxaIcJJ 18 | w9aahzCjj6IYZcXfFTiN2T8hzQskbSa11yVQJVXhIRkDQ/vQ4Y3d349U2swdS37v 19 | y+gRrcIwKs1vNtN9cEOcdJF2rF3DdYrZ4gq9PfltGThp2ACclvmfcNbeF+Y2dcoy 20 | mzqDnA5Q+QGQrGr3TOYSkiFn82HmZ8O39CI= 21 | -----END CERTIFICATE----- 22 | -----BEGIN RSA PRIVATE KEY----- 23 | MIIEpAIBAAKCAQEAydAlW/OXrA3z0yOAGAb4xIp+X4U+J6dwIgW/Mnp/CFRN4tN+ 24 | e2ApXh4lXpKx5MkHVhxdgpD47HvQ968qEB/ngV/3rtxAAN9IX3YYX81hA9VhyTtB 25 | p8SsFmhUOXFjWj2IEGrVIf8nPDCe/eg3F5614nRDju3SXivj1o3i+RxE6Fe9s4dZ 26 | YUm2oysfxv7ftDTS1TN4zCeQLgq8va2i0c1BRKMrfe5D4NtSGjFlmEKVD4B8Ubjc 27 | Hq138gu0+KyQ0doozohuiE+rQRvuck0u2wJ5UI+01T920m3kNLWSIx9E1NsJDVWK 28 | H0qqodIKAREhv39WCrjQ2v+48lk6xc/0LZxkcQIDAQABAoIBABA1t8p69mPLexoq 29 | b89+P90Jgr0JZsSonkkdTQ4w6KMyok7lzfL69leo9Dd0cPV/cCdqf9hM7LGSAGbk 30 | muxQo7ewjaRt7HYleRqx0aNgS7qTGRegutVO5sOl/Z3fjath5dvruNLSO8SJ4zth 31 | u4saJGHcFNEWKR+HRvWkz+ZSbvZ6cSGZ3R5OYGewTf0IdnzH4RdSm7d82NsXvnuP 32 | +KTetJzHzxahSVNI57TKzEkO/Dq04vI63h/Lz5d3JfC9KA4yFnR1dQm2eMxVwFRx 33 | 8VJ8mFWDuQKV6sYMAdgNJipevlgL3x+LCt+gIq626BAzcsbIdWPKdL7rJWfC6lS7 34 | j+MDLwECgYEA76T8g21aqChPg9qhakl0cwhzCIK+BazVWC289BT7rlCGLnF/RJz3 35 | kJaho91y9RzbWr0nA+NpIai52XnFxHTyu3fJzQUGW8tFpCnn7ZOahIh/YpR9JGiB 36 | 2Nuf6ZeOWaLIP4BdJPayDQkIfqyThLEM0eG9YBlJlwbRa1tSZLCGGvUCgYEA15Yt 37 | hjARWzfnyGfFjg/Kl9zph+rYBEhggGnjQAJ92sJ85cfw8dCev0qjKEDgfHYXoNhf 38 | P/r6ciOkdrw42dEgyA9bWTA/EqF7abCNb8AdgkvBzaqijDDKM5zUYiYsHjiUYkjH 39 | pTkt5sutM9XgShQgON2DMg0xpICGJviZWRcBLg0CgYAwpdV8+J4GtOgvZBqQcQjq 40 | sTRo7eGVVViZ5e8NvZS59i7HDtM/In4/I9T8ZuAHUixVZ0CcUXXuF0pjE41KLFN6 41 | Kv8UV4jK6aDhioBCgkxDy1HQuUQOOAjj9PGpgdKr75enDG/cKRhL/SF0VaQ8s5Re 42 | puzCrV97AS9SE9/OAOe4YQKBgQCjFQ/K+oGmp1vG1fkzxe5TguGF17khRD775R3r 43 | Rfc+jPE+QUmbI11zB1r1EF7Ax/SH0CX9mDXsMdovl6LJ4tERhcxsY3rS9SUOhmf3 44 | qTSpY/VvRy0/L4lGEdT3ijjFg7d7weKEsgRvGpQjKh9I6oCVg7vDGQf8kNzqjhQy 45 | uJxD4QKBgQCxUKKp6zOrlP/U9hBn1/qAEz8znInVuIgY02jg/2rhOnHnDi/Cn5NZ 46 | ajzj4Fdxx11hJ7vfo1BQengmRyAaflkcMvmdzNiW2W+jn0ND3wi7rXMbIRJuHmjT 47 | 6K2b/n2RESq23UtrkL+kKl9EbbOkH57jzj27DdlSggnszLk3OGdRFA== 48 | -----END RSA PRIVATE KEY----- 49 | -------------------------------------------------------------------------------- /test/tcp-ssl.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async-test) 2 | (def-suite cl-async-ssl-test :in cl-async-test 3 | :description "cl-async ssl test suite") 4 | (in-suite cl-async-ssl-test) 5 | 6 | (test tcp-ssl-simple-client-server 7 | "Test a simple client/server implementation over SSL" 8 | (multiple-value-bind (server-reqs server-data connect-num client-replies client-data) 9 | (async-let ((server-reqs 0) 10 | (server-data "") 11 | (connect-num 0) 12 | (client-replies 0) 13 | (client-data "")) 14 | (test-timeout 3) 15 | 16 | (as-ssl:tcp-ssl-server nil 31389 17 | (lambda (sock data) 18 | (incf server-reqs) 19 | (setf server-data (concat server-data (babel:octets-to-string data))) 20 | (as:write-socket-data sock "thxlol ")) 21 | :certificate (asdf:system-relative-pathname :cl-async #P"test/ssl/certkey") 22 | :key (asdf:system-relative-pathname :cl-async #P"test/ssl/certkey") 23 | :connect-cb (lambda (sock) 24 | (declare (ignore sock)) 25 | (incf connect-num))) 26 | 27 | (as:delay 28 | (lambda () 29 | (dolist (addr '("127.0.0.1" "localhost")) 30 | ;; split request "hai " up between tcp-ssl-connect and write-socket-data 31 | (let* ((sock (as-ssl:tcp-ssl-connect addr 31389 32 | (lambda (sock data) 33 | (incf client-replies) 34 | (unless (as:socket-closed-p sock) 35 | (as:close-socket sock)) 36 | (setf client-data (concat client-data (babel:octets-to-string data)))) 37 | :event-cb 38 | (lambda (ev) (error ev)) 39 | :data "ha"))) 40 | (as:write-socket-data sock "i ")))) 41 | :time .2) 42 | 43 | (as:delay (lambda () (as:exit-event-loop)) 44 | :time 2)) 45 | (is (= server-reqs 2) "number of server requests: ~s != ~s" server-reqs 2) 46 | (is (string= server-data "hai hai ") "received server data: ~s != ~s" server-data "hai hai ") 47 | (is (= connect-num 2) "number of connections (from connect-cb): ~s != ~s" connect-num 2) 48 | (is (= client-replies 2) "number of replies sent to client: ~s != ~s" client-replies 2) 49 | (is (string= client-data "thxlol thxlol ") "received client data: ~s != ~s" client-data "thxlol thxlol "))) 50 | 51 | -------------------------------------------------------------------------------- /test/tcp.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async-test) 2 | (in-suite cl-async-test-core) 3 | 4 | ;; TODO: timeouts (integer, float) 5 | 6 | (test tcp-simple-client-server 7 | "Test both tcp-connect and tcp-server" 8 | (multiple-value-bind (server-reqs server-data connect-num client-replies client-data) 9 | (async-let ((server-reqs 0) 10 | (server-data "") 11 | (connect-num 0) 12 | (client-replies 0) 13 | (client-data "")) 14 | (test-timeout 3) 15 | 16 | (as:tcp-server nil 31388 17 | (lambda (sock data) 18 | (incf server-reqs) 19 | (setf server-data (concat server-data (babel:octets-to-string data))) 20 | (as:write-socket-data sock "thxlol ")) 21 | :connect-cb (lambda (sock) 22 | (declare (ignore sock)) 23 | (incf connect-num))) 24 | 25 | (dolist (addr '("127.0.0.1" "localhost")) 26 | ;; split request "hai " up between tcp-connect and write-socket-data 27 | (let ((sock (as:tcp-connect addr 31388 28 | (lambda (sock data) 29 | (incf client-replies) 30 | (unless (as:socket-closed-p sock) 31 | (as:close-socket sock)) 32 | (setf client-data (concat client-data (babel:octets-to-string data)))) 33 | :event-cb (lambda (ev) (error ev)) 34 | :data "ha"))) 35 | (as:write-socket-data sock "i "))) 36 | 37 | (as:delay (lambda () (as:exit-event-loop)) 38 | :time 1)) 39 | (is (= server-reqs 2) "number of server requests") 40 | (is (string= server-data "hai hai ") "received server data") 41 | (is (= connect-num 2) "number of connections (from connect-cb)") 42 | (is (= client-replies 2) "number of replies sent to client") 43 | (is (string= client-data "thxlol thxlol ") "received client data"))) 44 | 45 | (test tcp-connect-fail 46 | "Make sure a tcp connection fails" 47 | (let ((num-err 0) 48 | (caught-p nil)) 49 | ;; FIXME: trying to connect to the unrouteable 50 | ;; address sometimes gives ETIMEDOUT and sometimes ECONNREFUSED 51 | (handler-case 52 | (async-let () 53 | (test-timeout 2) 54 | (as:tcp-connect "1.24.3.4" 9090 55 | (lambda (sock data) (declare (ignore sock data))) 56 | :event-cb 57 | (lambda (ev) 58 | (incf num-err) 59 | (error ev)) 60 | :data "hai" 61 | :read-timeout 1)) 62 | (as:tcp-timeout () 63 | (setf caught-p t)) 64 | (as:tcp-refused () 65 | (setf caught-p t))) 66 | (is-true caught-p) 67 | (is (= num-err 1)))) 68 | 69 | (test tcp-server-close 70 | "Make sure a tcp-server closes gracefully" 71 | (multiple-value-bind (closedp) 72 | (async-let ((closedp nil)) 73 | (test-timeout 3) 74 | (let* ((server (as:tcp-server nil 41818 75 | (lambda (sock data) (declare (ignore sock data))) 76 | :event-cb (lambda (ev) (declare (ignore ev)))))) 77 | (assert server () "failed to listen at port 41818") 78 | (as:tcp-connect "127.0.0.1" 41818 79 | (lambda (sock data) (declare (ignore sock data))) 80 | :event-cb (lambda (ev) (declare (ignore ev))) 81 | :connect-cb 82 | (lambda (sock) 83 | (as:delay 84 | (lambda () 85 | (let ((closed-pre (as::tcp-server-closed server))) 86 | (as:close-socket sock) 87 | (as:delay 88 | (lambda () 89 | (setf closedp (and closed-pre 90 | (as::tcp-server-closed server))))))) 91 | :time 1))) 92 | (as:delay (lambda () (as:close-tcp-server server)) :time .1))) 93 | (is-true closedp))) 94 | 95 | (test tcp-server-stream 96 | "Make sure a tcp-server stream functions properly" 97 | (multiple-value-bind (server-data) 98 | (async-let ((server-data nil)) 99 | (test-timeout 3) 100 | (as:tcp-server nil 41818 101 | (lambda (sock stream) 102 | (let ((buff (make-array 1024 :element-type '(unsigned-byte 8)))) 103 | (loop for n = (read-sequence buff stream) 104 | while (< 0 n) do 105 | (setf server-data (concat server-data (babel:octets-to-string (subseq buff 0 n)))))) 106 | (as:close-socket sock) 107 | (as:exit-event-loop)) 108 | :event-cb (lambda (ev) (declare (ignore ev))) 109 | :stream t) 110 | (as:tcp-connect "127.0.0.1" 41818 111 | (lambda (sock data) (declare (ignore sock data))) 112 | :event-cb (lambda (ev) (declare (ignore ev))) 113 | :data "HELLO!")) 114 | (is (string= server-data "HELLO!")))) 115 | 116 | (test test-address-in-use 117 | "Test SOCKET-ADDRESS-IN-USE error" 118 | (multiple-value-bind (first-successful-p) 119 | (async-let ((first-successful-p nil)) 120 | (flet ((make-server () 121 | (as:tcp-server nil 41818 122 | (lambda (sock stream) (declare (ignore sock stream))) 123 | :event-cb #'error))) 124 | (let ((server (make-server))) 125 | (setf first-successful-p t) 126 | (signals as:socket-address-in-use 127 | (make-server)) 128 | (as:close-tcp-server server)))) 129 | (is-true first-successful-p))) 130 | 131 | (defun sha256 (byte-array) 132 | (let ((byte-array (if (typep byte-array '(simple-array (unsigned-byte 8) (*))) 133 | byte-array 134 | (coerce byte-array '(simple-array (unsigned-byte 8) (*))))) 135 | (hasher (ironclad:make-digest :sha256))) 136 | (ironclad:update-digest hasher byte-array) 137 | (ironclad:byte-array-to-hex-string (ironclad:produce-digest hasher)))) 138 | 139 | #| 140 | (test no-overlap 141 | "Make sure that requests/responses don't overlap." 142 | (format t "~%---~%") 143 | (multiple-value-bind (res) 144 | (async-let ((res (make-hash-table :test #'eq)) 145 | (size (+ as:*buffer-size* 20000)) 146 | (num-clients 4) 147 | (num-recv 0) 148 | (server nil)) 149 | (test-timeout 20) 150 | 151 | (setf server 152 | (as:tcp-server nil 31389 153 | (lambda (sock data) 154 | (unless (getf (as:socket-data sock) :id) 155 | (setf (getf (as:socket-data sock) :id) (aref data 0))) 156 | (unless (getf (as:socket-data sock) :bytes) 157 | (setf (getf (as:socket-data sock) :bytes) 0)) 158 | (let ((id (getf (as:socket-data sock) :id)) 159 | (undupe (remove-duplicates data))) 160 | (assert (and (= (length undupe) 1) 161 | (= (aref undupe 0) id))) 162 | (incf (getf (as:socket-data sock) :bytes) (length data)) 163 | (when (<= size (getf (as:socket-data sock) :bytes)) 164 | (format t "server: send: ~a ~a~%" id (* size 1)) 165 | (as:write-socket-data 166 | sock 167 | (make-array (* size 1) :initial-element id :element-type 'as:octet)) 168 | (incf num-recv) 169 | (when (<= num-clients num-recv) 170 | (as:with-delay () 171 | (format t "close server: t~%") 172 | (as:close-tcp-server server)))))))) 173 | 174 | (dotimes (i num-clients) 175 | (let* ((x i) 176 | (data (make-array size 177 | :initial-element x 178 | :element-type '(unsigned-byte 8)))) 179 | (format t "client: send: ~a ~a~%" x (length data)) 180 | (as:tcp-connect "127.0.0.1" 31389 181 | (lambda (sock data) 182 | (declare (ignorable sock)) 183 | (push data (gethash x res)) 184 | (format t "client: recv: ~a ~a ~a~%" x (length data) 185 | (reduce (lambda (acc x) (+ acc (length x))) (gethash x res) :initial-value 0))) 186 | :data data)))) 187 | (format t "res done~%")(force-output) 188 | (loop for x being the hash-keys of res 189 | for v being the hash-values of res do 190 | (let ((stream (flexi-streams:make-in-memory-output-stream :element-type '(unsigned-byte 8)))) 191 | (dolist (part v) 192 | (write-sequence part stream)) 193 | (let ((bytes (flexi-streams:get-output-stream-sequence stream)) 194 | (is-eq t)) 195 | (dotimes (i (length bytes)) 196 | (unless (= (aref bytes 0) (aref bytes i)) 197 | (setf is-eq nil) 198 | (return))) 199 | (is (eq is-eq t))))))) 200 | 201 | (setf *debug-on-error* t) 202 | (run! 'no-overlap) 203 | |# 204 | 205 | (test write-seq-with-offset 206 | "Make sure writing subsequences to a socket works properly" 207 | (with-test-event-loop () 208 | (test-timeout 3) 209 | (let* ((server-data "") 210 | (server 211 | (as:tcp-server nil 31388 212 | (lambda (sock data) 213 | (declare (ignore sock)) 214 | (setf server-data (concat server-data (babel:octets-to-string data)))))) 215 | (sock 216 | (as:tcp-connect "localhost" 31388 217 | (lambda (sock data) 218 | (declare (ignore sock data))) 219 | :event-cb (lambda (ev) (error ev)) 220 | :connect-cb (lambda (socket) 221 | ;; avoid flushing the data after the delay 222 | (as:with-delay () 223 | (as:write-socket-data socket "qqqabcddd" 224 | :start 3 :end 6) 225 | (as:write-socket-data socket "def")))))) 226 | (wait (when (string= "abcdef" server-data) 227 | (as:close-socket sock) 228 | (as:close-tcp-server server) 229 | t))))) 230 | -------------------------------------------------------------------------------- /test/threading.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-async-test) 2 | (def-suite cl-async-threading-test :in cl-async-test :description "threading tests") 3 | (in-suite cl-async-threading-test) 4 | 5 | (test threading-delay 6 | "Test we can run a delay from outside the event loop." 7 | (let ((delay-val 0) 8 | (notifier nil)) 9 | (bt:make-thread 10 | (lambda () 11 | (sleep 2) 12 | (as:trigger-notifier notifier))) 13 | (as:with-event-loop () 14 | (setf notifier (as:make-notifier 15 | (lambda () (incf delay-val 42)))) 16 | (as:with-delay (2) 17 | (incf delay-val 69))) 18 | (is (= (+ 42 69) delay-val)))) 19 | 20 | -------------------------------------------------------------------------------- /test/util.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-async-test 2 | (:use :cl :fiveam :cl-async-base :cl-async-util) 3 | (:export #:run-tests 4 | #:benchmark-server 5 | #:benchmark-client)) 6 | (in-package :cl-async-test) 7 | 8 | ;; Exclude 5am check failures from normal cl-async error handling. 9 | ;; This makes it possible to use (is ...) and related operations 10 | ;; in cl-async callbacks inside tests. 11 | (pushnew '5am::check-failure cl-async-util:*passthrough-errors*) 12 | 13 | ;; TODO: test all functions in util package 14 | 15 | (defmacro async-let ((&rest bindings) &body body) 16 | "Wrap an async op inside of a let/start-event-loop block to mimick a blocking 17 | action. Bindings must be set from withing the block via setf." 18 | `(let ,bindings 19 | (as:with-event-loop (:catch-app-errors nil) 20 | ,@body) 21 | (values ,@(loop for (binding . nil) in bindings collect binding)))) 22 | 23 | (defun test-timeout (seconds) 24 | "Make sure a test times out after the given num seconds. An event loop can't 25 | do this itself without skewing results. Uses event base IDs to make sure it 26 | doesn't cancel an event loop that test-timeout wasn't called inside of." 27 | (let ((cancel nil) 28 | (notifier (as:make-notifier (lambda () (error "test timeout"))))) 29 | (as:unref notifier) 30 | ;; if the event loop exits naturally, cancel the break 31 | (as:add-event-loop-exit-callback 32 | (lambda () 33 | (setf cancel t) 34 | (unless (as:notifier-freed-p notifier) 35 | (as:free-notifier notifier)))) 36 | ;; spawn the thread to kill the event loop 37 | (handler-case 38 | (bt:make-thread (lambda () 39 | (sleep seconds) 40 | (when (not cancel) 41 | (as:trigger-notifier notifier)))) 42 | (bt::bordeaux-mp-condition () 43 | nil)))) 44 | 45 | (defun concat (&rest args) 46 | "Shortens string concatenation because I'm lazy and really who the hell wants 47 | to type out (concatenate 'string ...) seriously, I mispell concatentate like 48 | 90% of the time I type it out." 49 | (apply #'concatenate 'string args)) 50 | 51 | (defun id (val) 52 | "Returns val. Yes, yes. I know that the identity function exists, but 53 | seriously I'm not going to waste precious time out of my life typing identity 54 | when I can just type id. The idea is the same, and everybody KNOWS what I'm 55 | trying to express. 56 | 57 | Oh one more thing: the only reason I NEED identi...err, id is because Eos 58 | can't use its `is` macro around another macro. So I need a function to wrap 59 | it. Lame. BUT such is life." 60 | val) 61 | 62 | (defun call-with-temporary-directory (thunk) 63 | (as:mkdtemp (uiop:merge-pathnames* 64 | "as-tst-XXXXXX" 65 | (uiop:temporary-directory)) 66 | #'(lambda (dir) 67 | (as:add-event-loop-exit-callback 68 | #'(lambda () 69 | (uiop:delete-directory-tree 70 | dir 71 | :validate #'(lambda (path) 72 | (uiop:subpathp path (uiop:temporary-directory)))))) 73 | (funcall thunk dir)))) 74 | 75 | (defmacro with-temporary-directory ((dir) &body body) 76 | `(call-with-temporary-directory #'(lambda (,dir) ,@body))) 77 | 78 | (defmacro with-path-under-tmpdir ((path-var subpath) &body body) 79 | (alexandria:with-gensyms (dir) 80 | `(with-temporary-directory (,dir) 81 | (let ((,path-var (uiop:merge-pathnames* ,subpath ,dir))) 82 | ,@body)))) 83 | 84 | (defvar *later-list*) 85 | 86 | (defun later (function) 87 | "Execute the specified FUNCTION after event loop of WITH-TEST-EVENT-LOOP 88 | terminates." 89 | ;; using as:add-event-loop-exit-callback depends on event loop 90 | ;; actually calling it, which may not be a good assumption 91 | ;; for tests 92 | (push function *later-list*)) 93 | 94 | (defmacro with-test-event-loop ((&key (catch-app-errors nil)) &body body) 95 | "Run BODY within event loop, executing functions specified via LATER 96 | after it terminates. Can be used with CALLED-ONCE and NEVER." 97 | (alexandria:with-gensyms (fn) 98 | `(let ((*later-list* '())) 99 | (as:with-event-loop (:catch-app-errors ,catch-app-errors) 100 | ,@body) 101 | (dolist (,fn (nreverse *later-list*)) 102 | (funcall ,fn))))) 103 | 104 | (defun called-once (function) 105 | "Wrap FUNCTION to make sure that it's called exactly once during 106 | execution of WITH-TEST-EVENT-LOOP body." 107 | (let ((count 0)) 108 | (later #'(lambda () 109 | (is (= 1 count) 110 | "callback is expected to be called once, ~ 111 | but it was called ~d time~:p" count))) 112 | #'(lambda (&rest args) 113 | (incf count) 114 | (apply function args)))) 115 | 116 | (defun never (&rest args) 117 | "NEVER function is for use as a callback that should be never 118 | called. Use in the dynamic context of WITH-TEST-EVENT-LOOP." 119 | (declare (ignore args)) 120 | (fail "'never' function called (unexpected callbacl)")) 121 | 122 | (defparameter *wait-interval* 0.05) 123 | 124 | (defun %wait (pred) 125 | (let ((wait-successful-p nil)) 126 | (labels ((wait-for-it () 127 | (if (funcall pred) 128 | (setf wait-successful-p t) 129 | (as:delay #'wait-for-it :time *wait-interval*)))) 130 | (wait-for-it) 131 | (unless wait-successful-p 132 | (later #'(lambda () 133 | (is-true wait-successful-p "WAIT failed"))))))) 134 | 135 | (defmacro wait (expr) 136 | `(%wait #'(lambda () ,expr))) 137 | 138 | ;; define the test suite 139 | (def-suite cl-async-test :description "cl-async test suite") 140 | (def-suite cl-async-test-core :in cl-async-test :description "cl-async test suite") 141 | (in-suite cl-async-test-core) 142 | 143 | (test data-pointers 144 | "Make sure data pointers are #'eql" 145 | (let* ((raw-pointer (cl-async-util:create-data-pointer)) 146 | (pointer1 (make-pointer-eql-able raw-pointer)) 147 | (pointer2 (make-pointer-eql-able raw-pointer))) 148 | (is (eql pointer1 pointer2)))) 149 | 150 | (test ipv4-address 151 | "Test IPV4 address formatting" 152 | (is (ipv4-address-p "127.0.0.1")) 153 | (is (ipv4-address-p "192.168.0.1")) 154 | (is (ipv4-address-p "74.125.224.104")) 155 | (is (ipv4-address-p "255.255.255.0")) 156 | (is (not (ipv4-address-p "hai"))) 157 | (is (not (ipv4-address-p "i'm larry"))) 158 | (is (not (ipv4-address-p "127.0.4."))) 159 | (is (not (ipv4-address-p "80.80.80.257"))) 160 | (is (not (ipv4-address-p ""))) 161 | (is (not (ipv4-address-p "1.2.3.4.5")))) 162 | 163 | (test ipv6-address 164 | "Test IPV6 address formatting" 165 | (is (ipv6-address-p "fe80:0000:0000:0000:0204:61ff:fe9d:f156")) 166 | (is (ipv6-address-p "fe80:0:0:0:204:61ff:fe9d:f156")) 167 | (is (ipv6-address-p "fe80::204:61ff:fe9d:f156")) 168 | ;; no ipv4 dotted at end for now. 169 | ;(is (ipv6-address-p "fe80:0000:0000:0000:0204:61ff:254.157.241.86")) 170 | ;(is (ipv6-address-p "fe80:0:0:0:0204:61ff:254.157.241.86")) 171 | ;(is (ipv6-address-p "fe80::204:61ff:254.157.241.86")) 172 | (is (ipv6-address-p "::1")) 173 | (is (ipv6-address-p "fe80::")) 174 | (is (ipv6-address-p "2001::")) 175 | (is (not (ipv6-address-p "hai::"))) 176 | (is (not (ipv6-address-p "omg::lol:wtf::"))) 177 | (is (not (ipv6-address-p "sexrobot.sexrobot"))) 178 | (is (not (ipv6-address-p "ge80::"))) 179 | (is (not (ipv6-address-p "fe80:0000:0000:0000:02046:61ff:fe9d:f156"))) 180 | (is (not (ipv6-address-p "f:80:0000:0000:0000:0204:61ff:fe9d:f156")))) 181 | 182 | (test pointer-callbacks 183 | "Test that pointer callbacks are assigned and also cleared correctly" 184 | (let* ((*event-base* (make-instance 'event-base)) 185 | (*data-registry* (event-base-data-registry *event-base*)) 186 | (*function-registry* (event-base-function-registry *event-base*)) 187 | (fn (lambda (x) (1+ x))) 188 | (fn-size (if (event-base-function-registry *event-base*) 189 | (hash-table-count (event-base-function-registry *event-base*)) 190 | 0)) 191 | (data-pointer (create-data-pointer))) 192 | (save-callbacks data-pointer (list :test fn)) 193 | (is (= (funcall (getf (get-callbacks data-pointer) :test) 6) 7)) 194 | (free-pointer-data data-pointer) 195 | (is (null (get-callbacks data-pointer))) 196 | (is (= fn-size (hash-table-count (event-base-function-registry *event-base*)))))) 197 | 198 | (test pointer-data 199 | "Test that pointer data is assigned and also cleared correctly" 200 | (let* ((*event-base* (make-instance 'event-base)) 201 | (*data-registry* (event-base-data-registry *event-base*)) 202 | (*function-registry* (event-base-function-registry *event-base*)) 203 | (my-data (make-hash-table :size 5)) 204 | (data-size (if (event-base-data-registry *event-base*) 205 | (hash-table-count (event-base-data-registry *event-base*)) 206 | 0)) 207 | (data-pointer (create-data-pointer))) 208 | (attach-data-to-pointer data-pointer my-data) 209 | (is (equal my-data (deref-data-from-pointer data-pointer))) 210 | (free-pointer-data data-pointer) 211 | (is (null (deref-data-from-pointer data-pointer))) 212 | (is (= data-size (hash-table-count (event-base-data-registry *event-base*)))))) 213 | --------------------------------------------------------------------------------