1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Utility
6 ;;; --------------------------------------------------------------------------
8 ;;; (C) 2005 Philippe Brochard <hocwp@free.fr>
10 ;;; This program is free software; you can redistribute it and/or modify
11 ;;; it under the terms of the GNU General Public License as published by
12 ;;; the Free Software Foundation; either version 3 of the License, or
13 ;;; (at your option) any later version.
15 ;;; This program is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;;; GNU General Public License for more details.
20 ;;; You should have received a copy of the GNU General Public License
21 ;;; along with this program; if not, write to the Free Software
22 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
24 ;;; --------------------------------------------------------------------------
26 ;;; Server -> Client: orig_key=a generated key crypted with *key*
27 ;;; Client : build its new_key with orig_key+*key*
28 ;;; Client -> Server: new_key+(md5 new_key) crypted with new_key
29 ;;; Server -> Client: check if the keys match and then authenticate the client.
31 ;;; --------------------------------------------------------------------------
34 (format t
"Loading the clfswm server code... ")
36 (pushnew (truename (concatenate 'string
*contrib-dir
* "contrib/" "server/")) asdf
:*central-registry
*)
38 (dbg asdf
:*central-registry
*)
40 (asdf:oos
'asdf
:load-op
:util-server
)
46 (defstruct server-socket stream auth form key
)
48 (defparameter *server-socket
* nil
)
49 (defparameter *server-port
* 33333)
50 (defparameter *server-allowed-host
* '("127.0.0.1"))
51 (defparameter *server-wait-timeout
* 0.001d0
)
53 (defparameter *server-connection
* nil
)
55 (defparameter *server-commands
* '("bye" "close" "quit" "info" "clear" "ls[d][v|f] [pattern]"))
61 (defun send-to-client (sock show-prompt-p
&rest msg
)
62 (dolist (m (if (consp (car msg
)) (car msg
) msg
))
63 (format (server-socket-stream sock
) "~A~%" (crypt m
(server-socket-key sock
)))
64 (force-output (server-socket-stream sock
)))
66 (server-show-prompt sock
)))
69 (defun server-show-prompt (sock)
70 (send-to-client sock nil
(format nil
"~A> " (package-name *package
*))))
73 (defun read-from-client (sock)
74 (decrypt (read-line (server-socket-stream sock
) nil nil
) (server-socket-key sock
)))
78 (defun server-remove-connection (sock)
79 (send-to-client sock nil
"Connection closed by server")
80 (multiple-value-bind (local-host local-port remote-host remote-port
)
81 (port:socket-host
/port
(server-socket-stream sock
))
82 (declare (ignore local-host local-port
))
83 (format t
"~&Connection from ~A:~A closed.~%" remote-host remote-port
))
84 (close (server-socket-stream sock
))
85 (setf *server-connection
* (remove sock
*server-connection
*)))
87 (defun server-show-info (sock)
88 (send-to-client sock t
(format nil
"~A" *server-connection
*)))
91 (defun server-clear-connection ()
92 (dolist (sock *server-connection
*)
94 (send-to-client sock t
"Server clear connection in progress.")
96 (server-remove-connection sock
)))))
99 (defun server-show-help (sock)
100 (send-to-client sock t
(format nil
"Availables commandes: ~{~S~^, ~}" *server-commands
*)))
103 (defun server-ls (sock line ls-word var-p fun-p
&optional show-doc
)
104 (let* ((pattern (string-trim '(#\space
#\tab
) (subseq (string-trim '(#\space
#\tab
) line
) (length ls-word
))))
105 (all-search (string= pattern
"")))
106 (with-all-internal-symbols (symbol :clfswm
)
107 (when (or all-search
(symbol-search pattern symbol
))
108 (cond ((and var-p
(boundp symbol
))
109 (send-to-client sock nil
(format nil
"~A (variable) ~A" symbol
111 (format nil
"~& ~A~& => ~A"
112 (documentation symbol
'variable
)
113 (symbol-value symbol
))
115 ((and fun-p
(fboundp symbol
))
116 (send-to-client sock nil
(format nil
"~A (function) ~A" symbol
118 (documentation symbol
'function
)
120 (send-to-client sock t
"Done.")))
124 (defun server-is-allowed-host (stream)
125 (multiple-value-bind (local-host local-port remote-host remote-port
)
126 (port:socket-host
/port stream
)
127 (declare (ignore local-host local-port
))
128 (and (member remote-host
*server-allowed-host
* :test
#'string-equal
)
129 (equal remote-port
*server-port
*))))
132 (defun server-handle-new-connection ()
134 (let ((stream (and *server-socket
* (port:socket-accept
*server-socket
* :wait
*server-wait-timeout
*))))
136 (if (server-is-allowed-host stream
)
137 (multiple-value-bind (local-host local-port remote-host remote-port
)
138 (port:socket-host
/port stream
)
139 (declare (ignore local-host local-port
))
140 (format t
"~&New connection from ~A:~A " remote-host remote-port
)
141 (let ((new-sock (make-server-socket :stream stream
:auth nil
:form
"" :key
*key
*))
142 (key (generate-key)))
143 (push new-sock
*server-connection
*)
144 (send-to-client new-sock nil key
)
145 (setf (server-socket-key new-sock
) (concatenate 'string key
*key
*))))
148 (format t
"Connection rejected: ~A~%" c
)
152 (defun server-line-is (line &rest strings
)
153 (dolist (str strings
)
154 (when (string-equal line str
)
155 (return-from server-line-is t
)))
159 (defun server-complet-from (sock)
161 (when (listen (server-socket-stream sock
))
162 (let ((line (read-from-client sock
)))
163 (cond ((server-line-is line
"help") (server-show-help sock
))
164 ((server-line-is line
"bye" "close" "quit") (server-remove-connection sock
))
165 ((server-line-is line
"info") (server-show-info sock
))
166 ((server-line-is line
"clear") (server-clear-connection))
167 ((first-position "lsdv" line
) (server-ls sock line
"lsdv" t nil t
))
168 ((first-position "lsdf" line
) (server-ls sock line
"lsdf" nil t t
))
169 ((first-position "lsd" line
) (server-ls sock line
"lsd" t t t
))
170 ((first-position "lsv" line
) (server-ls sock line
"lsv" t nil nil
))
171 ((first-position "lsf" line
) (server-ls sock line
"lsf" nil t nil
))
172 ((first-position "ls" line
) (server-ls sock line
"ls" t t nil
))
173 (t (setf (server-socket-form sock
) (format nil
"~A~A~%" (server-socket-form sock
) line
))))))))
179 (defun server-eval-form (sock)
182 (with-output-to-string (*standard-output
*)
183 (setf result
(handler-case
184 (loop for i in
(multiple-value-list
185 (eval (read-from-string (server-socket-form sock
))))
186 collect
(format nil
"~S" i
))
188 (format nil
"~A" condition
)))))))
189 (send-to-client sock nil
(ensure-list printed-result
))
190 (send-to-client sock t
(ensure-list result
))
191 (setf (server-socket-form sock
) "")))
194 (defun server-handle-form (sock)
195 (server-complet-from sock
)
196 (if (server-socket-key sock
)
197 (when (ignore-errors (read-from-string (server-socket-form sock
)))
198 (server-eval-form sock
))
199 (server-show-prompt sock
)))
201 (defun server-handle-auth (sock)
202 (loop for line
= (read-from-client sock
)
205 (if (string= line
(format nil
"~A~A" (server-socket-key sock
)
206 (md5:md5
(server-socket-key sock
))))
208 (setf (server-socket-auth sock
) t
)
209 (setf (server-socket-form sock
) (format nil
"~S" "You are now authenticated!"))
210 (server-handle-form sock
)
211 (format t
"Connection accepted~%")
212 (return-from server-handle-auth nil
))
214 (format t
"Connection closed~%")
215 (close (server-socket-stream sock
))))))
218 (defun server-handle-connection (sock)
220 (when (listen (server-socket-stream sock
))
221 (if (server-socket-auth sock
)
222 (server-handle-form sock
)
223 (server-handle-auth sock
)))
225 (format t
"*** Error: ~A~%" c
) (force-output)
226 (close (server-socket-stream sock
))
227 (setf *server-connection
* (remove sock
*server-connection
*)))))
229 (defun handle-server ()
230 (server-handle-new-connection)
231 (dolist (sock *server-connection
*)
232 (server-handle-connection sock
)))
236 (defun start-server (&optional port
)
239 (setf *server-port
* port
))
240 (setf *server-socket
* (port:open-socket-server
*server-port
*))
241 (add-hook *loop-hook
* 'handle-server
)
242 (format t
"*** Server is started on port ~A and is accepting connection only from [~{~A~^, ~}].~2%"
243 *server-port
* *server-allowed-host
*))
250 You can now start a clfswm server with the command (start-server &optional port).
251 Only [~{~A~^, ~}] ~A allowed to login on the server~%"
252 *server-allowed-host
*
253 (if (or (null *server-allowed-host
*) (= (length *server-allowed-host
*) 1))