server.lisp - clic - Clic is an command line interactive client for gopher writ… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
server.lisp (4900B) | |
--- | |
1 ;;;; See LICENSE for licensing information. | |
2 | |
3 (in-package :usocket) | |
4 | |
5 (defvar *server*) | |
6 | |
7 (defun socket-server (host port function &optional arguments | |
8 &key in-new-thread (protocol :stream) | |
9 ;; for udp | |
10 (timeout 1) (max-buffer-size +max-datagram-pa… | |
11 ;; for tcp | |
12 element-type (reuse-address t) multi-threading | |
13 name) | |
14 (let* ((real-host (or host *wildcard-host*)) | |
15 (socket (ecase protocol | |
16 (:stream | |
17 (apply #'socket-listen | |
18 `(,real-host ,port | |
19 ,@(when element-type `(:element-type ,eleme… | |
20 ,@(when reuse-address `(:reuse-address ,reu… | |
21 (:datagram | |
22 (socket-connect nil nil :protocol :datagram | |
23 :local-host real-host | |
24 :local-port port))))) | |
25 (labels ((real-call () | |
26 (ecase protocol | |
27 (:stream | |
28 (tcp-event-loop socket function arguments | |
29 :element-type element-type | |
30 :multi-threading multi-threading)) | |
31 (:datagram | |
32 (udp-event-loop socket function arguments | |
33 :timeout timeout | |
34 :max-buffer-size max-buffer-size))))) | |
35 (if in-new-thread | |
36 (values (bt:make-thread #'real-call :name (or name "USOCKET Se… | |
37 (progn | |
38 (setq *server* socket) | |
39 (real-call)))))) | |
40 | |
41 (defvar *remote-host*) | |
42 (defvar *remote-port*) | |
43 | |
44 (defun default-udp-handler (buffer) ; echo | |
45 (declare (type (simple-array (unsigned-byte 8) *) buffer)) | |
46 buffer) | |
47 | |
48 (defun udp-event-loop (socket function &optional arguments | |
49 &key timeout max-buffer-size) | |
50 (let ((buffer (make-array max-buffer-size :element-type '(unsigned-byt… | |
51 (sockets (list socket))) | |
52 (unwind-protect | |
53 (loop do | |
54 (multiple-value-bind (return-sockets real-time) | |
55 (wait-for-input sockets :timeout timeout) | |
56 (declare (ignore return-sockets)) | |
57 (when real-time | |
58 (multiple-value-bind (recv n *remote-host* *remote-port*) | |
59 (socket-receive socket buffer max-buffer-size) | |
60 (declare (ignore recv)) | |
61 (if (plusp n) | |
62 (progn | |
63 (let ((reply | |
64 (apply function (subseq buffer 0 n) argumen… | |
65 (when reply | |
66 (replace buffer reply) | |
67 (let ((n (socket-send socket buffer (length re… | |
68 :host *remote-host* | |
69 :port *remote-port*))) | |
70 (when (minusp n) | |
71 (error "send error: ~A~%" n)))))) | |
72 (error "receive error: ~A" n)))) | |
73 #+scl (when thread:*quitting-lisp* (return)) | |
74 #+(and cmu mp) (mp:process-yield))) | |
75 (socket-close socket) | |
76 (values)))) | |
77 | |
78 (defun default-tcp-handler (stream) ; null | |
79 (declare (type stream stream)) | |
80 (format stream "Hello world!~%")) | |
81 | |
82 (defun echo-tcp-handler (stream) | |
83 (loop | |
84 (when (listen stream) | |
85 (let ((line (read-line stream nil))) | |
86 (write-line line stream) | |
87 (force-output stream))))) | |
88 | |
89 (defun tcp-event-loop (socket function &optional arguments | |
90 &key element-type multi-threading) | |
91 (let ((real-function #'(lambda (client-socket &rest arguments) | |
92 (unwind-protect | |
93 (multiple-value-bind (*remote-host* *remo… | |
94 (apply function (socket-stream client-s… | |
95 (close (socket-stream client-socket)) | |
96 (socket-close client-socket) | |
97 nil)))) | |
98 (unwind-protect | |
99 (loop do | |
100 (let* ((client-socket (apply #'socket-accept | |
101 `(,socket ,@(when element-type `(… | |
102 (client-stream (socket-stream client-socket))) | |
103 (if multi-threading | |
104 (bt:make-thread (lambda () (apply real-function client-s… | |
105 :name "USOCKET Client") | |
106 (prog1 (apply real-function client-socket arguments) | |
107 (close client-stream) | |
108 (socket-close client-socket))) | |
109 #+scl (when thread:*quitting-lisp* (return)) | |
110 #+(and cmu mp) (mp:process-yield))) | |
111 (socket-close socket) | |
112 (values)))) |