contrib/server/server.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Utility
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2005 Philippe Brochard <hocwp@free.fr>
   9 ;;;
  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.
  14 ;;;
  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.
  19 ;;;
  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.
  23 ;;;
  24 ;;; --------------------------------------------------------------------------
  25 ;;; Server protocole:
  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.
  30 ;;;
  31 ;;; --------------------------------------------------------------------------
  32
  33
  34 (format t "Loading the clfswm server code... ")
  35
  36 (pushnew (truename (concatenate 'string *contrib-dir* "contrib/" "server/")) asdf:*central-registry*)
  37
  38 (dbg asdf:*central-registry*)
  39
  40 (asdf:oos 'asdf:load-op :clfswm-client)
  41
  42 (in-package :clfswm)
  43
  44 (use-package :crypt)
  45
  46 (defstruct server-socket stream auth form key)
  47
  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)
  52
  53 (defparameter *server-connection* nil)
  54
  55 (defparameter *server-commands* '("bye" "close" "quit" "info" "clear" "ls[d][v|f] [pattern]"))
  56
  57
  58
  59
  60
  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)))
  65   (when show-prompt-p
  66     (server-show-prompt sock)))
  67
  68
  69 (defun server-show-prompt (sock)
  70   (send-to-client sock nil (format nil "~A> " (package-name *package*))))
  71
  72
  73 (defun read-from-client (sock)
  74   (decrypt (read-line (server-socket-stream sock) nil nil) (server-socket-key sock)))
  75
  76
  77
  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*)))
  86
  87 (defun server-show-info (sock)
  88   (send-to-client sock t (format nil "~A" *server-connection*)))
  89
  90
  91 (defun server-clear-connection ()
  92   (dolist (sock *server-connection*)
  93     (handler-case
  94         (send-to-client sock t "Server clear connection in progress.")
  95       (error ()
  96         (server-remove-connection sock)))))
  97
  98
  99 (defun server-show-help (sock)
 100   (send-to-client sock t (format nil "Availables commandes: ~{~S~^, ~}" *server-commands*)))
 101
 102
 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
 110                                                 (if show-doc
 111                                                     (format nil "~&  ~A~&  => ~A"
 112                                                             (documentation symbol 'variable)
 113                                                             (symbol-value symbol))
 114                                                     ""))))
 115               ((and fun-p (fboundp symbol))
 116                (send-to-client sock nil (format nil "~A (function) ~A" symbol
 117                                                 (if show-doc
 118                                                     (documentation symbol 'function)
 119                                                     "")))))))
 120     (send-to-client sock t "Done.")))
 121
 122
 123
 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*))))
 130
 131
 132 (defun server-handle-new-connection ()
 133   (handler-case
 134       (let ((stream (and *server-socket* (port:socket-accept *server-socket* :wait *server-wait-timeout*))))
 135         (when stream
 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*))))
 146               (close stream))))
 147     (error (c)
 148       (format t "Connection rejected: ~A~%" c)
 149       (force-output))))
 150
 151
 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)))
 156   nil)
 157
 158
 159 (defun server-complet-from (sock)
 160   (ignore-errors
 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))))))))
 174
 175
 176
 177
 178
 179 (defun server-eval-form (sock)
 180   (let* ((result nil)
 181          (printed-result
 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))
 187                            (error (condition)
 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) "")))
 192
 193
 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)))
 200
 201 (defun server-handle-auth (sock)
 202   (loop for line = (read-from-client sock)
 203      while line
 204        do
 205        (if (string= line (format nil "~A~A" (server-socket-key sock)
 206                                  (md5:md5 (server-socket-key sock))))
 207            (progn
 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))
 213            (progn
 214              (format t "Connection closed~%")
 215              (close (server-socket-stream sock))))))
 216
 217
 218 (defun server-handle-connection (sock)
 219   (handler-case
 220       (when (listen (server-socket-stream sock))
 221         (if (server-socket-auth sock)
 222             (server-handle-form sock)
 223             (server-handle-auth sock)))
 224     (error (c)
 225       (format t "*** Error: ~A~%" c) (force-output)
 226       (close (server-socket-stream sock))
 227       (setf *server-connection* (remove sock *server-connection*)))))
 228
 229 (defun handle-server ()
 230   (server-handle-new-connection)
 231   (dolist (sock *server-connection*)
 232     (server-handle-connection sock)))
 233
 234
 235
 236 (defun start-server (&optional port)
 237   (when port
 238     (setf *server-port* port))
 239   (setf *server-socket* (port:open-socket-server *server-port*))
 240   (add-hook *loop-hook* 'handle-server)
 241   (format t "*** Server is started on port ~A and is accepting connection only from [~{~A~^, ~}].~2%"
 242           *server-port* *server-allowed-host*)
 243   (save-new-key))
 244
 245
 246
 247
 248 (format t "done.
 249
 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 You can start the client with the '--client' command line option.~%"
 253         *server-allowed-host*
 254         (if (or (null *server-allowed-host*) (= (length *server-allowed-host*) 1))
 255             "is" "are"))
 256
 257 (defun server-parse-cmdline ()
 258   (let ((args (get-command-line-words)))
 259     (when (member "--client" args :test #'string-equal)
 260       (clfswm-client:start-client (remove "--client" args :test #'string-equal))
 261       (uquit))))
 262
 263 (add-hook *main-entrance-hook* 'server-parse-cmdline)
 264