contrib/server/crypt.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) 2012 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 :crypt
  38   (:use :common-lisp)
  39   (:export :crypt
  40            :decrypt
  41            :generate-key))
  42
  43 (in-package :crypt)
  44
  45 (eval-when (:compile-toplevel :load-toplevel :execute)
  46   (defun mkstr (&rest args)
  47     (with-output-to-string (s)
  48       (dolist (a args)
  49         (princ a s))))
  50
  51   (defun symb (&rest args)
  52     (values (intern (apply #'mkstr args)))))
  53
  54
  55
  56 (defmacro circ-loop (binding &body body)
  57   "Loop circularly over some sequences.
  58 binding is a list of (variable sequence).
  59 The loop is the same size of the first sequence.
  60 Each variable binding element is bound to each character in the
  61 sequence in the second element.
  62 See 'test-circ-loop for some usage examples."
  63   (labels ((let-body (prefix list)
  64              (loop for i from 0
  65                 for l in list
  66                 collect `(,(symb prefix "-" i) (coerce ,(second l) 'list))))
  67            (loop-var-name (l)
  68               (symb "LOOP-VAR-" (first l)))
  69            (do-body (prefix list)
  70              (cons (list (loop-var-name (first list))
  71                          (symb prefix "-" 0)
  72                          `(cdr ,(loop-var-name (first list))))
  73                    (loop for i from 1
  74                       for l in (cdr list)
  75                       collect (list (loop-var-name l)
  76                                     (symb prefix "-" i)
  77                                     `(or (cdr ,(loop-var-name l))
  78                                          ,(symb prefix "-" i))))))
  79            (stop-body (list)
  80              (list `(null ,(loop-var-name (first list)))))
  81            (symbol-body (list)
  82              (loop for l in list
  83                 collect `(,(first l) (car ,(loop-var-name l))))))
  84     (let ((prefix (gensym)))
  85       `(let (,@(let-body prefix binding))
  86          (do ,(do-body prefix binding)
  87              ,(stop-body binding)
  88            (symbol-macrolet ,(symbol-body binding)
  89              ,@body))))))
  90
  91 (defun test-circ-loop ()
  92   (print 'first-test)
  93   (circ-loop ((m "Ceci est un test. éàç^# 1234567890")
  94               (k "azerty")
  95               (p "test")
  96               (o "123"))
  97     (print (list m k p o)))
  98   (print 'second-test) (terpri)
  99   (circ-loop ((a #(1 2 3 4 5 6 7 8 9 10))
 100               (b '(1 2 3))
 101               (c "abcd"))
 102     (format t "(~A ~A ~A) " a b c)))
 103
 104
 105
 106 (defun crypt-to-list (msg &optional (size 4))
 107   (let ((len (length msg)))
 108     (when (zerop (mod len size))
 109       (loop for i from 0 below (/ len size)
 110          collect (parse-integer (subseq msg (* i size) (* (1+ i) size)) :radix 16 :junk-allowed t)))))
 111
 112
 113
 114 (defun crypt (msg key)
 115   (with-output-to-string (str)
 116     (circ-loop ((m msg) (k key))
 117       (format str "~4,'0X" (logxor (char-code m) (char-code k))))))
 118
 119
 120 (defun decrypt (msg key)
 121   (with-output-to-string (str)
 122     (circ-loop ((m (crypt-to-list msg 4)) (k key))
 123       (princ (code-char (logxor m (char-code k))) str))))
 124
 125 (defun test ()
 126   (let* ((key "11a3e229084349bc25d97e29393ced1d")
 127          (msg (format nil "~C Ceci est un test. éàç^# 1234567890" (code-char 100)))
 128          (crypt (crypt msg key))
 129          (decrypt (decrypt crypt key)))
 130     (format t "msg:     ~A~%Crypt:   ~A~%Decrypt: ~A~%" msg crypt decrypt)))
 131
 132
 133
 134
 135 (let* ((dic (with-output-to-string (str)
 136               (dotimes (i 26)
 137                 (princ (code-char (+ i (char-code #\a))) str)
 138                 (princ (code-char (+ i (char-code #\A))) str))
 139               (dotimes (i 10)
 140                 (princ (code-char (+ i (char-code #\0))) str))))
 141        (dic-size (length dic)))
 142   (defun generate-key (&optional (min-size 10) (max-size 30))
 143     (let ((length (+ (random (- max-size min-size)) min-size)))
 144       (with-output-to-string (str)
 145         (dotimes (i length)
 146           (princ (aref dic (random dic-size)) str))))))