From bb375a7bd82f62c3a7d1be23f4f8800a3d8f0203 Mon Sep 17 00:00:00 2001 From: Philippe Brochard Date: Thu, 12 Aug 2010 23:21:20 +0200 Subject: [PATCH] Add a clfswm server/client --- contrib/README | 4 +- contrib/server/.svn/entries | 217 ++++++++ contrib/server/.svn/props/configure.svn-work | 5 + contrib/server/.svn/props/test.sh.svn-work | 5 + contrib/server/.svn/props/test2.sh.svn-work | 5 + contrib/server/Makefile | 49 ++ contrib/server/Makefile.template | 49 ++ contrib/server/clfswm-client.asd | 20 + contrib/server/clfswm-client.lisp | 81 +++ contrib/server/configure | 129 +++++ contrib/server/crypt.lisp | 112 ++++ contrib/server/key.lisp | 70 +++ contrib/server/load.lisp | 59 ++ contrib/server/md5.lisp | 750 +++++++++++++++++++++++++ contrib/server/net.lisp | 781 +++++++++++++++++++++++++++ contrib/server/server.lisp | 257 +++++++++ contrib/server/test.sh | 7 + contrib/server/test2.sh | 18 + contrib/server/util-server.asd | 23 + 19 files changed, 2639 insertions(+), 2 deletions(-) create mode 100644 contrib/server/.svn/entries create mode 100644 contrib/server/.svn/props/configure.svn-work create mode 100644 contrib/server/.svn/props/test.sh.svn-work create mode 100644 contrib/server/.svn/props/test2.sh.svn-work create mode 100644 contrib/server/Makefile create mode 100644 contrib/server/Makefile.template create mode 100644 contrib/server/clfswm-client.asd create mode 100644 contrib/server/clfswm-client.lisp create mode 100755 contrib/server/configure create mode 100644 contrib/server/crypt.lisp create mode 100644 contrib/server/key.lisp create mode 100644 contrib/server/load.lisp create mode 100644 contrib/server/md5.lisp create mode 100644 contrib/server/net.lisp create mode 100644 contrib/server/server.lisp create mode 100755 contrib/server/test.sh create mode 100755 contrib/server/test2.sh create mode 100644 contrib/server/util-server.asd diff --git a/contrib/README b/contrib/README index b13ed7f..974d845 100644 --- a/contrib/README +++ b/contrib/README @@ -1,9 +1,9 @@ The contrib directory is here if you want to contribute to CLFSWM and if your code is not merged in the clfswm core. -To contribute, place your files in the contrib directory. +To contribute, place your files in the contrib directory. You can have your own repository and tell me if you want to merge it -in the clfswm svn. +in the clfswm svn/git. To use a contributed code add a line like this in your configuration file: diff --git a/contrib/server/.svn/entries b/contrib/server/.svn/entries new file mode 100644 index 0000000..7113923 --- /dev/null +++ b/contrib/server/.svn/entries @@ -0,0 +1,217 @@ +10 + +dir +0 +svn+ssh://pbrochard@common-lisp.net/project/clfswm/svn/clfswm/contrib/server +svn+ssh://pbrochard@common-lisp.net/project/clfswm/svn +add + + + + + + + + + + + + + + + + + + + +a42fa774-7830-0410-a598-a0bf735cded7 + +clfswm-client.fas +file + + + +add + +configure +file + + + +add + + + + + +has-props +has-prop-mods + +load.lisp +file + + + +add + +Makefile.template +file + + + +add + +util-server.asd +file + + + +add + +test.sh +file + + + +add + + + + + +has-props +has-prop-mods + +md5.lib +file + + + +add + +net.lib +file + + + +add + +md5.lisp +file + + + +add + +net.lisp +file + + + +add + +key.lib +file + + + +add + +md5.fas +file + + + +add + +net.fas +file + + + +add + +key.lisp +file + + + +add + +key.fas +file + + + +add + +crypt.lib +file + + + +add + +crypt.lisp +file + + + +add + +crypt.fas +file + + + +add + +test2.sh +file + + + +add + + + + + +has-props +has-prop-mods + +clfswm-client.lib +file + + + +add + +server.lisp +file + + + +add + +clfswm-client.lisp +file + + + +add + +Makefile +file + + + +add + +clfswm-client.asd +file + + + +add + diff --git a/contrib/server/.svn/props/configure.svn-work b/contrib/server/.svn/props/configure.svn-work new file mode 100644 index 0000000..869ac71 --- /dev/null +++ b/contrib/server/.svn/props/configure.svn-work @@ -0,0 +1,5 @@ +K 14 +svn:executable +V 1 +* +END diff --git a/contrib/server/.svn/props/test.sh.svn-work b/contrib/server/.svn/props/test.sh.svn-work new file mode 100644 index 0000000..869ac71 --- /dev/null +++ b/contrib/server/.svn/props/test.sh.svn-work @@ -0,0 +1,5 @@ +K 14 +svn:executable +V 1 +* +END diff --git a/contrib/server/.svn/props/test2.sh.svn-work b/contrib/server/.svn/props/test2.sh.svn-work new file mode 100644 index 0000000..869ac71 --- /dev/null +++ b/contrib/server/.svn/props/test2.sh.svn-work @@ -0,0 +1,5 @@ +K 14 +svn:executable +V 1 +* +END diff --git a/contrib/server/Makefile b/contrib/server/Makefile new file mode 100644 index 0000000..2232103 --- /dev/null +++ b/contrib/server/Makefile @@ -0,0 +1,49 @@ +# -*- makefile -*- +PROJECT_NAME=clfswm-client +DESTDIR=/tmp/local + +LISP=/usr/bin/clisp +EVAL_OPT=-x -q +LOAD_OPT= +EXT=fas +CORE= +EXTRA_OPT= + +all: build + @echo "ALL" + +build: + @echo "Building" + $(LISP) $(CORE) $(EVAL_OPT) '(progn (pushnew :BUILD *features*) (load "load.lisp") (quit))' + @echo "" + @echo "Type 'make install' to install $(PROJECT_NAME) in '$(DESTDIR)/bin/$(PROJECT_NAME)'" + @echo "" + +install: + @echo "1) Installing: Creating directories" + mkdir -p $(DESTDIR)/lib/$(PROJECT_NAME)/ + mkdir -p $(DESTDIR)/bin + @echo "2) Installing: Copying files" + cp -R `pwd`/../asdf.lisp $(DESTDIR)/lib/$(PROJECT_NAME)/ + cp -R `pwd`/*.asd $(DESTDIR)/lib/$(PROJECT_NAME)/ + cp -R `pwd`/*.lisp $(DESTDIR)/lib/$(PROJECT_NAME)/ + @sleep 1 + cp -R `pwd`/*.$(EXT) $(DESTDIR)/lib/$(PROJECT_NAME)/ + @echo "3) Installing: Creating starter script" + echo "#!/bin/sh" > $(DESTDIR)/bin/$(PROJECT_NAME) + echo "$(LISP) $(CORE) $(LOAD_OPT) $(DESTDIR)/lib/$(PROJECT_NAME)/load.lisp $(EXTRA_OPT) \"\$$*\"" >> $(DESTDIR)/bin/$(PROJECT_NAME) + chmod a+x $(DESTDIR)/bin/$(PROJECT_NAME) + @echo "" + @echo "$(PROJECT_NAME) has been installed in '$(DESTDIR)/bin/$(PROJECT_NAME)'" + @echo "" + + +uninstall: + rm -rf $(DESTDIR)/bin/$(PROJECT_NAME) + rm -rf $(DESTDIR)/lib/$(PROJECT_NAME)/ + +clean: + find . \( -name "*~" -o -name "*.fas" -o -name "*.fasl" -o -name "*.lib" -o -name "*.lx32fsl" -o -name "*.x86f" \) -print0 | xargs -0 rm -f + +dist: clean + cd .. && tar czvf $(PROJECT_NAME)-`date +%y%m%d`.tar.gz $(PROJECT_NAME) diff --git a/contrib/server/Makefile.template b/contrib/server/Makefile.template new file mode 100644 index 0000000..91bb5f9 --- /dev/null +++ b/contrib/server/Makefile.template @@ -0,0 +1,49 @@ +# -*- makefile -*- +PROJECT_NAME=+PROJECT_NAME+ +DESTDIR=+DESTDIR+ + +LISP=+LISP+ +EVAL_OPT=+EVAL_OPT+ +LOAD_OPT=+LOAD_OPT+ +EXT=+EXT+ +CORE=+CORE+ +EXTRA_OPT=+EXTRA_OPT+ + +all: build + @echo "ALL" + +build: + @echo "Building" + $(LISP) $(CORE) $(EVAL_OPT) '(progn (pushnew :BUILD *features*) (load "load.lisp") (quit))' + @echo "" + @echo "Type 'make install' to install $(PROJECT_NAME) in '$(DESTDIR)/bin/$(PROJECT_NAME)'" + @echo "" + +install: + @echo "1) Installing: Creating directories" + mkdir -p $(DESTDIR)/lib/$(PROJECT_NAME)/ + mkdir -p $(DESTDIR)/bin + @echo "2) Installing: Copying files" + cp -R `pwd`/../asdf.lisp $(DESTDIR)/lib/$(PROJECT_NAME)/ + cp -R `pwd`/*.asd $(DESTDIR)/lib/$(PROJECT_NAME)/ + cp -R `pwd`/*.lisp $(DESTDIR)/lib/$(PROJECT_NAME)/ + @sleep 1 + cp -R `pwd`/*.$(EXT) $(DESTDIR)/lib/$(PROJECT_NAME)/ + @echo "3) Installing: Creating starter script" + echo "#!/bin/sh" > $(DESTDIR)/bin/$(PROJECT_NAME) + echo "$(LISP) $(CORE) $(LOAD_OPT) $(DESTDIR)/lib/$(PROJECT_NAME)/load.lisp $(EXTRA_OPT) \"\$$*\"" >> $(DESTDIR)/bin/$(PROJECT_NAME) + chmod a+x $(DESTDIR)/bin/$(PROJECT_NAME) + @echo "" + @echo "$(PROJECT_NAME) has been installed in '$(DESTDIR)/bin/$(PROJECT_NAME)'" + @echo "" + + +uninstall: + rm -rf $(DESTDIR)/bin/$(PROJECT_NAME) + rm -rf $(DESTDIR)/lib/$(PROJECT_NAME)/ + +clean: + find . \( -name "*~" -o -name "*.fas" -o -name "*.fasl" -o -name "*.lib" -o -name "*.lx32fsl" -o -name "*.x86f" \) -print0 | xargs -0 rm -f + +dist: clean + cd .. && tar czvf $(PROJECT_NAME)-`date +%y%m%d`.tar.gz $(PROJECT_NAME) diff --git a/contrib/server/clfswm-client.asd b/contrib/server/clfswm-client.asd new file mode 100644 index 0000000..f5eec1f --- /dev/null +++ b/contrib/server/clfswm-client.asd @@ -0,0 +1,20 @@ +;;;; -*- Mode: Lisp -*- +;;;; ASDF System Definition +;;; + +(in-package #:asdf) + +(defsystem clfswm-client + :description "" + :licence "GNU Lesser General Public License (LGPL)" + :components ((:file "clfswm-client")) + :depends-on (util-server)) + + + + + + + + + diff --git a/contrib/server/clfswm-client.lisp b/contrib/server/clfswm-client.lisp new file mode 100644 index 0000000..c33c53a --- /dev/null +++ b/contrib/server/clfswm-client.lisp @@ -0,0 +1,81 @@ +(in-package :common-lisp-user) + +(defpackage :clfswm-client + (:use :common-lisp :crypt)) + +(in-package :clfswm-client) + +(defun args () + #+sbcl (cdr sb-ext:*posix-argv*) + #+(or clozure ccl) (cddddr (ccl::command-line-arguments)) + #+gcl (cdr si:*command-args*) + #+ecl (loop for i from 1 below (si:argc) collect (si:argv i)) + #+cmu (cdddr extensions:*command-line-strings*) + #+allegro (cdr (sys:command-line-arguments)) + #+lispworks (cdr sys:*line-arguments-list*) + #+clisp ext:*args* + #-(or sbcl clozure gcl ecl cmu allegro lispworks clisp) + (error "get-command-line-arguments not supported for your implementation")) + +(defun uquit () + #+(or clisp cmu) (ext:quit) + #+sbcl (sb-ext:quit) + #+ecl (si:quit) + #+gcl (lisp:quit) + #+lispworks (lw:quit) + #+(or allegro-cl allegro-cl-trial) (excl:exit) + #+ccl (ccl:quit)) + + + +(defparameter *server-port* 33333) + +(defun print-output (sock &optional wait) + (when (or wait (ignore-errors (listen sock))) + (let ((line (ignore-errors (string-trim '(#\newline) (read-line sock nil nil))))) + (when line + (format t "~&~A" (decrypt line *key*)) + (force-output))))) + + +(defun quit-on-command (line sock) + (when (member line '("quit" "close" "bye") :test #'string-equal) + (loop for line = (read-line sock nil nil) + while line + do (format t "~&~A" (decrypt line *key*)) + (force-output)) + (terpri) + (uquit))) + + +(defun parse-args (sock args) + (unless (string= args "") + (multiple-value-bind (form pos) + (read-from-string args) + (let ((str (format nil "~A" form))) + (format t "~A~% " str) + (format sock "~A~%" (crypt str *key*)) + (force-output sock) + (print-output sock t) + (quit-on-command str sock) + (parse-args sock (subseq args pos)))))) + + +(defun start-client (&optional (url "127.0.0.1") (port *server-port*)) + (load-new-key) + (let* ((sock (port:open-socket url port)) + (key (string-trim '(#\Newline #\Space) (decrypt (read-line sock nil nil) *key*)))) + (setf *key* (concatenate 'string key *key*)) + (write-line (crypt (format nil "~A~A" *key* (md5:md5 *key*)) *key*) sock) + (force-output sock) + (print-output sock t) + (dolist (a (args)) + (parse-args sock a)) + (loop + (print-output sock) + (when (listen) + (let ((line (read-line))) + (write-line (crypt line *key*) sock) + (force-output sock) + (quit-on-command line sock)))))) + diff --git a/contrib/server/configure b/contrib/server/configure new file mode 100755 index 0000000..f1fe773 --- /dev/null +++ b/contrib/server/configure @@ -0,0 +1,129 @@ +#! /bin/sh + +PROJECT_NAME=clfswm-client +CONFIGURE_VERSION=0.1 + + +usage () { + echo "'configure' configures $PROJECT_NAME to adapt to many kinds of systems. + +Usage: ./configure [OPTION]... [VAR=VALUE]... + +Please, be sure to edit the file key.lisp to change the encryption key. And +protect this file from unwanted eyes. + +Defaults for the options are specified in brackets. + +Configuration: + -h, --help display this help and exit + -V, --version display version information and exit + --with-lisp=LISP use a particular Lisp implementation [ask] + --with-lisp-eval-opt=OPT use a particular Lisp eval command line option + --with-lisp-load-opt=OPT use a particular Lisp load command line option + --with-lisp-ext=OPT use a particular Lisp extension filename + --with-lisp-core=CORE use a particular Lisp core (initial memory image) + --prefix=PREFIX install architecture-independent files in PREFIX + [/usr/local] + +By default, 'make install' will install all the files in +'/usr/local/bin', '/usr/local/lib' etc. You can specify +an installation prefix other than '/usr/local' using '--prefix', +for instance '--prefix=$HOME'." + exit 0 +} + + +version () { + echo "Configure version: $CONFIGURE_VERSION" + exit 0 +} + + + +TEMP=`getopt -o hV: --long help,version,srcdir:,with-lisp:,with-lisp-eval-opt:,with-lisp-load-opt:,with-lisp-ext:,with-lisp-core:,prefix: -- "$@"` +PREFIX=/usr/local + +if [ $? != 0 ] ; then echo "Terminating..." >&2 ; exit 1 ; fi + +eval set -- "$TEMP" + +while true ; do + case "$1" in + -h|--help) usage ; shift ;; + -V|--version) version ; shift ;; + --srcdir) SRCDIR=$2 ; shift 2 ;; + --with-lisp) LISP=$2 ; shift 2 ;; + --with-lisp-eval-opt) EVAL_OPT=$2 ; shift 2 ;; + --with-lisp-load-opt) LOAD_OPT=$2 ; shift 2 ;; + --with-lisp-ext) EXT=$2 ; shift 2 ;; + --with-lisp-core) CORE=$2 ; shift 2 ;; + --prefix) PREFIX=$2 ; shift 2 ;; + --key-perms) KEY_PERMS=$2 ; shift 2 ;; + --) shift ; break ;; + *) echo "Internal error!" ; exit 1 ;; + esac +done + +DESTDIR=$PREFIX + + +if [ "x$LISP" = "x" ]; then + echo "Please, choose a Lisp implementation in: +1) SBCL 2) CMUCL 3) CLISP 4) ECL 5) CCL 6) Other" + read REP_LISP + case $REP_LISP in + 1) LISP=sbcl ;; + 2) LISP=cmucl ;; + 3) LISP=clisp ;; + 4) LISP=ecl ;; + 5) LISP=ccl ;; + 6) echo -n "Please, enter your Lisp implementation: " + read LISP ;; + *) echo "Error"; exit -1 ;; + esac +fi + +EXTRA_OPT="" + +case $LISP in + clisp) LISP=$(which clisp) + EVAL_OPT="-x -q" + LOAD_OPT="" + EXT=fas ;; + sbcl) LISP=$(which sbcl) + EVAL_OPT="--eval" + LOAD_OPT="--load" + EXT=fasl ;; + cmucl) LISP=$(which cmucl) + EVAL_OPT="-eval" + LOAD_OPT="-load" + EXT=x86f ;; + ecl) LISP=$(which ecl) + EVAL_OPT="-eval" + LOAD_OPT="-load" + EXT=fas ;; + ccl) LISP=$(which ccl) + EVAL_OPT="-e" + LOAD_OPT="-l" + EXT=lx32fsl + EXTRA_OPT="--" ;; +esac + +echo "Configuration:" +echo SRCDIR = $SRCDIR +echo PREFIX = $PREFIX +echo "LISP=$LISP EVAL_OPT=$EVAL_OPT LOAD_OPT=$LOAD_OPT EXT=$EXT CORE=$CORE EXTRA_OPT=$EXTRA_OPT" + +sed -e "s#+PROJECT_NAME+#$PROJECT_NAME#g" \ + -e "s#+DESTDIR+#$DESTDIR#g" \ + -e "s#+LISP+#$LISP#g" \ + -e "s#+EVAL_OPT+#$EVAL_OPT#g" \ + -e "s#+LOAD_OPT+#$LOAD_OPT#g" \ + -e "s#+EXT+#$EXT#g" \ + -e "s#+CORE+#$CORE#g" \ + -e "s#+EXTRA_OPT+#$EXTRA_OPT#g" \ + Makefile.template > Makefile + +echo "" +echo "Type 'make' to build $PROJECT_NAME" +echo "" diff --git a/contrib/server/crypt.lisp b/contrib/server/crypt.lisp new file mode 100644 index 0000000..82a47fb --- /dev/null +++ b/contrib/server/crypt.lisp @@ -0,0 +1,112 @@ +(in-package :common-lisp-user) + +(defpackage :crypt + (:use :common-lisp) + (:export :crypt + :decrypt + :generate-key)) + +(in-package :crypt) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun mkstr (&rest args) + (with-output-to-string (s) + (dolist (a args) + (princ a s)))) + + (defun symb (&rest args) + (values (intern (apply #'mkstr args))))) + + + +(defmacro circ-loop (binding &body body) + "Loop circularly over some sequences. +binding is a list of (variable sequence). +The loop is the same size of the first sequence. +Each variable binding element is bound to each character in the +sequence in the second element. +See 'test-circ-loop for some usage examples." + (labels ((let-body (prefix list) + (loop for i from 0 + for l in list + collect `(,(symb prefix "-" i) (coerce ,(second l) 'list)))) + (loop-var-name (l) + (symb "LOOP-VAR-" (first l))) + (do-body (prefix list) + (cons (list (loop-var-name (first list)) + (symb prefix "-" 0) + `(cdr ,(loop-var-name (first list)))) + (loop for i from 1 + for l in (cdr list) + collect (list (loop-var-name l) + (symb prefix "-" i) + `(or (cdr ,(loop-var-name l)) + ,(symb prefix "-" i)))))) + (stop-body (list) + (list `(null ,(loop-var-name (first list))))) + (symbol-body (list) + (loop for l in list + collect `(,(first l) (car ,(loop-var-name l)))))) + (let ((prefix (gensym))) + `(let (,@(let-body prefix binding)) + (do ,(do-body prefix binding) + ,(stop-body binding) + (symbol-macrolet ,(symbol-body binding) + ,@body)))))) + +(defun test-circ-loop () + (print 'first-test) + (circ-loop ((m "Ceci est un test. éàç^# 1234567890") + (k "azerty") + (p "test") + (o "123")) + (print (list m k p o))) + (print 'second-test) (terpri) + (circ-loop ((a #(1 2 3 4 5 6 7 8 9 10)) + (b '(1 2 3)) + (c "abcd")) + (format t "(~A ~A ~A) " a b c))) + + + +(defun crypt-to-list (msg &optional (size 4)) + (let ((len (length msg))) + (when (zerop (mod len size)) + (loop for i from 0 below (/ len size) + collect (parse-integer (subseq msg (* i size) (* (1+ i) size)) :radix 16 :junk-allowed t))))) + + + +(defun crypt (msg key) + (with-output-to-string (str) + (circ-loop ((m msg) (k key)) + (format str "~4,'0X" (logxor (char-code m) (char-code k)))))) + + +(defun decrypt (msg key) + (with-output-to-string (str) + (circ-loop ((m (crypt-to-list msg 4)) (k key)) + (princ (code-char (logxor m (char-code k))) str)))) + +(defun test () + (let* ((key "11a3e229084349bc25d97e29393ced1d") + (msg (format nil "~C Ceci est un test. éàç^# 1234567890" (code-char 100))) + (crypt (crypt msg key)) + (decrypt (decrypt crypt key))) + (format t "msg: ~A~%Crypt: ~A~%Decrypt: ~A~%" msg crypt decrypt))) + + + + +(let* ((dic (with-output-to-string (str) + (dotimes (i 26) + (princ (code-char (+ i (char-code #\a))) str) + (princ (code-char (+ i (char-code #\A))) str)) + (dotimes (i 10) + (princ (code-char (+ i (char-code #\0))) str)))) + (dic-size (length dic))) + (defun generate-key (&optional (min-size 10) (max-size 30)) + (let ((length (+ (random (- max-size min-size)) min-size))) + (with-output-to-string (str) + (dotimes (i length) + (princ (aref dic (random dic-size)) str)))))) diff --git a/contrib/server/key.lisp b/contrib/server/key.lisp new file mode 100644 index 0000000..75faf8b --- /dev/null +++ b/contrib/server/key.lisp @@ -0,0 +1,70 @@ +(in-package :crypt) + +(export '(load-new-key + save-new-key + *key*)) + +(defparameter *key-filename* "/tmp/.clfswm-server.key") + +(defparameter *key* "Automatically changed") + +(defparameter *initial-key-perms* "0600") +(defparameter *final-key-perms* "0400") + + +(defun ushell-sh (formatter &rest args) + (labels ((remove-plist (plist &rest keys) + "Remove the keys from the plist. +Useful for re-using the &REST arg after removing some options." + (do (copy rest) + ((null (setq rest (nth-value 2 (get-properties plist keys)))) + (nreconc copy plist)) + (do () ((eq plist rest)) + (push (pop plist) copy) + (push (pop plist) copy)) + (setq plist (cddr plist)))) + (urun-prog (prog &rest opts &key args (wait t) &allow-other-keys) + "Common interface to shell. Does not return anything useful." + #+gcl (declare (ignore wait)) + (setq opts (remove-plist opts :args :wait)) + #+allegro (apply #'excl:run-shell-command (apply #'vector prog prog args) + :wait wait opts) + #+(and clisp lisp=cl) + (apply #'ext:run-program prog :arguments args :wait wait opts) + #+(and clisp (not lisp=cl)) + (if wait + (apply #'lisp:run-program prog :arguments args opts) + (lisp:shell (format nil "~a~{ '~a'~} &" prog args))) + #+cmu (apply #'ext:run-program prog args :wait wait :output *standard-output* opts) + #+gcl (apply #'si:run-process prog args) + #+liquid (apply #'lcl:run-program prog args) + #+lispworks (apply #'sys::call-system-showing-output + (format nil "~a~{ '~a'~}~@[ &~]" prog args (not wait)) + opts) + #+lucid (apply #'lcl:run-program prog :wait wait :arguments args opts) + #+sbcl (apply #'sb-ext:run-program prog args :wait wait :output *standard-output* opts) + #-(or allegro clisp cmu gcl liquid lispworks lucid sbcl) + (error 'not-implemented :proc (list 'run-prog prog opts)))) + (urun-prog "/bin/sh" :args (list "-c" (apply #'format nil formatter args))))) + + +(defun save-new-key () + (when (probe-file *key-filename*) + (delete-file *key-filename*)) + (with-open-file (stream *key-filename* :direction :output :if-exists :supersede + :if-does-not-exist :create) + (format stream "Nothing useful~%")) + (ushell-sh "chmod ~A ~A" *initial-key-perms* *key-filename*) + (setf *key* (generate-key)) + (with-open-file (stream *key-filename* :direction :output :if-exists :supersede + :if-does-not-exist :create) + (format stream "~A~%" *key*)) + (ushell-sh "chmod ~A ~A" *final-key-perms* *key-filename*)) + +(defun load-new-key () + (if (probe-file *key-filename*) + (with-open-file (stream *key-filename* :direction :input) + (setf *key* (read-line stream nil nil))) + (error "Key file ~S not found" *key-filename*))) + + diff --git a/contrib/server/load.lisp b/contrib/server/load.lisp new file mode 100644 index 0000000..574813b --- /dev/null +++ b/contrib/server/load.lisp @@ -0,0 +1,59 @@ +;;; -------------------------------------------------------------------------- +;;; CLFSWM - FullScreen Window Manager +;;; +;;; -------------------------------------------------------------------------- +;;; Documentation: CLFSWM Client +;;; -------------------------------------------------------------------------- +;;; +;;; (C) 2005 Philippe Brochard +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; -------------------------------------------------------------------------- + +(defparameter *base-dir* (directory-namestring *load-truename*)) +(export '*base-dir*) + +#+CMU +(setf ext:*gc-verbose* nil) + +#+SBCL +(require :asdf) + +#+SBCL +(require :sb-posix) + +#-ASDF +(let ((asdf-file (make-pathname :host (pathname-host *base-dir*) + :device (pathname-device *base-dir*) + :directory (pathname-directory *base-dir*) + :name "asdf" :type "lisp"))) + (if (probe-file asdf-file) + (load asdf-file) + (load (make-pathname :host (pathname-host *base-dir*) + :device (pathname-device *base-dir*) + :directory (butlast (pathname-directory *base-dir*)) + :name "asdf" :type "lisp")))) + +(push *base-dir* asdf:*central-registry*) + +(asdf:oos 'asdf:load-op :clfswm-client) + +(in-package :clfswm-client) + + +#-BUILD +(start-client) + diff --git a/contrib/server/md5.lisp b/contrib/server/md5.lisp new file mode 100644 index 0000000..4d39c8c --- /dev/null +++ b/contrib/server/md5.lisp @@ -0,0 +1,750 @@ +;;;; This file implements The MD5 Message-Digest Algorithm, as defined in +;;;; RFC 1321 by R. Rivest, published April 1992. +;;;; +;;;; It was written by Pierre R. Mai, with copious input from the +;;;; cmucl-help mailing-list hosted at cons.org, in November 2001 and +;;;; has been placed into the public domain. +;;;; +;;;; While the implementation should work on all conforming Common +;;;; Lisp implementations, it has only been optimized for CMU CL, +;;;; where it achieved comparable performance to the standard md5sum +;;;; utility (within a factor of 1.5 or less on iA32 and UltraSparc +;;;; hardware). +;;;; +;;;; Since the implementation makes heavy use of arithmetic on +;;;; (unsigned-byte 32) numbers, acceptable performance is likely only +;;;; on CL implementations that support unboxed arithmetic on such +;;;; numbers in some form. For other CL implementations a 16bit +;;;; implementation of MD5 is probably more suitable. +;;;; +;;;; The code implements correct operation for files of unbounded size +;;;; as is, at the cost of having to do a single generic integer +;;;; addition for each call to update-md5-state. If you call +;;;; update-md5-state frequently with little data, this can pose a +;;;; performance problem. If you can live with a size restriction of +;;;; 512 MB, then you can enable fast fixnum arithmetic by putting +;;;; :md5-small-length onto *features* prior to compiling this file. +;;;; +;;;; Testing code can be compiled by including :md5-testing on +;;;; *features* prior to compilation. In that case evaluating +;;;; (md5::test-rfc1321) will run all the test-cases present in +;;;; Appendix A.5 of RFC 1321 and report on the results. +;;;; Evaluating (md5::test-other) will run further test-cases +;;;; gathered by the author to cover regressions, etc. +;;;; +;;;; This software is "as is", and has no warranty of any kind. The +;;;; authors assume no responsibility for the consequences of any use +;;;; of this software. + +(defpackage #:md5 (:use #:cl) + (:export + ;; Low-Level types and functions + #:md5-regs #:initial-md5-regs #:md5regs-digest + #:update-md5-block #:fill-block #:fill-block-ub8 #:fill-block-char + ;; Mid-Level types and functions + #:md5-state #:md5-state-p #:make-md5-state + #:update-md5-state #:finalize-md5-state + ;; High-Level functions on sequences, streams and files + #:md5sum-sequence #:md5sum-stream #:md5sum-file + ;; Very High level functions + #:md5)) + +(in-package #:md5) + +#+cmu +(eval-when (:compile-toplevel) + (defparameter *old-expansion-limit* ext:*inline-expansion-limit*) + (setq ext:*inline-expansion-limit* (max ext:*inline-expansion-limit* 1000))) + +#+cmu +(eval-when (:compile-toplevel :execute) + (defparameter *old-features* *features*) + (pushnew (c:backend-byte-order c:*target-backend*) *features*)) + +;;; Section 2: Basic Datatypes + +#-lispworks +(eval-when (:compile-toplevel :load-toplevel :execute) + (deftype ub32 () + "Corresponds to the 32bit quantity word of the MD5 Spec" + `(unsigned-byte 32))) + +#+lispworks +(deftype ub32 () + "Corresponds to the 32bit quantity word of the MD5 Spec" + `(unsigned-byte 32)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro assemble-ub32 (a b c d) + "Assemble an ub32 value from the given (unsigned-byte 8) values, +where a is the intended low-order byte and d the high-order byte." + `(the ub32 (logior (ash ,d 24) (ash ,c 16) (ash ,b 8) ,a)))) + +;;; Section 3.4: Auxilliary functions + +(declaim (inline f g h i) + (ftype (function (ub32 ub32 ub32) ub32) f g h i)) + +(defun f (x y z) + (declare (type ub32 x y z) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) + #+cmu + (kernel:32bit-logical-or (kernel:32bit-logical-and x y) + (kernel:32bit-logical-andc1 x z)) + #-cmu + (logior (logand x y) (logandc1 x z))) + +(defun g (x y z) + (declare (type ub32 x y z) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) + #+cmu + (kernel:32bit-logical-or (kernel:32bit-logical-and x z) + (kernel:32bit-logical-andc2 y z)) + #-cmu + (logior (logand x z) (logandc2 y z))) + +(defun h (x y z) + (declare (type ub32 x y z) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) + #+cmu + (kernel:32bit-logical-xor x (kernel:32bit-logical-xor y z)) + #-cmu + (logxor x y z)) + +(defun i (x y z) + (declare (type ub32 x y z) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) + #+cmu + (kernel:32bit-logical-xor y (kernel:32bit-logical-orc2 x z)) + #-cmu + (ldb (byte 32 0) (logxor y (logorc2 x z)))) + +(declaim (inline mod32+) + (ftype (function (ub32 ub32) ub32) mod32+)) +(defun mod32+ (a b) + (declare (type ub32 a b) (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (ldb (byte 32 0) (+ a b))) + +#+cmu +(define-compiler-macro mod32+ (a b) + `(ext:truly-the ub32 (+ ,a ,b))) + +(declaim (inline rol32) + (ftype (function (ub32 (unsigned-byte 5)) ub32) rol32)) +(defun rol32 (a s) + (declare (type ub32 a) (type (unsigned-byte 5) s) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) + #+cmu + (kernel:32bit-logical-or #+little-endian (kernel:shift-towards-end a s) + #+big-endian (kernel:shift-towards-start a s) + (ash a (- s 32))) + #-cmu + (logior (ldb (byte 32 0) (ash a s)) (ash a (- s 32)))) + +;;; Section 3.4: Table T + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *t* (make-array 64 :element-type 'ub32 + :initial-contents + (loop for i from 1 to 64 + collect + (truncate + (* 4294967296 + (abs (sin (float i 0.0d0))))))))) + +;;; Section 3.4: Helper Macro for single round definitions + +(defmacro with-md5-round ((op block) &rest clauses) + (loop for (a b c d k s i) in clauses + collect + `(setq ,a (mod32+ ,b (rol32 (mod32+ (mod32+ ,a (,op ,b ,c ,d)) + (mod32+ (aref ,block ,k) + ,(aref *t* (1- i)))) + ,s))) + into result + finally + (return `(progn ,@result)))) + +;;; Section 3.3: (Initial) MD5 Working Set + +(deftype md5-regs () + "The working state of the MD5 algorithm, which contains the 4 32-bit +registers A, B, C and D." + `(simple-array (unsigned-byte 32) (4))) + +(defmacro md5-regs-a (regs) + `(aref ,regs 0)) + +(defmacro md5-regs-b (regs) + `(aref ,regs 1)) + +(defmacro md5-regs-c (regs) + `(aref ,regs 2)) + +(defmacro md5-regs-d (regs) + `(aref ,regs 3)) + +(defconstant +md5-magic-a+ (assemble-ub32 #x01 #x23 #x45 #x67) + "Initial value of Register A of the MD5 working state.") +(defconstant +md5-magic-b+ (assemble-ub32 #x89 #xab #xcd #xef) + "Initial value of Register B of the MD5 working state.") +(defconstant +md5-magic-c+ (assemble-ub32 #xfe #xdc #xba #x98) + "Initial value of Register C of the MD5 working state.") +(defconstant +md5-magic-d+ (assemble-ub32 #x76 #x54 #x32 #x10) + "Initial value of Register D of the MD5 working state.") + +(declaim (inline initial-md5-regs)) +(defun initial-md5-regs () + "Create the initial working state of an MD5 run." + (declare (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (let ((regs (make-array 4 :element-type '(unsigned-byte 32)))) + (declare (type md5-regs regs)) + (setf (md5-regs-a regs) +md5-magic-a+ + (md5-regs-b regs) +md5-magic-b+ + (md5-regs-c regs) +md5-magic-c+ + (md5-regs-d regs) +md5-magic-d+) + regs)) + +;;; Section 3.4: Operation on 16-Word Blocks + +(defun update-md5-block (regs block) + "This is the core part of the MD5 algorithm. It takes a complete 16 +word block of input, and updates the working state in A, B, C, and D +accordingly." + (declare (type md5-regs regs) + (type (simple-array ub32 (16)) block) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (let ((A (md5-regs-a regs)) (B (md5-regs-b regs)) + (C (md5-regs-c regs)) (D (md5-regs-d regs))) + (declare (type ub32 A B C D)) + ;; Round 1 + (with-md5-round (f block) + (A B C D 0 7 1)(D A B C 1 12 2)(C D A B 2 17 3)(B C D A 3 22 4) + (A B C D 4 7 5)(D A B C 5 12 6)(C D A B 6 17 7)(B C D A 7 22 8) + (A B C D 8 7 9)(D A B C 9 12 10)(C D A B 10 17 11)(B C D A 11 22 12) + (A B C D 12 7 13)(D A B C 13 12 14)(C D A B 14 17 15)(B C D A 15 22 16)) + ;; Round 2 + (with-md5-round (g block) + (A B C D 1 5 17)(D A B C 6 9 18)(C D A B 11 14 19)(B C D A 0 20 20) + (A B C D 5 5 21)(D A B C 10 9 22)(C D A B 15 14 23)(B C D A 4 20 24) + (A B C D 9 5 25)(D A B C 14 9 26)(C D A B 3 14 27)(B C D A 8 20 28) + (A B C D 13 5 29)(D A B C 2 9 30)(C D A B 7 14 31)(B C D A 12 20 32)) + ;; Round 3 + (with-md5-round (h block) + (A B C D 5 4 33)(D A B C 8 11 34)(C D A B 11 16 35)(B C D A 14 23 36) + (A B C D 1 4 37)(D A B C 4 11 38)(C D A B 7 16 39)(B C D A 10 23 40) + (A B C D 13 4 41)(D A B C 0 11 42)(C D A B 3 16 43)(B C D A 6 23 44) + (A B C D 9 4 45)(D A B C 12 11 46)(C D A B 15 16 47)(B C D A 2 23 48)) + ;; Round 4 + (with-md5-round (i block) + (A B C D 0 6 49)(D A B C 7 10 50)(C D A B 14 15 51)(B C D A 5 21 52) + (A B C D 12 6 53)(D A B C 3 10 54)(C D A B 10 15 55)(B C D A 1 21 56) + (A B C D 8 6 57)(D A B C 15 10 58)(C D A B 6 15 59)(B C D A 13 21 60) + (A B C D 4 6 61)(D A B C 11 10 62)(C D A B 2 15 63)(B C D A 9 21 64)) + ;; Update and return + (setf (md5-regs-a regs) (mod32+ (md5-regs-a regs) A) + (md5-regs-b regs) (mod32+ (md5-regs-b regs) B) + (md5-regs-c regs) (mod32+ (md5-regs-c regs) C) + (md5-regs-d regs) (mod32+ (md5-regs-d regs) D)) + regs)) + +;;; Section 3.4: Converting 8bit-vectors into 16-Word Blocks + +(declaim (inline fill-block fill-block-ub8 fill-block-char)) + +(defun fill-block-ub8 (block buffer offset) + "Convert a complete 64 (unsigned-byte 8) input vector segment +starting from offset into the given 16 word MD5 block." + (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset) + (type (simple-array ub32 (16)) block) + (type (simple-array (unsigned-byte 8) (*)) buffer) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) +;; #+(and :cmu :little-endian) +;; (kernel:bit-bash-copy ;; There is a problem with this specific code (PBrochard) +;; buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits)) +;; block (* vm:vector-data-offset vm:word-bits) +;; (* 64 vm:byte-bits)) +;; #-(and :cmu :little-endian) + (loop for i of-type (integer 0 16) from 0 + for j of-type (integer 0 #.most-positive-fixnum) + from offset to (+ offset 63) by 4 + do + (setf (aref block i) + (assemble-ub32 (aref buffer j) + (aref buffer (+ j 1)) + (aref buffer (+ j 2)) + (aref buffer (+ j 3)))))) + +(defun fill-block-char (block buffer offset) + "Convert a complete 64 character input string segment starting from +offset into the given 16 word MD5 block." + (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset) + (type (simple-array ub32 (16)) block) + (type simple-string buffer) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) +;; #+(and :cmu :little-endian) +;; (kernel:bit-bash-copy ;; There is a problem with this specific code (PBrochard) +;; buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits)) +;; block (* vm:vector-data-offset vm:word-bits) +;; (* 64 vm:byte-bits)) +;; #-(and :cmu :little-endian) + (loop for i of-type (integer 0 16) from 0 + for j of-type (integer 0 #.most-positive-fixnum) + from offset to (+ offset 63) by 4 + do + (setf (aref block i) + (assemble-ub32 (char-code (schar buffer j)) + (char-code (schar buffer (+ j 1))) + (char-code (schar buffer (+ j 2))) + (char-code (schar buffer (+ j 3))))))) + +(defun fill-block (block buffer offset) + "Convert a complete 64 byte input vector segment into the given 16 +word MD5 block. This currently works on (unsigned-byte 8) and +character simple-arrays, via the functions `fill-block-ub8' and +`fill-block-char' respectively." + (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset) + (type (simple-array ub32 (16)) block) + (type (simple-array * (*)) buffer) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (etypecase buffer + ((simple-array (unsigned-byte 8) (*)) + (fill-block-ub8 block buffer offset)) + (simple-string + (fill-block-char block buffer offset)))) + +;;; Section 3.5: Message Digest Output + +(declaim (inline md5regs-digest)) +(defun md5regs-digest (regs) + "Create the final 16 byte message-digest from the MD5 working state +in regs. Returns a (simple-array (unsigned-byte 8) (16))." + (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)) + (type md5-regs regs)) + (let ((result (make-array 16 :element-type '(unsigned-byte 8)))) + (declare (type (simple-array (unsigned-byte 8) (16)) result)) + (macrolet ((frob (reg offset) + (let ((var (gensym))) + `(let ((,var ,reg)) + (declare (type ub32 ,var)) + (setf + (aref result ,offset) (ldb (byte 8 0) ,var) + (aref result ,(+ offset 1)) (ldb (byte 8 8) ,var) + (aref result ,(+ offset 2)) (ldb (byte 8 16) ,var) + (aref result ,(+ offset 3)) (ldb (byte 8 24) ,var)))))) + (frob (md5-regs-a regs) 0) + (frob (md5-regs-b regs) 4) + (frob (md5-regs-c regs) 8) + (frob (md5-regs-d regs) 12)) + result)) + +;;; Mid-Level Drivers + +(defstruct (md5-state + (:constructor make-md5-state ()) + (:copier)) + (regs (initial-md5-regs) :type md5-regs :read-only t) + (amount 0 :type + #-md5-small-length (integer 0 *) + #+md5-small-length (unsigned-byte 29)) + (block (make-array 16 :element-type '(unsigned-byte 32)) :read-only t + :type (simple-array (unsigned-byte 32) (16))) + (buffer (make-array 64 :element-type '(unsigned-byte 8)) :read-only t + :type (simple-array (unsigned-byte 8) (64))) + (buffer-index 0 :type (integer 0 63)) + (finalized-p nil)) + +(declaim (inline copy-to-buffer)) +(defun copy-to-buffer (from from-offset count buffer buffer-offset) + "Copy a partial segment from input vector from starting at +from-offset and copying count elements into the 64 byte buffer +starting at buffer-offset." + (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)) + (type (unsigned-byte 29) from-offset) + (type (integer 0 63) count buffer-offset) + (type (simple-array * (*)) from) + (type (simple-array (unsigned-byte 8) (64)) buffer)) +;; #+cmu +;; (kernel:bit-bash-copy ;; There is a problem with this specific code (PBrochard) +;; from (+ (* vm:vector-data-offset vm:word-bits) (* from-offset vm:byte-bits)) +;; buffer (+ (* vm:vector-data-offset vm:word-bits) +;; (* buffer-offset vm:byte-bits)) +;; (* count vm:byte-bits)) +;; #-cmu + (etypecase from + (simple-string + (loop for buffer-index of-type (integer 0 64) from buffer-offset + for from-index of-type fixnum from from-offset + below (+ from-offset count) + do + (setf (aref buffer buffer-index) + (char-code (schar (the simple-string from) from-index))))) + ((simple-array (unsigned-byte 8) (*)) + (loop for buffer-index of-type (integer 0 64) from buffer-offset + for from-index of-type fixnum from from-offset + below (+ from-offset count) + do + (setf (aref buffer buffer-index) + (aref (the (simple-array (unsigned-byte 8) (*)) from) + from-index)))))) + +(defun update-md5-state (state sequence &key (start 0) (end (length sequence))) + "Update the given md5-state from sequence, which is either a +simple-string or a simple-array with element-type (unsigned-byte 8), +bounded by start and end, which must be numeric bounding-indices." + (declare (type md5-state state) + (type (simple-array * (*)) sequence) + (type fixnum start end) + (optimize (speed 3) #+cmu (safety 0) (space 0) (debug 0)) + #+cmu + (ext:optimize-interface (safety 1) (debug 1))) + (let ((regs (md5-state-regs state)) + (block (md5-state-block state)) + (buffer (md5-state-buffer state))) + (declare (type md5-regs regs) + (type (simple-array (unsigned-byte 32) (16)) block) + (type (simple-array (unsigned-byte 8) (64)) buffer)) + ;; Handle old rest + (unless (zerop (md5-state-buffer-index state)) + (let* ((buffer-index (md5-state-buffer-index state)) + (remainder (- 64 buffer-index)) + (length (- end start)) + (amount (min remainder length))) + (declare (type (integer 0 63) buffer-index remainder amount) + (type fixnum length)) + (copy-to-buffer sequence start amount buffer buffer-index) + (setf (md5-state-amount state) + #-md5-small-length (+ (md5-state-amount state) amount) + #+md5-small-length (the (unsigned-byte 29) + (+ (md5-state-amount state) amount))) + (setq start (the fixnum (+ start amount))) + (if (< length remainder) + (setf (md5-state-buffer-index state) + (the (integer 0 63) (+ buffer-index amount))) + (progn + (fill-block-ub8 block buffer 0) + (update-md5-block regs block) + (setf (md5-state-buffer-index state) 0))))) + ;; Leave when nothing to do + (when (>= start end) + (return-from update-md5-state state)) + ;; Handle main-part and new-rest + (etypecase sequence + ((simple-array (unsigned-byte 8) (*)) + (locally + (declare (type (simple-array (unsigned-byte 8) (*)) sequence)) + (loop for offset of-type (unsigned-byte 29) from start below end by 64 + until (< (- end offset) 64) + do + (fill-block-ub8 block sequence offset) + (update-md5-block regs block) + finally + (let ((amount (- end offset))) + (unless (zerop amount) + (copy-to-buffer sequence offset amount buffer 0)) + (setf (md5-state-buffer-index state) amount))))) + (simple-string + (locally + (declare (type simple-string sequence)) + (loop for offset of-type (unsigned-byte 29) from start below end by 64 + until (< (- end offset) 64) + do + (fill-block-char block sequence offset) + (update-md5-block regs block) + finally + (let ((amount (- end offset))) + (unless (zerop amount) + (copy-to-buffer sequence offset amount buffer 0)) + (setf (md5-state-buffer-index state) amount)))))) + (setf (md5-state-amount state) + #-md5-small-length (+ (md5-state-amount state) + (the fixnum (- end start))) + #+md5-small-length (the (unsigned-byte 29) + (+ (md5-state-amount state) + (the fixnum (- end start))))) + state)) + +(defun finalize-md5-state (state) + "If the given md5-state has not already been finalized, finalize it, +by processing any remaining input in its buffer, with suitable padding +and appended bit-length, as specified by the MD5 standard. + +The resulting MD5 message-digest is returned as an array of sixteen +(unsigned-byte 8) values. Calling `update-md5-state' after a call to +`finalize-md5-state' results in unspecified behaviour." + (declare (type md5-state state) + (optimize (speed 3) #+cmu (safety 0) (space 0) (debug 0)) + #+cmu + (ext:optimize-interface (safety 1) (debug 1))) + (or (md5-state-finalized-p state) + (let ((regs (md5-state-regs state)) + (block (md5-state-block state)) + (buffer (md5-state-buffer state)) + (buffer-index (md5-state-buffer-index state)) + (total-length (* 8 (md5-state-amount state)))) + (declare (type md5-regs regs) + (type (integer 0 63) buffer-index) + (type (simple-array ub32 (16)) block) + (type (simple-array (unsigned-byte 8) (*)) buffer)) + ;; Add mandatory bit 1 padding + (setf (aref buffer buffer-index) #x80) + ;; Fill with 0 bit padding + (loop for index of-type (integer 0 64) + from (1+ buffer-index) below 64 + do (setf (aref buffer index) #x00)) + (fill-block-ub8 block buffer 0) + ;; Flush block first if length wouldn't fit + (when (>= buffer-index 56) + (update-md5-block regs block) + ;; Create new fully 0 padded block + (loop for index of-type (integer 0 16) from 0 below 16 + do (setf (aref block index) #x00000000))) + ;; Add 64bit message bit length + (setf (aref block 14) (ldb (byte 32 0) total-length)) + #-md5-small-length + (setf (aref block 15) (ldb (byte 32 32) total-length)) + ;; Flush last block + (update-md5-block regs block) + ;; Done, remember digest for later calls + (setf (md5-state-finalized-p state) + (md5regs-digest regs))))) + +;;; High-Level Drivers + +(defun md5sum-sequence (sequence &key (start 0) end) + "Calculate the MD5 message-digest of data in sequence. On CMU CL +this works for all sequences whose element-type is supported by the +underlying MD5 routines, on other implementations it only works for 1d +simple-arrays with such element types." + (declare (optimize (speed 3) (space 0) (debug 0)) + (type vector sequence) (type fixnum start)) + (let ((state (make-md5-state))) + (declare (type md5-state state)) + #+cmu + (lisp::with-array-data ((data sequence) (real-start start) (real-end end)) + (update-md5-state state data :start real-start :end real-end)) + #-cmu + (let ((real-end (or end (length sequence)))) + (declare (type fixnum real-end)) + (update-md5-state state sequence :start start :end real-end)) + (finalize-md5-state state))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +buffer-size+ (* 128 1024) + "Size of internal buffer to use for md5sum-stream and md5sum-file +operations. This should be a multiple of 64, the MD5 block size.")) + +(deftype buffer-index () `(integer 0 ,+buffer-size+)) + +(defun md5sum-stream (stream) + "Calculate an MD5 message-digest of the contents of stream. Its +element-type has to be either (unsigned-byte 8) or character." + (declare (optimize (speed 3) (space 0) (debug 0))) + (let ((state (make-md5-state))) + (declare (type md5-state state)) + (cond + ((equal (stream-element-type stream) '(unsigned-byte 8)) + (let ((buffer (make-array +buffer-size+ + :element-type '(unsigned-byte 8)))) + (declare (type (simple-array (unsigned-byte 8) (#.+buffer-size+)) + buffer)) + (loop for bytes of-type buffer-index = (read-sequence buffer stream) + do (update-md5-state state buffer :end bytes) + until (< bytes +buffer-size+) + finally + (return (finalize-md5-state state))))) + ((equal (stream-element-type stream) 'character) + (let ((buffer (make-string +buffer-size+))) + (declare (type (simple-string #.+buffer-size+) buffer)) + (loop for bytes of-type buffer-index = (read-sequence buffer stream) + do (update-md5-state state buffer :end bytes) + until (< bytes +buffer-size+) + finally + (return (finalize-md5-state state))))) + (t + (error "Unsupported stream element-type ~S for stream ~S." + (stream-element-type stream) stream))))) + +(defun md5sum-file (pathname) + "Calculate the MD5 message-digest of the file specified by pathname." + (declare (optimize (speed 3) (space 0) (debug 0))) + (with-open-file (stream pathname :element-type '(unsigned-byte 8)) + (md5sum-stream stream))) + + + +(defun md5-string (md5-digest) + (format nil "~(~{~2,'0X~}~)" + (map 'list #'identity md5-digest))) + + +(defun md5 (sequence) + (md5-string (md5sum-sequence sequence))) + + + +#+md5-testing +(defconstant +rfc1321-testsuite+ + '(("" . "d41d8cd98f00b204e9800998ecf8427e") + ("a" ."0cc175b9c0f1b6a831c399e269772661") + ("abc" . "900150983cd24fb0d6963f7d28e17f72") + ("message digest" . "f96b697d7cb7938d525a2f31aaf161d0") + ("abcdefghijklmnopqrstuvwxyz" . "c3fcd3d76192e4007dfb496cca67e13b") + ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" . + "d174ab98d277d9f5a5611c2c9f419d9f") + ("12345678901234567890123456789012345678901234567890123456789012345678901234567890" . + "57edf4a22be3c955ac49da2e2107b67a")) + "AList of test input strings and stringified message-digests +according to the test suite in Appendix A.5 of RFC 1321") + +#+md5-testing +(defconstant +other-testsuite+ + '(;; From padding bug report by Edi Weitz + ("1631901HERR BUCHHEISTERCITROEN NORD1043360796beckenbauer" . + "d734945e5930bb28859ccd13c830358b") + ;; Test padding for strings from 0 to 69*8 bits in size. + ("" . "d41d8cd98f00b204e9800998ecf8427e") + ("a" . "0cc175b9c0f1b6a831c399e269772661") + ("aa" . "4124bc0a9335c27f086f24ba207a4912") + ("aaa" . "47bce5c74f589f4867dbd57e9ca9f808") + ("aaaa" . "74b87337454200d4d33f80c4663dc5e5") + ("aaaaa" . "594f803b380a41396ed63dca39503542") + ("aaaaaa" . "0b4e7a0e5fe84ad35fb5f95b9ceeac79") + ("aaaaaaa" . "5d793fc5b00a2348c3fb9ab59e5ca98a") + ("aaaaaaaa" . "3dbe00a167653a1aaee01d93e77e730e") + ("aaaaaaaaa" . "552e6a97297c53e592208cf97fbb3b60") + ("aaaaaaaaaa" . "e09c80c42fda55f9d992e59ca6b3307d") + ("aaaaaaaaaaa" . "d57f21e6a273781dbf8b7657940f3b03") + ("aaaaaaaaaaaa" . "45e4812014d83dde5666ebdf5a8ed1ed") + ("aaaaaaaaaaaaa" . "c162de19c4c3731ca3428769d0cd593d") + ("aaaaaaaaaaaaaa" . "451599a5f9afa91a0f2097040a796f3d") + ("aaaaaaaaaaaaaaa" . "12f9cf6998d52dbe773b06f848bb3608") + ("aaaaaaaaaaaaaaaa" . "23ca472302f49b3ea5592b146a312da0") + ("aaaaaaaaaaaaaaaaa" . "88e42e96cc71151b6e1938a1699b0a27") + ("aaaaaaaaaaaaaaaaaa" . "2c60c24e7087e18e45055a33f9a5be91") + ("aaaaaaaaaaaaaaaaaaa" . "639d76897485360b3147e66e0a8a3d6c") + ("aaaaaaaaaaaaaaaaaaaa" . "22d42eb002cefa81e9ad604ea57bc01d") + ("aaaaaaaaaaaaaaaaaaaaa" . "bd049f221af82804c5a2826809337c9b") + ("aaaaaaaaaaaaaaaaaaaaaa" . "ff49cfac3968dbce26ebe7d4823e58bd") + ("aaaaaaaaaaaaaaaaaaaaaaa" . "d95dbfee231e34cccb8c04444412ed7d") + ("aaaaaaaaaaaaaaaaaaaaaaaa" . "40edae4bad0e5bf6d6c2dc5615a86afb") + ("aaaaaaaaaaaaaaaaaaaaaaaaa" . "a5a8bfa3962f49330227955e24a2e67c") + ("aaaaaaaaaaaaaaaaaaaaaaaaaa" . "ae791f19bdf77357ff10bb6b0e97e121") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaa" . "aaab9c59a88bf0bdfcb170546c5459d6") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "b0f0545856af1a340acdedce23c54b97") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "f7ce3d7d44f3342107d884bfa90c966a") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "59e794d45697b360e18ba972bada0123") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "3b0845db57c200be6052466f87b2198a") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "5eca9bd3eb07c006cd43ae48dfde7fd3") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "b4f13cb081e412f44e99742cb128a1a5") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "4c660346451b8cf91ef50f4634458d41") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "11db24dc3f6c2145701db08625dd6d76") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "80dad3aad8584778352c68ab06250327") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "1227fe415e79db47285cb2689c93963f") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "8e084f489f1bdf08c39f98ff6447ce6d") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "08b2f2b0864bac1ba1585043362cbec9") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "4697843037d962f62a5a429e611e0f5f") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "10c4da18575c092b486f8ab96c01c02f") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "af205d729450b663f48b11d839a1c8df") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "0d3f91798fac6ee279ec2485b25f1124") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "4c3c7c067634daec9716a80ea886d123") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "d1e358e6e3b707282cdd06e919f7e08c") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "8c6ded4f0af86e0a7e301f8a716c4363") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "4c2d8bcb02d982d7cb77f649c0a2dea8") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "bdb662f765cd310f2a547cab1cfecef6") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "08ff5f7301d30200ab89169f6afdb7af") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "6eb6a030bcce166534b95bc2ab45d9cf") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "1bb77918e5695c944be02c16ae29b25e") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "b6fe77c19f0f0f4946c761d62585bfea") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "e9e7e260dce84ffa6e0e7eb5fd9d37fc") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "eced9e0b81ef2bba605cbc5e2e76a1d0") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "ef1772b6dff9a122358552954ad0df65") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "3b0c8ac703f828b04c6c197006d17218") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "652b906d60af96844ebd21b674f35e93") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "dc2f2f2462a0d72358b2f99389458606") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "762fc2665994b217c52c3c2eb7d9f406") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "cc7ed669cf88f201c3297c6a91e1d18d") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "cced11f7bbbffea2f718903216643648") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "24612f0ce2c9d2cf2b022ef1e027a54f") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "b06521f39153d618550606be297466d5") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "014842d480b571495a4a0363793f7367") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "c743a45e0d2e6a95cb859adae0248435") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "def5d97e01e1219fb2fc8da6c4d6ba2f") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "92cb737f8687ccb93022fdb411a77cca") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "a0d1395c7fb36247bfe2d49376d9d133") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "ab75504250558b788f99d1ebd219abf2")) + "AList of test input strings and stringified message-digests +according to my additional test suite") + +#+md5-testing +(defun test-with-testsuite (testsuite) + (loop for count from 1 + for (source . md5-string) in testsuite + for md5-digest = (md5sum-sequence source) + for md5-result-string = (md5-string md5-digest) + do + (format + *trace-output* + "~2&Test-Case ~D:~% Input: ~S~% Required: ~A~% Returned: ~A~%" + count source md5-string md5-result-string) + when (string= md5-string md5-result-string) + do (format *trace-output* " OK~%") + else + count 1 into failed + and do (format *trace-output* " FAILED~%") + finally + (format *trace-output* + "~2&~[All ~D test cases succeeded~:;~:*~D of ~D test cases failed~].~%" + failed (1- count)) + (return (zerop failed)))) + +#+md5-testing +(defun test-rfc1321 () + (test-with-testsuite +rfc1321-testsuite+)) + +#+md5-testing +(defun test-other () + (test-with-testsuite +other-testsuite+)) + +#+cmu +(eval-when (:compile-toplevel :execute) + (setq *features* *old-features*)) + +#+cmu +(eval-when (:compile-toplevel) + (setq ext:*inline-expansion-limit* *old-expansion-limit*)) diff --git a/contrib/server/net.lisp b/contrib/server/net.lisp new file mode 100644 index 0000000..04dc666 --- /dev/null +++ b/contrib/server/net.lisp @@ -0,0 +1,781 @@ +;;; Network Access +;;; +;;; Copyright (C) 1999-2008 by Sam Steingold +;;; This is open-source software. +;;; GNU Lesser General Public License (LGPL) is applicable: +;;; No warranty; you may copy/modify/redistribute under the same +;;; conditions with the source code. +;;; See +;;; for details and the precise copyright document. +;;; +;;; $Id: net.lisp,v 1.64 2008/10/20 19:54:38 sds Exp $ +;;; $Source: /cvsroot-fuse/clocc/clocc/src/port/net.lisp,v $ + +(in-package :cl-user) + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;;(require "ext.lisp") + ;; `getenv' + ;;(require "sys.lisp") + #+(or cmu scl) (require :simple-streams) ; for `set-socket-stream-format' + #+cormanlisp (require :winsock) + #+lispworks (require "comm") + #+(and sbcl (not (or db-sockets net.sbcl.sockets))) + (progn (require :sb-bsd-sockets) (pushnew :sb-bsd-sockets *features*))) + +(defpackage :port + (:use :common-lisp) + (:export :resolve-host-ipaddr + :ipaddr-to-dotted + :dotted-to-ipaddr + :ipaddr-closure + :hostent + :hostent-name + :hostent-aliases + :hostent-addr-list + :hostent-addr-type + :socket + :open-socket + :socket-host/port + :socket-string + :socket-server + :set-socket-stream-format + :socket-accept + :open-socket-server + :socket-server-close + :socket-server-host/port + :socket-service-port + :servent-name + :servent-aliases + :servent-port + :servent-proto + :servent-p + :servent + :network + :timeout + :login + :net-path)) + +(in-package :port) + + +(define-condition code (error) + ((proc :reader code-proc :initarg :proc :initform nil) + (mesg :type (or null simple-string) :reader code-mesg + :initarg :mesg :initform nil) + (args :type list :reader code-args :initarg :args :initform nil)) + (:documentation "An error in the user code.") + (:report (lambda (cc out) + (declare (stream out)) + (format out "[~s]~@[ ~?~]" (code-proc cc) (code-mesg cc) + (code-args cc))))) + +(define-condition case-error (code) + ((mesg :type simple-string :reader code-mesg :initform + "`~s' evaluated to `~s', not one of [~@{`~s'~^ ~}]")) + (:documentation "An error in a case statement. +This carries the function name which makes the error message more useful.")) + + +(define-condition not-implemented (code) + ((mesg :type simple-string :reader code-mesg :initform + "not implemented for ~a [~a]") + (args :type list :reader code-args :initform + (list (lisp-implementation-type) (lisp-implementation-version)))) + (:documentation "Your implementation does not support this functionality.")) + + +(defmacro with-gensyms ((title &rest names) &body body) + "Bind symbols in NAMES to gensyms. TITLE is a string - `gensym' prefix. +Inspired by Paul Graham, , p. 145." + `(let (,@(mapcar (lambda (sy) + `(,sy (gensym ,(concatenate 'string title + (symbol-name sy) "-")))) + names)) + ,@body)) + +(defmacro defconst (name type init doc) + "Define a typed constant." + `(progn (declaim (type ,type ,name)) + ;; since constant redefinition must be the same under EQL, there + ;; can be no constants other than symbols, numbers and characters + ;; see ANSI CL spec 3.1.2.1.1.3 "Constant Variables" + (,(if (subtypep type '(or symbol number character)) 'defconstant 'defvar) + ,name (the ,type ,init) ,doc))) + +(defconst +eof+ cons (list '+eof+) + "*The end-of-file object. +To be passed as the third arg to `read' and checked against using `eq'.") + +(defun string-tokens (string &key (start 0) end max + ((:package *package*) (find-package :keyword))) + "Read from STRING repeatedly, starting with START, up to MAX tokens. +Return the list of objects read and the final index in STRING. +Binds `*package*' to the KEYWORD package (or argument), +so that the bare symbols are read as keywords." + (declare (type (or null fixnum) max) (type fixnum start)) + (if max + (do ((beg start) obj res (num 0 (1+ num))) + ((or (= max num) (and end (>= beg end))) + (values (nreverse res) beg)) + (declare (fixnum beg num)) + (setf (values obj beg) + (read-from-string string nil +eof+ :start beg :end end)) + (if (eq obj +eof+) + (return (values (nreverse res) beg)) + (push obj res))) + (with-input-from-string (st string :start start :end end) + (loop :for obj = (read st nil st) + :until (eq obj st) :collect obj)))) + + + +(defmacro compose (&rest functions) + "Macro: compose functions or macros of 1 argument into a lambda. +E.g., (compose abs (dl-val zz) 'key) ==> + (lambda (yy) (abs (funcall (dl-val zz) (funcall key yy))))" + (labels ((rec (xx yy) + (let ((rr (list (car xx) (if (cdr xx) (rec (cdr xx) yy) yy)))) + (if (consp (car xx)) + (cons 'funcall (if (eq (caar xx) 'quote) + (cons (cadar xx) (cdr rr)) rr)) + rr)))) + (with-gensyms ("COMPOSE-" arg) + `(lambda (,arg) ,(rec functions arg))))) + + + + +;;; +;;; {{{ name resolution +;;; + +(declaim (ftype (function ((unsigned-byte 32)) (values simple-string)) + ipaddr-to-dotted)) +(defun ipaddr-to-dotted (ipaddr) + "Number --> string." + (declare (type (unsigned-byte 32) ipaddr)) + #+allegro (socket:ipaddr-to-dotted ipaddr) + #+(or openmcl ccl) (ccl:ipaddr-to-dotted ipaddr) + #+(and sbcl net.sbcl.sockets) (net.sbcl.sockets:ipaddr-to-dot-string ipaddr) + #-(or allegro openmcl ccl (and sbcl net.sbcl.sockets)) + (format nil "~d.~d.~d.~d" + (logand #xff (ash ipaddr -24)) (logand #xff (ash ipaddr -16)) + (logand #xff (ash ipaddr -8)) (logand #xff ipaddr))) + +(declaim (ftype (function (string) (values (unsigned-byte 32))) + dotted-to-ipaddr)) +(defun dotted-to-ipaddr (dotted) + "String --> number." + (declare (string dotted)) + #+allegro (socket:dotted-to-ipaddr dotted) + #+(or openmcl ccl) (ccl:dotted-to-ipaddr dotted) + #+(and sbcl net.sbcl.sockets) (net.sbcl.sockets:dot-string-to-ipaddr dotted) + #-(or allegro openmcl ccl (and sbcl net.sbcl.sockets)) + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll)))) + +;#+(and sbcl (or db-sockets sb-bsd-sockets)) +;(declaim (ftype (function (vector) (values (unsigned-byte 32))) +; vector-to-ipaddr)) +#+(and sbcl (or db-sockets sb-bsd-sockets)) +(defun vector-to-ipaddr (vector) + (+ (ash (aref vector 0) 24) + (ash (aref vector 1) 16) + (ash (aref vector 2) 8) + (aref vector 3))) + +;#+(and sbcl (or db-sockets sb-bsd-sockets)) +;(declaim (ftype (function (vector) (values (unsigned-byte 32))) +; ipaddr-to-vector)) +#+(and sbcl (or db-sockets sb-bsd-sockets)) +(defun ipaddr-to-vector (ipaddr) + (vector (ldb (byte 8 24) ipaddr) + (ldb (byte 8 16) ipaddr) + (ldb (byte 8 8) ipaddr) + (ldb (byte 8 0) ipaddr))) + +(defstruct hostent + "see gethostbyname(3) for details" + (name "" :type simple-string) ; canonical name of host + (aliases nil :type list) ; alias list + (addr-list nil :type list) ; list of addresses + (addr-type 2 :type fixnum)) ; host address type + +(defun resolve-host-ipaddr (host) + "Call gethostbyname(3) or gethostbyaddr(3)." + #+allegro + (let* ((ipaddr + (etypecase host + (string + (if (every (lambda (ch) (or (char= ch #\.) (digit-char-p ch))) + host) + (socket:dotted-to-ipaddr host) + (socket:lookup-hostname host))) + (integer host))) + (name (socket:ipaddr-to-hostname ipaddr))) + (make-hostent :name name :addr-list + (list (socket:ipaddr-to-dotted ipaddr)))) + #+(and clisp syscalls) + (let ((he (posix:resolve-host-ipaddr host))) + (make-hostent :name (posix::hostent-name he) + :aliases (posix::hostent-aliases he) + :addr-list (posix::hostent-addr-list he) + :addr-type (posix::hostent-addrtype he))) + #+(or cmu scl) + (let ((he (ext:lookup-host-entry host))) + (make-hostent :name (ext:host-entry-name he) + :aliases (ext:host-entry-aliases he) + :addr-list (mapcar #'ipaddr-to-dotted + (ext:host-entry-addr-list he)) + :addr-type (ext::host-entry-addr-type he))) + #+gcl (make-hostent :name (or (si:hostid-to-hostname host) host) + :addr-list (list (si:hostname-to-hostid host))) + #+lispworks + (multiple-value-bind (name addr aliases) + (comm:get-host-entry host :fields '(:name :address :aliases)) + (make-hostent :name name :addr-list (list (ipaddr-to-dotted addr)) + :aliases aliases)) + #+(or openmcl ccl) + (let* ((ipaddr + (etypecase host + (string + (if (every (lambda (ch) (or (char= ch #\.) (digit-char-p ch))) + host) + (dotted-to-ipaddr host) + (ccl:lookup-hostname host))) + (integer host))) + (name (ccl:ipaddr-to-hostname ipaddr))) + (make-hostent :name name :addr-list (list (ccl:lookup-hostname ipaddr)))) + #+(and sbcl sb-bsd-sockets) + (let ((he (sb-bsd-sockets:get-host-by-name host))) + (make-hostent :name (sb-bsd-sockets:host-ent-name he) + :addr-list + (loop for ipaddr in (sb-bsd-sockets:host-ent-addresses he) + collect (format nil "~{~a~^.~}" + (loop for octect + being the elements of ipaddr + collect octect))))) + #+(and sbcl db-sockets) + (let* ((ipaddr + (etypecase host + (string + (if (every (lambda (ch) (or (char= ch #\.) (digit-char-p ch))) + host) + (dotted-to-ipaddr host) + (let ((hostent + (sockets:get-host-by-name host))) + (when hostent + (vector-to-ipaddr + (sockets::host-ent-address hostent)))))) + (integer host))) + (name + (when ipaddr + (let ((hostent + (sockets:get-host-by-address + (ipaddr-to-vector ipaddr)))) + (when (and hostent + (sockets::host-ent-aliases hostent)) + (first (sockets::host-ent-aliases hostent))))))) + (make-hostent :name name :addr-list (list ipaddr))) + #+(and sbcl net.sbcl.sockets) + (let ((he (net.sbcl.sockets:lookup-host-entry host))) + (make-hostent :name (net.sbcl.sockets:host-entry-name he) + :aliases (net.sbcl.sockets:host-entry-aliases he) + :addr-list (mapcar #'ipaddr-to-dotted + (net.sbcl.sockets:host-entry-addr-list he)) + :addr-type (net.sbcl.sockets::host-entry-addr-type he))) + #-(or allegro (and clisp syscalls) cmu gcl lispworks openmcl ccl + (and sbcl (or db-sockets net.sbcl.sockets sb-bsd-sockets)) scl) + (error 'not-implemented :proc (list 'resolve-host-ipaddr host))) + +(defun ipaddr-closure (address) + "Resolve all addresses and names associated with the argument." + (let ((a2he (make-hash-table :test 'equalp)) + (he2a (make-hash-table :test 'equalp))) + (labels ((handle (s) + (unless (gethash s a2he) + (let ((he (resolve-host-ipaddr s))) + (setf (gethash s a2he) he) + (push s (gethash he he2a)) + (handle (hostent-name he)) + (mapc #'handle (hostent-aliases he)) + (mapc #'handle (hostent-addr-list he)))))) + (handle address)) + (values he2a a2he))) + +;;; +;;; }}}{{{ sockets +;;; + +(deftype socket () + #+abcl 'to-way-stream + #+allegro 'excl::socket-stream + #+clisp 'stream + #+(or cmu scl) 'stream ; '(or stream:socket-simple-stream sys:fd-stream) + #+gcl 'stream + #+lispworks 'comm:socket-stream + #+(or openmcl ccl) 'ccl::socket + #+(and sbcl (or db-sockets sb-bsd-sockets)) 'sb-sys:fd-stream + #+(and sbcl net.sbcl.sockets) 'net.sbcl.sockets:stream-socket + #-(or abcl allegro clisp cmu gcl lispworks openmcl ccl + (and sbcl (or db-sockets net.sbcl.sockets sb-bsd-sockets)) scl) 'stream) + +(defun open-socket (host port &optional bin) + "Open a socket connection to HOST at PORT." + (declare (type (or integer string) host) (fixnum port) + #+(or cmu scl) (ignore bin)) + (let ((host (etypecase host + (string host) + (integer (hostent-name (resolve-host-ipaddr host)))))) + #+abcl (ext:get-socket-stream + (sys:make-socket host port) + :element-type (if bin '(unsigned-byte 8) 'character)) + #+allegro (socket:make-socket :remote-host host :remote-port port + :format (if bin :binary :text)) + #+clisp (#+lisp=cl ext:socket-connect #-lisp=cl lisp:socket-connect + port host :element-type + (if bin '(unsigned-byte 8) 'character)) + #+(or cmu scl) + (make-instance 'stream:socket-simple-stream :direction :io + :remote-host host :remote-port port) + #+gcl (si:socket port :host host) + #+lispworks (comm:open-tcp-stream host port :direction :io :element-type + (if bin 'unsigned-byte 'base-char)) + #+(or mcl ccl) (ccl:make-socket :remote-host host :remote-port port + :format (if bin :binary :text)) + #+(and sbcl db-sockets) + (let ((socket (make-instance 'sockets:inet-socket + :type :stream :protocol :tcp))) + (sockets:socket-connect socket + (sockets::host-ent-address + (sockets:get-host-by-name host)) + port) + (sockets:socket-make-stream + socket :input t :output t :buffering (if bin :none :line) + :element-type (if bin '(unsigned-byte 8) 'character))) + #+(and sbcl net.sbcl.sockets) + (net.sbcl.sockets:make-socket + (if bin + 'net.sbcl.sockets:binary-stream-socket + 'net.sbcl.sockets:character-stream-socket) + :port port :host host) + #+(and sbcl sb-bsd-sockets) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream :protocol :tcp))) + (sb-bsd-sockets:socket-connect socket + (sb-bsd-sockets::host-ent-address + (sb-bsd-sockets:get-host-by-name host)) + port) + (sb-bsd-sockets:socket-make-stream + socket :input t :output t :buffering (if bin :none :line) + :element-type (if bin '(unsigned-byte 8) 'character))) + #-(or abcl allegro clisp cmu gcl lispworks mcl ccl + (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl) + (error 'not-implemented :proc (list 'open-socket host port bin)))) + +(defun set-socket-stream-format (socket format) + "switch between binary and text output" + #+clisp (setf (stream-element-type socket) format) + #+(or acl cmu lispworks scl) + (declare (ignore socket format)) ; bivalent streams + #-(or acl clisp cmu lispworks scl) + (error 'not-implemented :proc (list 'set-socket-stream-format socket format))) + +#+(and sbcl sb-bsd-sockets) +(defun funcall-on-sock (function sock) + "Apply function (getsockname/getpeername) on socket, return host/port as two values" + (let ((sockaddr (sockint::allocate-sockaddr-in))) + (funcall function (sb-sys:fd-stream-fd sock) sockaddr sockint::size-of-sockaddr-in) + (let ((host (coerce (loop :for i :from 0 :below 4 + :collect (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) i)) + '(vector (unsigned-byte 8) 4))) + (port (+ (* 256 (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 0)) + (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 1)))) + (sockint::free-sockaddr-in sockaddr) + (values host port)))) + +(defun socket-host/port (sock) + "Return the remote and local host&port, as 4 values." + (declare (type socket sock)) + #+allegro (values (socket:ipaddr-to-dotted (socket:remote-host sock)) + (socket:remote-port sock) + (socket:ipaddr-to-dotted (socket:local-host sock)) + (socket:local-port sock)) + #+clisp (flet ((ip (ho) (subseq ho 0 (position #\Space ho :test #'char=)))) + (multiple-value-bind (ho1 po1) + (#+lisp=cl ext:socket-stream-peer + #-lisp=cl lisp:socket-stream-peer sock) + (multiple-value-bind (ho2 po2) + (#+lisp=cl ext:socket-stream-local + #-lisp=cl lisp:socket-stream-local sock) + (values (ip ho1) po1 + (ip ho2) po2)))) + #+(or cmu scl) + (let ((fd (sys:fd-stream-fd sock))) + (multiple-value-bind (ho1 po1) (ext:get-peer-host-and-port fd) + (multiple-value-bind (ho2 po2) (ext:get-socket-host-and-port fd) + (values (ipaddr-to-dotted ho1) po1 + (ipaddr-to-dotted ho2) po2)))) + #+gcl (let ((peer (si:getpeername sock)) + (loc (si:getsockname sock))) + (values (car peer) (caddr peer) + (car loc) (caddr loc))) + #+lispworks + (multiple-value-bind (ho1 po1) (comm:socket-stream-peer-address sock) + (multiple-value-bind (ho2 po2) (comm:socket-stream-address sock) + (values (ipaddr-to-dotted ho1) po1 + (ipaddr-to-dotted ho2) po2))) + #+(or mcl ccl) + (values (ccl:ipaddr-to-dotted (ccl:remote-host sock)) + (ccl:remote-port sock) + (ccl:ipaddr-to-dotted (ccl:local-host sock)) + (ccl:local-port sock)) + #+(and sbcl db-sockets) + (let ((sock (sb-sys:fd-stream-fd sock))) + (multiple-value-bind (remote remote-port) (sockets:socket-peername sock) + (multiple-value-bind (local local-port) (sockets:socket-name sock) + (values (ipaddr-to-dotted (vector-to-ipaddr remote)) + remote-port + (ipaddr-to-dotted (vector-to-ipaddr local)) + local-port)))) + #+(and sbcl net.sbcl.sockets) + (net.sbcl.sockets:socket-host-port sock) + #+(and sbcl sb-bsd-sockets) + (multiple-value-bind (remote remote-port) + (funcall-on-sock #'sockint::getpeername sock) + (multiple-value-bind (local local-port) + (funcall-on-sock #'sockint::getsockname sock) + (values (ipaddr-to-dotted (vector-to-ipaddr remote)) + remote-port + (ipaddr-to-dotted (vector-to-ipaddr local)) + local-port))) + #-(or allegro clisp cmu gcl lispworks mcl ccl + (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl) + (error 'not-implemented :proc (list 'socket-host/port sock))) + +(defun socket-string (sock) + "Print the socket local&peer host&port to a string." + (declare (type socket sock)) + (with-output-to-string (stream) + (print-unreadable-object (sock stream :type t :identity t) + (multiple-value-bind (ho1 po1 ho2 po2) (socket-host/port sock) + (format stream "[local: ~a:~d] [peer: ~s:~d]" ho2 po2 ho1 po1))))) + +;;; +;;; }}}{{{ socket-servers +;;; + +#+lispworks (defstruct socket-server proc mbox port) +#-lispworks +(deftype socket-server () + #+abcl 'ext:javaobject + #+allegro 'acl-socket::socket-stream-internet-passive + #+(and clisp lisp=cl) 'ext:socket-server + #+(and clisp (not lisp=cl)) 'lisp:socket-server + #+(or cmu scl) 'integer + #+gcl 'si:socket-stream + #+(or mcl ccl) 'ccl::listener-socket + #+(and sbcl db-sockets) 'sb-sys:fd-stream + #+(and sbcl net.sbcl.sockets) 'net.sbcl.sockets:passive-socket + #+(and sbcl sb-bsd-sockets) 'sb-bsd-sockets:inet-socket + #-(or abcl allegro clisp cmu gcl mcl ccl + (and sbcl (or net.sbcl.sockets db-sockets)) scl) t) + +(defun open-socket-server (&optional port) + "Open a `generic' socket server." + (declare (type (or null integer #-sbcl socket) port)) + #+abcl (ext:make-server-socket port) + #+allegro (socket:make-socket :connect :passive :local-port + (when (integerp port) port)) + #+clisp (#+lisp=cl ext:socket-server #-lisp=cl lisp:socket-server port) + #+(or cmu scl) (ext:create-inet-listener (or port 0) :stream :reuse-address t) + #+gcl (si:make-socket-pair port) ; FIXME + #+lispworks (let ((mbox (mp:make-mailbox :size 1))) + (make-socket-server + :mbox mbox :port port + :proc (comm:start-up-server + :function (lambda (sock) (mp:mailbox-send mbox sock)) + :service port))) + #+(or mcl ccl) + (ccl:make-socket :connect :passive + :type :stream + :reuse-address t + :local-port (or port 0)) + #+(and sbcl db-sockets) + (let ((socket (make-instance 'sockets:inet-socket + :type :stream :protocol :tcp))) + (sockets:socket-bind socket (vector 0 0 0 0) (or port 0))) + #+(and sbcl net.sbcl.sockets) + (net.sbcl.sockets:make-socket 'net.sbcl.sockets:passive-socket :port port) + #+(and sbcl sb-bsd-sockets) + (let ((sock (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address sock) t) + (sb-bsd-sockets:socket-bind sock (vector 0 0 0 0) (or port 0)) + (sb-bsd-sockets:socket-listen sock 15) + sock) + #-(or abcl allegro clisp cmu gcl lispworks mcl ccl + (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl) + (error 'not-implemented :proc (list 'open-socket-server port))) + +(defun socket-accept (serv &key bin wait) + "Accept a connection on a socket server (passive socket). +Keyword arguments are: + BIN - create a binary stream; + WAIT - wait for the connection this many seconds + (the default is NIL - wait forever). +Returns a socket stream or NIL." + (declare (type socket-server serv) + #+(or (and allegro (version>= 6)) openmcl ccl) + (ignore bin)) + #+abcl (ext:get-socket-stream + (ext:socket-accept serv) + :element-type (if bin '(unsigned-byte 8) 'character)) + #+allegro (let* ((fmt (if bin :binary :text)) + #+allegro-v5.0 + (excl:*default-external-format* fmt) + (sock (if wait + (if (plusp wait) + (mp:with-timeout (wait) + (socket:accept-connection serv :wait t)) + (socket:accept-connection serv :wait nil)) + (socket:accept-connection serv :wait t)))) + (when sock + ;; From: John Foderaro + ;; Date: Sun, 12 Nov 2000 16:58:28 -0800 + ;; in ACL6 and later, all sockets are bivalent (both + ;; text and binary) and thus there's no need to convert + ;; between the element types. + #+allegro-v5.0 + (unless (eq (socket:socket-format sock) fmt) + (warn "~s: ACL5 cannot modify socket format" + 'socket-accept)) + #+allegro-v4.3 + (socket:set-socket-format sock fmt) + sock)) + #+clisp (multiple-value-bind (sec usec) (floor (or wait 0)) + (when (#+lisp=cl ext:socket-wait #-lisp=cl lisp:socket-wait + serv (and wait sec) (round usec 1d-6)) + (#+lisp=cl ext:socket-accept #-lisp=cl lisp:socket-accept + serv :element-type + (if bin '(unsigned-byte 8) 'character)))) + #+(or cmu scl) + (when (sys:wait-until-fd-usable serv :input wait) + (sys:make-fd-stream (ext:accept-tcp-connection serv) + :buffering (if bin :full :line) + :input t :output t :element-type + (if bin '(unsigned-byte 8) 'character))) + #+gcl (si:accept-socket-connection serv bin wait) ; FIXME + #+lispworks (make-instance + 'comm:socket-stream :direction :io + :socket (mp:mailbox-read (socket-server-mbox serv)) + :element-type (if bin 'unsigned-byte 'base-char)) + ;; For ccl, as wait is a boolean, the time to wait is ignored. + #+(or mcl ccl) (ccl:accept-connection serv :wait (not wait)) + #+(and sbcl db-sockets) + (let ((new-connection (sockets:socket-accept serv))) + ;; who needs WAIT and BIN anyway :-S + new-connection) + #+(and sbcl net.sbcl.sockets) + (net.sbcl.sockets:accept-connection + serv + (if bin + 'net.sbcl.sockets:binary-stream-socket + 'net.sbcl.sockets:character-stream-socket) + :wait wait) + #+(and sbcl sb-bsd-sockets) + (progn + (setf (sb-bsd-sockets:non-blocking-mode serv) wait) + (let ((s (sb-bsd-sockets:socket-accept serv))) + (if s + (sb-bsd-sockets:socket-make-stream + s :input t :output t + :element-type (if bin '(unsigned-byte 8) 'character) + :buffering (if bin :full :line)) + (sleep wait)))) + #-(or abcl allegro clisp cmu gcl lispworks mcl ccl + (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl) + (error 'not-implemented :proc (list 'socket-accept serv bin))) + +(defun socket-server-close (server) + "Close the server." + (declare (type socket-server server)) + #+abcl (ext:server-socket-close server) + #+allegro (close server) + #+clisp (#+lisp=cl ext:socket-server-close + #-lisp=cl lisp:socket-server-close server) + #+(or cmu scl) (unix:unix-close server) + #+gcl (close server) + #+lispworks (mp:process-kill (socket-server-proc server)) + #+(or openmcl ccl) (close server) + #+(and sbcl db-sockets) (sockets:socket-close server) + #+(and sbcl net.sbcl.sockets) (close server) + #+(and sbcl sb-bsd-sockets) (sb-bsd-sockets:socket-close server) + #-(or abcl allegro clisp cmu gcl lispworks openmcl ccl + (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl) + (error 'not-implemented :proc (list 'socket-server-close server))) + +(defun socket-server-host/port (server) + "Return the local host&port on which the server is running, as 2 values." + (declare (type socket-server server)) + #+allegro (values (socket:ipaddr-to-dotted (socket:local-host server)) + (socket:local-port server)) + #+(and clisp lisp=cl) (values (ext:socket-server-host server) + (ext:socket-server-port server)) + #+(and clisp (not lisp=cl)) (values (lisp:socket-server-host server) + (lisp:socket-server-port server)) + #+(or cmu scl) + (values (ipaddr-to-dotted (car (ext:host-entry-addr-list + (ext:lookup-host-entry "localhost")))) + (nth-value 1 (ext:get-socket-host-and-port server))) + #+gcl (let ((sock (si:getsockname server))) + (values (car sock) (caddr sock))) + #+lispworks (values (ipaddr-to-dotted (comm:get-host-entry + "localhost" :fields '(:address))) + (socket-server-port server)) + #+(or openmcl ccl) + (values (ccl:ipaddr-to-dotted (ccl:local-host server)) + (ccl:local-port server)) + #+(and sbcl db-sockets) + (multiple-value-bind (addr port) (sockets:socket-name server) + (values (vector-to-ipaddr addr) port)) + #+(and sbcl net.sbcl.sockets) + (net.sbcl.sockets:passive-socket-host-port server) + #+(and sbcl sb-bsd-sockets) + (multiple-value-bind (addr port) (sb-bsd-sockets:socket-name server) + (values (ipaddr-to-dotted (vector-to-ipaddr addr)) port)) + #-(or allegro clisp cmu gcl lispworks openmcl ccl + (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl) + (error 'not-implemented :proc (list 'socket-server-host/port server))) + +;;; +;;; }}}{{{ for CLX +;;; + +(defun wait-for-stream (stream &optional timeout) + "Sleep until there is input on the STREAM, or for TIMEOUT seconds, +whichever comes first. If there was a timeout, return NIL." + #+clisp (multiple-value-bind (sec usec) (floor (or timeout 0)) + (#+lisp=cl ext:socket-status #-lisp=cl lisp:socket-status + stream (and timeout sec) (round usec 1d-6))) + #+(or cmu scl) + (#+mp mp:process-wait-until-fd-usable #-mp sys:wait-until-fd-usable + (system:fd-stream-fd stream) :input timeout) + #+(or openmcl ccl) + (ccl:make-socket :type :stream + :address-family :file + :connect :active + :format :text ;;(if bin :binary :text) + :remote-filename #P"");;path) + #+(and sbcl net.sbcl.sockets) + (net.sbcl.sockets:wait-for-input-data stream timeout) + #+(and sbcl db-sockets) + (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream) :input timeout) + #-(or clisp cmu (and sbcl (or net.sbcl.sockets db-sockets)) scl) + (error 'not-implemented :proc (list 'wait-for-stream stream timeout))) + +(defun open-unix-socket (path &key (kind :stream) bin) + "Opens a unix socket. Path is the location. +Kind can be :stream or :datagram." + (declare (simple-string path) #-(or cmu sbcl) (ignore kind)) + #+allegro (socket:make-socket :type :stream + :address-family :file + :connect :active + :remote-filename path) + #+cmu (sys:make-fd-stream (ext:connect-to-unix-socket path kind) + :input t :output t :element-type + (if bin '(unsigned-byte 8) 'character)) + #+(and sbcl net.sbcl.sockets) + (net.sbcl.sockets:make-socket 'net.sbcl.sockets:unix-stream-socket + :buffering :full :path path :type kind) + #+(and sbcl db-sockets) + (let ((socket (make-instance 'sockets:unix-socket :type :stream))) + (sockets:socket-connect socket path) + (sockets:socket-make-stream socket :input t :output t + :buffering :none + :element-type '(unsigned-byte 8))) + #-(or allegro cmu (and sbcl (or net.sbcl.sockets db-sockets))) + (open path :element-type (if bin '(unsigned-byte 8) 'character) + :direction :io)) + +;;; +;;; }}}{{{ conditions +;;; + +(defun report-network-condition (cc out) + (declare (stream out)) + (format out "[~s] ~s:~d~@[ ~?~]" (net-proc cc) (net-host cc) + (net-port cc) (net-mesg cc) (net-args cc))) + +(define-condition network (error) + ((proc :type symbol :reader net-proc :initarg :proc :initform nil) + (host :type simple-string :reader net-host :initarg :host :initform "") + (port :type (unsigned-byte 16) :reader net-port :initarg :port :initform 0) + (mesg :type (or null simple-string) :reader net-mesg + :initarg :mesg :initform nil) + (args :type list :reader net-args :initarg :args :initform nil)) + (:report report-network-condition)) + +(define-condition timeout (network) + ((time :type (real 0) :reader timeout-time :initarg :time :initform 0)) + (:report (lambda (cc out) + (declare (stream out)) + (report-network-condition cc out) + (when (plusp (timeout-time cc)) + (format out " [timeout ~a sec]" (timeout-time cc)))))) + +(define-condition login (network) ()) +(define-condition net-path (network) ()) + +;;; +;;; }}}{{{ `socket-service-port' +;;; + +(defstruct servent + "see getservbyname(3) for details" + (name "" :type simple-string) ; official name of service + (aliases nil :type list) ; alias list + (port -1 :type fixnum) ; port service resides at + (proto :tcp :type symbol)) ; protocol to use + +(defun socket-service-port (&optional service (protocol "tcp")) + "Return the SERVENT structure corresponding to the SERVICE. +When SERVICE is NIL, return the list of all services." + (with-open-file (fl #+unix "/etc/services" #+(or win32 mswindows) + (concatenate 'string (getenv "windir") + "/system32/drivers/etc/services") + :direction :input) + (loop :with name :and aliases :and port :and prot :and tokens + :for st = (read-line fl nil nil) + :until (null st) + :unless (or (zerop (length st)) (char= #\# (schar st 0))) + :do (setq tokens (string-tokens + (nsubstitute + #\Space #\/ (subseq st 0 (position #\# st)))) + name (string-downcase (string (first tokens))) + aliases (mapcar (compose string-downcase string) + (cdddr tokens)) + port (second tokens) + prot (third tokens)) :and + :if service + :when (and (string-equal protocol prot) + (or (string-equal service name) + (member service aliases :test #'string-equal))) + :return (make-servent :name name :aliases aliases :port port + :proto prot) + :end + :else :collect (make-servent :name name :aliases aliases :port port + :proto prot) + :end + :end + :finally (when service + (error "~s: service ~s is not found for protocol ~s" + 'socket-service-port service protocol))))) + +;;; }}} + +(provide :port-net) +;;; file net.lisp ends here diff --git a/contrib/server/server.lisp b/contrib/server/server.lisp new file mode 100644 index 0000000..e790d56 --- /dev/null +++ b/contrib/server/server.lisp @@ -0,0 +1,257 @@ +;;; -------------------------------------------------------------------------- +;;; CLFSWM - FullScreen Window Manager +;;; +;;; -------------------------------------------------------------------------- +;;; Documentation: Utility +;;; -------------------------------------------------------------------------- +;;; +;;; (C) 2005 Philippe Brochard +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; -------------------------------------------------------------------------- +;;; Server protocole: +;;; Server -> Client: orig_key=a generated key crypted with *key* +;;; Client : build its new_key with orig_key+*key* +;;; Client -> Server: new_key+(md5 new_key) crypted with new_key +;;; Server -> Client: check if the keys match and then authenticate the client. +;;; +;;; -------------------------------------------------------------------------- + + +(format t "Loading the clfswm server code... ") + +(pushnew (truename (concatenate 'string *contrib-dir* "contrib/" "server/")) asdf:*central-registry*) + +(dbg asdf:*central-registry*) + +(asdf:oos 'asdf:load-op :util-server) + +(in-package :clfswm) + +(use-package :crypt) + +(defstruct server-socket stream auth form key) + +(defparameter *server-socket* nil) +(defparameter *server-port* 33333) +(defparameter *server-allowed-host* '("127.0.0.1")) + +(defparameter *server-connection* nil) + +(defparameter *server-commands* '("bye" "close" "quit" "info" "clear" "ls[d][v|f] [pattern]")) + + + + + +(defun send-to-client (sock show-prompt-p &rest msg) + (dolist (m (if (consp (car msg)) (car msg) msg)) + (format (server-socket-stream sock) "~A~%" (crypt m (server-socket-key sock))) + (force-output (server-socket-stream sock))) + (when show-prompt-p + (server-show-prompt sock))) + + +(defun server-show-prompt (sock) + (send-to-client sock nil (format nil "~A> " (package-name *package*)))) + + +(defun read-from-client (sock) + (decrypt (read-line (server-socket-stream sock) nil nil) (server-socket-key sock))) + + + +(defun server-remove-connection (sock) + (send-to-client sock nil "Connection closed by server") + (multiple-value-bind (local-host local-port remote-host remote-port) + (port:socket-host/port (server-socket-stream sock)) + (declare (ignore local-host local-port)) + (format t "~&Connection from ~A:~A closed.~%" remote-host remote-port)) + (close (server-socket-stream sock)) + (setf *server-connection* (remove sock *server-connection*))) + +(defun server-show-info (sock) + (send-to-client sock t (format nil "~A" *server-connection*))) + + +(defun server-clear-connection () + (dolist (sock *server-connection*) + (handler-case + (send-to-client sock t "Server clear connection in progress.") + (error () + (server-remove-connection sock))))) + + +(defun server-show-help (sock) + (send-to-client sock t (format nil "Availables commandes: ~{~S~^, ~}" *server-commands*))) + + +(defun server-ls (sock line ls-word var-p fun-p &optional show-doc) + (let* ((pattern (string-trim '(#\space #\tab) (subseq (string-trim '(#\space #\tab) line) (length ls-word)))) + (all-search (string= pattern ""))) + (with-all-internal-symbols (symbol :clfswm) + (when (or all-search (symbol-search pattern symbol)) + (cond ((and var-p (boundp symbol)) + (send-to-client sock nil (format nil "~A (variable) ~A" symbol + (if show-doc + (format nil "~& ~A~& => ~A" + (documentation symbol 'variable) + (symbol-value symbol)) + "")))) + ((and fun-p (fboundp symbol)) + (send-to-client sock nil (format nil "~A (function) ~A" symbol + (if show-doc + (documentation symbol 'function) + ""))))))) + (send-to-client sock t "Done."))) + + + +(defun server-is-allowed-host (stream) + (multiple-value-bind (local-host local-port remote-host remote-port) + (port:socket-host/port stream) + (declare (ignore local-host local-port)) + (and (member remote-host *server-allowed-host* :test #'string-equal) + (equal remote-port *server-port*)))) + + +(defun server-handle-new-connection () + (handler-case + (let ((stream (and *server-socket* (port:socket-accept *server-socket* :wait 0.01d0)))) + (when stream + (if (server-is-allowed-host stream) + (multiple-value-bind (local-host local-port remote-host remote-port) + (port:socket-host/port stream) + (declare (ignore local-host local-port)) + (format t "~&New connection from ~A:~A " remote-host remote-port) + (let ((new-sock (make-server-socket :stream stream :auth nil :form "" :key *key*)) + (key (generate-key))) + (push new-sock *server-connection*) + (send-to-client new-sock nil key) + (setf (server-socket-key new-sock) (concatenate 'string key *key*)))) + (close stream)))) + (error (c) + (format t "Connection rejected: ~A~%" c) + (force-output)))) + + +(defun server-line-is (line &rest strings) + (dolist (str strings) + (when (string-equal line str) + (return-from server-line-is t))) + nil) + + +(defun server-complet-from (sock) + (ignore-errors + (when (listen (server-socket-stream sock)) + (let ((line (read-from-client sock))) + (cond ((server-line-is line "help") (server-show-help sock)) + ((server-line-is line "bye" "close" "quit") (server-remove-connection sock)) + ((server-line-is line "info") (server-show-info sock)) + ((server-line-is line "clear") (server-clear-connection)) + ((first-position "lsdv" line) (server-ls sock line "lsdv" t nil t)) + ((first-position "lsdf" line) (server-ls sock line "lsdf" nil t t)) + ((first-position "lsd" line) (server-ls sock line "lsd" t t t)) + ((first-position "lsv" line) (server-ls sock line "lsv" t nil nil)) + ((first-position "lsf" line) (server-ls sock line "lsf" nil t nil)) + ((first-position "ls" line) (server-ls sock line "ls" t t nil)) + (t (setf (server-socket-form sock) (format nil "~A~A~%" (server-socket-form sock) line)))))))) + + + + + +(defun server-eval-form (sock) + (let* ((result nil) + (printed-result + (with-output-to-string (*standard-output*) + (setf result (handler-case + (loop for i in (multiple-value-list + (eval (read-from-string (server-socket-form sock)))) + collect (format nil "~S" i)) + (error (condition) + (format nil "~A" condition))))))) + (send-to-client sock nil (ensure-list printed-result)) + (send-to-client sock t (ensure-list result)) + (setf (server-socket-form sock) ""))) + + +(defun server-handle-form (sock) + (server-complet-from sock) + (if (server-socket-key sock) + (when (ignore-errors (read-from-string (server-socket-form sock))) + (server-eval-form sock)) + (server-show-prompt sock))) + +(defun server-handle-auth (sock) + (loop for line = (read-from-client sock) + while line + do + (if (string= line (format nil "~A~A" (server-socket-key sock) + (md5:md5 (server-socket-key sock)))) + (progn + (setf (server-socket-auth sock) t) + (setf (server-socket-form sock) (format nil "~S" "You are now authenticated!")) + (server-handle-form sock) + (format t "Connection accepted~%") + (return-from server-handle-auth nil)) + (progn + (format t "Connection closed~%") + (close (server-socket-stream sock)))))) + + +(defun server-handle-connection (sock) + (handler-case + (when (listen (server-socket-stream sock)) + (if (server-socket-auth sock) + (server-handle-form sock) + (server-handle-auth sock))) + (error (c) + (format t "*** Error: ~A~%" c) (force-output) + (close (server-socket-stream sock)) + (setf *server-connection* (remove sock *server-connection*))))) + +(defun handle-server () + (server-handle-new-connection) + (dolist (sock *server-connection*) + (server-handle-connection sock))) + + + +(defun start-server (&optional port) + (save-new-key) + (when port + (setf *server-port* port)) + (setf *server-socket* (port:open-socket-server *server-port*)) + (add-hook *loop-hook* 'handle-server) + (format t "*** Server is started on port ~A and is accepting connection only from [~{~A~^, ~}].~2%" + *server-port* *server-allowed-host*)) + + + + +(format t "done. + +You can now start a clfswm server with the command (start-server &optional port). +Only [~{~A~^, ~}] ~A allowed to login on the server~%" + *server-allowed-host* + (if (or (null *server-allowed-host*) (= (length *server-allowed-host*) 1)) + "is" "are")) + + + + diff --git a/contrib/server/test.sh b/contrib/server/test.sh new file mode 100755 index 0000000..733d15e --- /dev/null +++ b/contrib/server/test.sh @@ -0,0 +1,7 @@ +#! /bin/sh + +clisp load.lisp "(print 'toto) (print (+ 2 2))" "(leave-frame)" " quit " +#cmucl -load load.lisp "(print 'toto)" "(print (+ 2 2))" "(leave-frame)" "quit" +#sbcl --load load.lisp "(print 'toto)" "(print (+ 2 2))" "(leave-frame)" "quit" +#ccl --load load.lisp -- "(print 'toto)" "(print (+ 2 2))" "(leave-frame)" "quit" +#/tmp/local/bin/clfswm-client "(print 'toto)" "(print 'toto) (print (+ 2 2))" "(leave-frame)" "quit" diff --git a/contrib/server/test2.sh b/contrib/server/test2.sh new file mode 100755 index 0000000..f32e778 --- /dev/null +++ b/contrib/server/test2.sh @@ -0,0 +1,18 @@ +#! /bin/sh + +EXEC_CMD='(leave-frame) +(select-previous-level) +(let ((frame (create-frame \:name \"Test root\" \:x 0.05 \:y 0.05))) + (add-frame frame *current-child*) + (add-frame (create-frame \:name \"Test 1\" \:x 0.3 \:y 0 \:w 0.7 \:h 1) frame) + (add-frame (create-frame \:name \"Test 2\" \:x 0 \:y 0 \:w 0.3 \:h 1) frame) + (setf *current-child* (first (frame-child frame)))) +(show-all-children *current-root*) +quit' + +clisp load.lisp "$EXEC_CMD" +#cmucl -load load.lisp "$EXEC_CMD" +#sbcl --load load.lisp "$EXEC_CMD" +#ccl --load load.lisp -- "$EXEC_CMD" +#/tmp/local/bin/clfswm-client "$EXEC_CMD" + diff --git a/contrib/server/util-server.asd b/contrib/server/util-server.asd new file mode 100644 index 0000000..746eb4a --- /dev/null +++ b/contrib/server/util-server.asd @@ -0,0 +1,23 @@ +;;;; -*- Mode: Lisp -*- +;;;; ASDF System Definition +;;; + +(in-package #:asdf) + +(defsystem util-server + :description "" + :licence "GNU Lesser General Public License (LGPL)" + :components ((:file "md5") + (:file "net") + (:file "crypt") + (:file "key" + :depends-on ("crypt")))) + + + + + + + + + -- 2.11.4.GIT