1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Client/server connection.
6 ;;; The connection is crypted and you can only connect to the server with the
7 ;;; same clfswm binary.
8 ;;; --------------------------------------------------------------------------
10 ;;; (C) 2012 Philippe Brochard <pbrochard@common-lisp.net>
12 ;;; This program is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 3 of the License, or
15 ;;; (at your option) any later version.
17 ;;; This program is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with this program; if not, write to the Free Software
24 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
26 ;;; --------------------------------------------------------------------------
28 ;;; Server -> Client: orig_key=a generated key crypted with *key*
29 ;;; Client : build its new_key with orig_key+*key*
30 ;;; Client -> Server: new_key+(md5 new_key) crypted with new_key
31 ;;; Server -> Client: check if the keys match and then authenticate the client.
32 ;;; Server <-> Client: All connections are crypted with new_key
33 ;;; --------------------------------------------------------------------------
37 (defparameter *server-port
* 33333)
39 (format t
"Loading the clfswm server code... ")
41 (pushnew (truename (merge-pathnames "server/" *contrib-dir
*)) asdf
:*central-registry
*)
43 (dbg asdf
:*central-registry
*)
45 (asdf:oos
'asdf
:load-op
:clfswm-client
)
51 (defstruct server-socket stream auth form key
)
52 (defparameter *server-socket
* nil
)
54 (defparameter *server-allowed-host
* '("127.0.0.1"))
55 (defparameter *server-wait-timeout
* 0.001d0
)
57 (defparameter *server-connection
* nil
)
59 (defparameter *server-commands
* '("bye" "close" "quit" "info" "clear" "ls[d][v|f] [pattern]"))
64 (defun server-show-prompt (sock)
65 ;;(send-to-client sock nil (format nil "~A> " (package-name *package*))))
66 (format (server-socket-stream sock
) "~A~%"
67 (crypt (format nil
"~A> " (package-name *package
*)) (server-socket-key sock
)))
68 (force-output (server-socket-stream sock
)))
71 (defun send-to-client (sock show-prompt-p
&rest msg
)
72 (dolist (m (if (consp (car msg
)) (car msg
) msg
))
73 (format (server-socket-stream sock
) "~A~%" (crypt m
(server-socket-key sock
)))
74 (force-output (server-socket-stream sock
)))
76 (server-show-prompt sock
)))
78 ;;(defun server-show-prompt (sock)
79 ;; (send-to-client sock nil (format nil "~A> " (package-name *package*))))
83 (defun read-from-client (sock)
84 (decrypt (read-line (server-socket-stream sock
) nil nil
) (server-socket-key sock
)))
88 (defun server-remove-connection (sock)
89 (send-to-client sock nil
"Connection closed by server")
90 (multiple-value-bind (local-host local-port remote-host remote-port
)
91 (port:socket-host
/port
(server-socket-stream sock
))
92 (declare (ignore local-host local-port
))
93 (format t
"~&Connection from ~A:~A closed.~%" remote-host remote-port
))
94 (close (server-socket-stream sock
))
95 (setf *server-connection
* (remove sock
*server-connection
*)))
97 (defun server-show-info (sock)
98 (send-to-client sock t
(format nil
"~A" *server-connection
*)))
101 (defun server-clear-connection ()
102 (dolist (sock *server-connection
*)
104 (send-to-client sock t
"Server clear connection in progress.")
106 (server-remove-connection sock
)))))
109 (defun server-show-help (sock)
110 (send-to-client sock t
(format nil
"Availables commandes: ~{~S~^, ~}" *server-commands
*)))
113 (defun server-ls (sock line ls-word var-p fun-p
&optional show-doc
)
114 (let* ((pattern (string-trim '(#\space
#\tab
) (subseq (string-trim '(#\space
#\tab
) line
) (length ls-word
))))
115 (all-search (string= pattern
"")))
116 (with-all-internal-symbols (symbol :clfswm
)
117 (when (or all-search
(symbol-search pattern symbol
))
118 (cond ((and var-p
(boundp symbol
))
119 (send-to-client sock nil
(format nil
"~A (variable) ~A" symbol
121 (format nil
"~& ~A~& => ~A"
122 (documentation symbol
'variable
)
123 (symbol-value symbol
))
125 ((and fun-p
(fboundp symbol
))
126 (send-to-client sock nil
(format nil
"~A (function) ~A" symbol
128 (documentation symbol
'function
)
130 (send-to-client sock t
"Done.")))
134 (defun server-is-allowed-host (stream)
135 (multiple-value-bind (local-host local-port remote-host remote-port
)
136 (port:socket-host
/port stream
)
137 (declare (ignore local-host local-port
))
138 (and (member remote-host
*server-allowed-host
* :test
#'string-equal
)
139 (equal remote-port
*server-port
*))))
142 (defun server-handle-new-connection ()
144 (let ((stream (and *server-socket
* (port:socket-accept
*server-socket
* :wait
*server-wait-timeout
*))))
146 (if (server-is-allowed-host stream
)
147 (multiple-value-bind (local-host local-port remote-host remote-port
)
148 (port:socket-host
/port stream
)
149 (declare (ignore local-host local-port
))
150 (format t
"~&New connection from ~A:~A " remote-host remote-port
)
151 (let ((new-sock (make-server-socket :stream stream
:auth nil
:form
"" :key
*key
*))
152 (key (generate-key)))
153 (push new-sock
*server-connection
*)
154 (send-to-client new-sock nil key
)
155 (setf (server-socket-key new-sock
) (concatenate 'string key
*key
*))))
158 (format t
"Connection rejected: ~A~%" c
)
162 (defun server-line-is (line &rest strings
)
163 (dolist (str strings
)
164 (when (string-equal line str
)
165 (return-from server-line-is t
)))
169 (defun server-complet-from (sock)
171 (when (listen (server-socket-stream sock
))
172 (let ((line (read-from-client sock
)))
173 (cond ((server-line-is line
"help") (server-show-help sock
))
174 ((server-line-is line
"bye" "close" "quit") (server-remove-connection sock
))
175 ((server-line-is line
"info") (server-show-info sock
))
176 ((server-line-is line
"clear") (server-clear-connection))
177 ((first-position "lsdv" line
) (server-ls sock line
"lsdv" t nil t
))
178 ((first-position "lsdf" line
) (server-ls sock line
"lsdf" nil t t
))
179 ((first-position "lsd" line
) (server-ls sock line
"lsd" t t t
))
180 ((first-position "lsv" line
) (server-ls sock line
"lsv" t nil nil
))
181 ((first-position "lsf" line
) (server-ls sock line
"lsf" nil t nil
))
182 ((first-position "ls" line
) (server-ls sock line
"ls" t t nil
))
183 (t (setf (server-socket-form sock
) (format nil
"~A~A~%" (server-socket-form sock
) line
))))))))
189 (defun server-eval-form (sock)
192 (with-output-to-string (*standard-output
*)
193 (setf result
(handler-case
194 (loop for i in
(multiple-value-list
195 (eval (read-from-string (server-socket-form sock
))))
196 collect
(format nil
"~S" i
))
198 (format nil
"~A" condition
)))))))
199 (send-to-client sock nil
(ensure-list printed-result
))
200 (send-to-client sock t
(ensure-list result
))
201 (setf (server-socket-form sock
) "")))
204 (defun server-handle-form (sock)
205 (server-complet-from sock
)
206 (if (server-socket-key sock
)
207 (when (ignore-errors (read-from-string (server-socket-form sock
)))
208 (server-eval-form sock
))
209 (server-show-prompt sock
)))
211 (defun server-handle-auth (sock)
212 (loop for line
= (read-from-client sock
)
215 (if (string= line
(format nil
"~A~A" (server-socket-key sock
)
216 (md5:md5
(server-socket-key sock
))))
218 (setf (server-socket-auth sock
) t
)
219 (setf (server-socket-form sock
) (format nil
"~S" "You are now authenticated!"))
220 (server-handle-form sock
)
221 (format t
"Connection accepted~%")
222 (return-from server-handle-auth nil
))
224 (format t
"Connection closed~%")
225 (close (server-socket-stream sock
))))))
228 (defun server-handle-connection (sock)
230 (when (listen (server-socket-stream sock
))
231 (if (server-socket-auth sock
)
232 (server-handle-form sock
)
233 (server-handle-auth sock
)))
235 (format t
"*** Error: ~A~%" c
) (force-output)
236 (close (server-socket-stream sock
))
237 (setf *server-connection
* (remove sock
*server-connection
*)))))
239 (defun handle-server ()
240 (server-handle-new-connection)
241 (dolist (sock *server-connection
*)
242 (server-handle-connection sock
)))
246 (defun start-server (&optional port
)
248 (setf *server-port
* port
))
249 (setf *server-socket
* (port:open-socket-server
*server-port
*))
250 (add-hook *loop-hook
* 'handle-server
)
251 (format t
"*** Server is started on port ~A and is accepting connection only from [~{~A~^, ~}].~2%"
252 *server-port
* *server-allowed-host
*)
260 You can now start a clfswm server with the command (start-server &optional port).
261 Only [~{~A~^, ~}] ~A allowed to login on the server. The connection is crypted.
262 You can start the client with the '--client' command line option.~%"
263 *server-allowed-host
*
264 (if (or (null *server-allowed-host
*) (= (length *server-allowed-host
*) 1))
267 (defun server-parse-cmdline ()
268 (let ((args (get-command-line-words)))
269 (when (member "--client" args
:test
#'string-equal
)
270 (clfswm-client:start-client
(remove "--client" args
:test
#'string-equal
))
273 (defun is-started-as-client-p ()
274 (member "--client" (get-command-line-words) :test
#'string-equal
))
276 (add-hook *main-entrance-hook
* 'server-parse-cmdline
)