contrib/server/server.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   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 ;;; --------------------------------------------------------------------------
   9 ;;;
  10 ;;; (C) 2015 Philippe Brochard <pbrochard@common-lisp.net>
  11 ;;;
  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.
  16 ;;;
  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.
  21 ;;;
  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.
  25 ;;;
  26 ;;; --------------------------------------------------------------------------
  27 ;;; Server protocole:
  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 ;;; --------------------------------------------------------------------------
  34
  35 (in-package :clfswm)
  36
  37 (defparameter *server-port* 33333)
  38
  39 (format t "Loading the clfswm server code... ")
  40
  41 (pushnew (truename (merge-pathnames "server/" *contrib-dir*)) asdf:*central-registry*)
  42
  43 (dbg asdf:*central-registry*)
  44
  45 (asdf:oos 'asdf:load-op :clfswm-client)
  46
  47 (in-package :clfswm)
  48
  49 (use-package :crypt)
  50
  51 (defstruct server-socket stream auth form key)
  52 (defparameter *server-socket* nil)
  53
  54 (defparameter *server-allowed-host* '("127.0.0.1"))
  55 (defparameter *server-wait-timeout* 0.001d0)
  56
  57 (defparameter *server-connection* nil)
  58
  59 (defparameter *server-commands* '("bye" "close" "quit" "info" "clear" "ls[d][v|f] [pattern]"))
  60
  61
  62
  63
  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)))
  69
  70
  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)))
  75   (when show-prompt-p
  76     (server-show-prompt sock)))
  77
  78 ;;(defun server-show-prompt (sock)
  79 ;;  (send-to-client sock nil (format nil "~A> " (package-name *package*))))
  80
  81
  82
  83 (defun read-from-client (sock)
  84   (decrypt (read-line (server-socket-stream sock) nil nil) (server-socket-key sock)))
  85
  86
  87
  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*)))
  96
  97 (defun server-show-info (sock)
  98   (send-to-client sock t (format nil "~A" *server-connection*)))
  99
 100
 101 (defun server-clear-connection ()
 102   (dolist (sock *server-connection*)
 103     (handler-case
 104         (send-to-client sock t "Server clear connection in progress.")
 105       (error ()
 106         (server-remove-connection sock)))))
 107
 108
 109 (defun server-show-help (sock)
 110   (send-to-client sock t (format nil "Availables commandes: ~{~S~^, ~}" *server-commands*)))
 111
 112
 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
 120                                                 (if show-doc
 121                                                     (format nil "~&  ~A~&  => ~A"
 122                                                             (documentation symbol 'variable)
 123                                                             (symbol-value symbol))
 124                                                     ""))))
 125               ((and fun-p (fboundp symbol))
 126                (send-to-client sock nil (format nil "~A (function) ~A" symbol
 127                                                 (if show-doc
 128                                                     (documentation symbol 'function)
 129                                                     "")))))))
 130     (send-to-client sock t "Done.")))
 131
 132
 133
 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*))))
 140
 141
 142 (defun server-handle-new-connection ()
 143   (handler-case
 144       (let ((stream (and *server-socket* (port:socket-accept *server-socket* :wait *server-wait-timeout*))))
 145         (when stream
 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*))))
 156               (close stream))))
 157     (error (c)
 158       (format t "Connection rejected: ~A~%" c)
 159       (force-output))))
 160
 161
 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)))
 166   nil)
 167
 168
 169 (defun server-complet-from (sock)
 170   (ignore-errors
 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))))))))
 184
 185
 186
 187
 188
 189 (defun server-eval-form (sock)
 190   (let* ((result nil)
 191          (printed-result
 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))
 197                            (error (condition)
 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) "")))
 202
 203
 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)))
 210
 211 (defun server-handle-auth (sock)
 212   (loop for line = (read-from-client sock)
 213      while line
 214        do
 215        (if (string= line (format nil "~A~A" (server-socket-key sock)
 216                                  (md5:md5 (server-socket-key sock))))
 217            (progn
 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))
 223            (progn
 224              (format t "Connection closed~%")
 225              (close (server-socket-stream sock))))))
 226
 227
 228 (defun server-handle-connection (sock)
 229   (handler-case
 230       (when (listen (server-socket-stream sock))
 231         (if (server-socket-auth sock)
 232             (server-handle-form sock)
 233             (server-handle-auth sock)))
 234     (error (c)
 235       (format t "*** Error: ~A~%" c) (force-output)
 236       (close (server-socket-stream sock))
 237       (setf *server-connection* (remove sock *server-connection*)))))
 238
 239 (defun handle-server ()
 240   (server-handle-new-connection)
 241   (dolist (sock *server-connection*)
 242     (server-handle-connection sock)))
 243
 244
 245
 246 (defun start-server (&optional port)
 247   (when 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*)
 253   (save-new-key))
 254
 255
 256
 257
 258 (format t "done.
 259
 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))
 265             "is" "are"))
 266
 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))
 271       (uquit))))
 272
 273 (defun is-started-as-client-p ()
 274   (member "--client" (get-command-line-words) :test #'string-equal))
 275
 276 (add-hook *main-entrance-hook* 'server-parse-cmdline)