contrib/server/clfswm-client.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 :common-lisp-user)
  36
  37 (defpackage :clfswm-client
  38   (:use :common-lisp :crypt)
  39   (:export :start-client))
  40
  41 (in-package :clfswm-client)
  42
  43 (defun uquit ()
  44   #+(or clisp cmu) (ext:quit)
  45   #+sbcl (sb-ext:quit)
  46   #+ecl (si:quit)
  47   #+gcl (lisp:quit)
  48   #+lispworks (lw:quit)
  49   #+(or allegro-cl allegro-cl-trial) (excl:exit)
  50   #+ccl (ccl:quit))
  51
  52
  53 ;;(defparameter *server-port* 33333)
  54
  55 (defun print-output (sock &optional wait)
  56   (when (or wait (ignore-errors (listen sock)))
  57     (let ((line (ignore-errors (string-trim '(#\newline) (read-line sock nil nil)))))
  58       (when line
  59         (format t "~&~A" (decrypt line *key*))
  60         (force-output)))))
  61
  62
  63 (defun quit-on-command (line sock)
  64   (when (member line '("quit" "close" "bye") :test #'string-equal)
  65     (loop for line = (read-line sock nil nil)
  66        while line
  67        do (format t "~&~A" (decrypt line *key*))
  68          (force-output))
  69     (terpri)
  70     (uquit)))
  71
  72
  73 (defun parse-args (sock args)
  74   (unless (string= args "")
  75     (multiple-value-bind (form pos)
  76         (read-from-string args)
  77       (let ((str (format nil "~A" form)))
  78         (format t "~A~% " str)
  79         (format sock "~A~%" (crypt str *key*))
  80         (force-output sock)
  81         (print-output sock t)
  82         (quit-on-command str sock)
  83         (parse-args sock (subseq args pos))))))
  84
  85
  86 (defun start-client (args &optional (url "127.0.0.1") (port clfswm::*server-port*))
  87   (load-new-key)
  88   (let* ((sock (port:open-socket url port))
  89          (key (string-trim '(#\Newline #\Space) (decrypt (read-line sock nil nil) *key*))))
  90     (setf *key* (concatenate 'string key *key*))
  91     (write-line (crypt (format nil "~A~A" *key* (md5:md5 *key*)) *key*) sock)
  92     (force-output sock)
  93     (print-output sock t)
  94     (dolist (a args)
  95       (parse-args sock a))
  96     (loop
  97        (print-output sock)
  98        (when (listen)
  99          (let ((line (read-line)))
 100            (write-line (crypt line *key*) sock)
 101            (force-output sock)
 102            (quit-on-command line sock)))
 103        (sleep 0.01))))