server.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) 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-packet-size+)
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 ,element-type))
20 ,@(when reuse-address `(:reuse-address ,reuse-address)))))
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 Server")) socket)
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-byte 8) :initial-element 0))
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) arguments)))
65 (when reply
66 (replace buffer reply)
67 (let ((n (socket-send socket buffer (length reply)
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* *remote-port*) (get-peer-name client-socket)
94 (apply function (socket-stream client-socket) arguments))
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 `(:element-type ,element-type)))))
102 (client-stream (socket-stream client-socket)))
103 (if multi-threading
104 (bt:make-thread (lambda () (apply real-function client-socket arguments))
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))))