contrib/server/key.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) 2011 Philippe Brochard <hocwp@free.fr>
  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 :crypt)
  36
  37 (export '(load-new-key
  38           save-new-key
  39           *key*))
  40
  41 (defparameter *key-filename* "/tmp/.clfswm-server.key")
  42
  43 (defparameter *key* "Automatically changed")
  44
  45 (defparameter *initial-key-perms* "0600")
  46 (defparameter *final-key-perms* "0400")
  47
  48
  49
  50
  51 (defun ushell-sh (formatter &rest args)
  52   (labels ((remove-plist (plist &rest keys)
  53              "Remove the keys from the plist.
  54 Useful for re-using the &REST arg after removing some options."
  55              (do (copy rest)
  56                  ((null (setq rest (nth-value 2 (get-properties plist keys))))
  57                   (nreconc copy plist))
  58                (do () ((eq plist rest))
  59                  (push (pop plist) copy)
  60                  (push (pop plist) copy))
  61                (setq plist (cddr plist))))
  62            (urun-prog (prog &rest opts &key args (wait t) &allow-other-keys)
  63              "Common interface to shell. Does not return anything useful."
  64              #+gcl (declare (ignore wait))
  65              (setq opts (remove-plist opts :args :wait))
  66              #+allegro (apply #'excl:run-shell-command (apply #'vector prog prog args)
  67                               :wait wait opts)
  68              #+(and clisp      lisp=cl)
  69              (apply #'ext:run-program prog :arguments args :wait wait opts)
  70              #+(and clisp (not lisp=cl))
  71              (if wait
  72                  (apply #'lisp:run-program prog :arguments args opts)
  73                  (lisp:shell (format nil "~a~{ '~a'~} &" prog args)))
  74              #+cmu (apply #'ext:run-program prog args :wait wait :output *standard-output* opts)
  75              #+gcl (apply #'si:run-process prog args)
  76              #+liquid (apply #'lcl:run-program prog args)
  77              #+lispworks (apply #'sys::call-system-showing-output
  78                                 (format nil "~a~{ '~a'~}~@[ &~]" prog args (not wait))
  79                                 opts)
  80              #+lucid (apply #'lcl:run-program prog :wait wait :arguments args opts)
  81              #+sbcl (apply #'sb-ext:run-program prog args :wait wait :output *standard-output* opts)
  82              #+ecl (apply #'ext:run-program prog args opts)
  83              #+ccl (apply #'ccl:run-program prog args opts)
  84              #-(or allegro clisp cmu gcl liquid lispworks lucid sbcl ccl ecl)
  85              (error "Error: urun-prog not implemented")))
  86     (urun-prog "/bin/sh" :args (list "-c" (apply #'format nil formatter args)))))
  87
  88
  89 (defun save-new-key ()
  90   (when (probe-file *key-filename*)
  91     (delete-file *key-filename*))
  92   (with-open-file (stream *key-filename* :direction :output :if-exists :supersede
  93                           :if-does-not-exist :create)
  94     (format stream "Nothing useful~%"))
  95   (ushell-sh "chmod ~A ~A" *initial-key-perms* *key-filename*)
  96   (setf *key* (generate-key))
  97   (with-open-file (stream *key-filename* :direction :output :if-exists :supersede
  98                           :if-does-not-exist :create)
  99     (format stream "~A~%" *key*))
 100   (ushell-sh "chmod ~A ~A" *final-key-perms* *key-filename*))
 101
 102 (defun load-new-key ()
 103   (if (probe-file *key-filename*)
 104       (with-open-file (stream *key-filename* :direction :input)
 105         (setf *key* (read-line stream nil nil)))
 106       (error "Key file ~S not found" *key-filename*)))
 107
 108