sbcl stuff

2020-01-20 14:13:08 -05:00 · 2020-01-20 14:13:08 -05:00 · 5d91dbb667
commit 5d91dbb667
parent 1d1dbc34df
335 changed files with 119806 additions and 1 deletions
--- a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/server.lisp
+++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/server.lisp
@ -0,0 +1,112 @@
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+(defvar *server*)
+
+(defun socket-server (host port function &optional arguments
+                      &key in-new-thread (protocol :stream)
+                           ;; for udp
+                           (timeout 1) (max-buffer-size +max-datagram-packet-size+)
+                           ;; for tcp
+                           element-type (reuse-address t) multi-threading
+                           name)
+  (let* ((real-host (or host *wildcard-host*))
+         (socket (ecase protocol
+                   (:stream
+                    (apply #'socket-listen
+                           `(,real-host ,port
+                             ,@(when element-type `(:element-type ,element-type))
+                             ,@(when reuse-address `(:reuse-address ,reuse-address)))))
+                   (:datagram
+                    (socket-connect nil nil :protocol :datagram
+                                    :local-host real-host
+                                    :local-port port)))))
+    (labels ((real-call ()
+               (ecase protocol
+                 (:stream
+                  (tcp-event-loop socket function arguments
+                                  :element-type element-type
+                                  :multi-threading multi-threading))
+                 (:datagram
+                  (udp-event-loop socket function arguments
+                                  :timeout timeout
+                                  :max-buffer-size max-buffer-size)))))
+      (if in-new-thread
+	  (values (bt:make-thread #'real-call :name (or name "USOCKET Server")) socket)
+	(progn
+	  (setq *server* socket)
+	  (real-call))))))
+
+(defvar *remote-host*)
+(defvar *remote-port*)
+
+(defun default-udp-handler (buffer) ; echo
+  (declare (type (simple-array (unsigned-byte 8) *) buffer))
+  buffer)
+
+(defun udp-event-loop (socket function &optional arguments
+                       &key timeout max-buffer-size)
+  (let ((buffer (make-array max-buffer-size :element-type '(unsigned-byte 8) :initial-element 0))
+        (sockets (list socket)))
+    (unwind-protect
+        (loop do
+          (multiple-value-bind (return-sockets real-time)
+              (wait-for-input sockets :timeout timeout)
+            (declare (ignore return-sockets))
+            (when real-time
+              (multiple-value-bind (recv n *remote-host* *remote-port*)
+                  (socket-receive socket buffer max-buffer-size)
+                (declare (ignore recv))
+                (if (plusp n)
+                    (progn
+                      (let ((reply
+                             (apply function (subseq buffer 0 n) arguments)))
+                        (when reply
+                          (replace buffer reply)
+                          (let ((n (socket-send socket buffer (length reply)
+                                                :host *remote-host*
+                                                :port *remote-port*)))
+                            (when (minusp n)
+                              (error "send error: ~A~%" n))))))
+                  (error "receive error: ~A" n))))
+            #+scl (when thread:*quitting-lisp* (return))
+            #+(and cmu mp) (mp:process-yield)))
+      (socket-close socket)
+      (values))))
+
+(defun default-tcp-handler (stream) ; null
+  (declare (type stream stream))
+  (format stream "Hello world!~%"))
+
+(defun echo-tcp-handler (stream)
+  (loop
+     (when (listen stream)
+       (let ((line (read-line stream nil)))
+	 (write-line line stream)
+	 (force-output stream)))))
+
+(defun tcp-event-loop (socket function &optional arguments
+                       &key element-type multi-threading)
+  (let ((real-function #'(lambda (client-socket &rest arguments)
+                           (unwind-protect
+                               (multiple-value-bind (*remote-host* *remote-port*) (get-peer-name client-socket)
+                                 (apply function (socket-stream client-socket) arguments))
+                             (close (socket-stream client-socket))
+                             (socket-close client-socket)
+                             nil))))
+    (unwind-protect
+        (loop do
+          (let* ((client-socket (apply #'socket-accept
+                                       `(,socket ,@(when element-type `(:element-type ,element-type)))))
+                 (client-stream (socket-stream client-socket)))
+            (if multi-threading
+                (bt:make-thread (lambda () (apply real-function client-socket arguments))
+                                :name "USOCKET Client")
+              (prog1 (apply real-function client-socket arguments)
+                (close client-stream)
+                (socket-close client-socket)))
+            #+scl (when thread:*quitting-lisp* (return))
+            #+(and cmu mp) (mp:process-yield)))
+      (socket-close socket)
+      (values))))