1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
|
;;;; $Id$
;;;; $URL$
(in-package :usocket)
(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 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 (spawn-thread (or name "USOCKET Server") #'real-call) 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))
(terpri stream))
(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
(apply #'spawn-thread "USOCKET Client" real-function client-socket arguments)
(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))))
|
