diff --git a/scsh/CSAN/CSAN-server-daemon-record.scm b/scsh/CSAN/CSAN-server-daemon-record.scm new file mode 100644 index 0000000..9369105 --- /dev/null +++ b/scsh/CSAN/CSAN-server-daemon-record.scm @@ -0,0 +1,42 @@ +;;; CSAN-server-daemon-record.scm - records for CSAN server side +;;; +;;; Copyright (c) 2011-2012 Johan Ceuppens +;;; +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the authors may not be used to endorse or promote products +;;; derived from this software without specific prior written permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, +;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(define :CSAN-daemon-record + (make-record-type 'CSAN-daemon-record + '(hostname port sock motd ack bye))) +(define make-CSAN-daemon-record + (record-constructor :CSAN-daemon-record + '(hostname port sock motd ack bye))) + +(define hostname (record-accessor :CSAN-daemon-record 'hostname)) +(define port (record-accessor :CSAN-daemon-record 'port)) +(define sock (record-accessor :CSAN-daemon-record 'sock)) +(define motd (record-accessor :CSAN-daemon-record 'motd)) +(define ack (record-accessor :CSAN-daemon-record 'ack)) +(define bye (record-accessor :CSAN-daemon-record 'bye)) + diff --git a/scsh/CSAN/CSAN-server-daemon.scm b/scsh/CSAN/CSAN-server-daemon.scm new file mode 100644 index 0000000..5eb0a0c --- /dev/null +++ b/scsh/CSAN/CSAN-server-daemon.scm @@ -0,0 +1,105 @@ +;;; tforks.scm - a scheme daemon child process +;;; +;;; Copyright (c) 2011-2012 Johan Ceuppens +;;; +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the authors may not be used to endorse or promote products +;;; derived from this software without specific prior written permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, +;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;; NOTE : files stored on this server are retrieved from its runtime directory + +(load "CSAN-server-daemon-record.scm") + +(define (errormsg) (display " message not understood. ")) +(define (eoln) (string #\newline)) +(define (servermsg) (display "::message::")) + +(define (get-package package-name) + (let* ((in (open-input-file (if (string<=? ".tar.gz" package-name) + package-name + (string-append package-name ".tar.gz")))) + (contents "")) + (do ((c (read-char in) (read-char in))) + ((eof-object? c)contents) + (set! contents (string-append contents (string c)))))) + +(define (run-daemon-child-CSAN rec) + (let ((*hostname (hostname rec)) + (*port (port rec)) + (*socket (socket rec)) + (*motd (motd rec)) + (*ack (ack rec)) + (*apop (apop rec)) + (*stat (stat rec)) + (*list (list rec)) + (*bye (bye rec))) + + (set! *socket (open-socket *port)) + + (for-each display '("Opening CSAN server side : listening on host : " + *hostname + " port : " + *port + (eoln))) + + ((lambda () + (call-with-values + (lambda () + (socket-accept *socket)) + (lambda (in out) + (write *motd out) + (let ((answer (read (make-string-input-port in)))) + (for-each display '((servermsg) (symbol->string answer))) + (if (symbol? answer) + (cond ((eq? 'get answer) + (let ((answer2 (read (make-string-input-port in)))) + (write (get-package answer2) out))) + ((or (eq? 'QUIT answer)(eq? 'quit answer)) + (write *bye out) + (close-input-port in) + (close-socket *socket) + (close-output-port out) + (exit)) + (else + (write (errormsg) out)) + )) + )))) + (let ((answer2 (read (make-string-input-port in)))) + (for-each display '((servermsg) (symbol->string answer2))) + (write *bye out) + (close-input-port in) + (close-socket *socket) + (close-output-port out) + (exit))))) + + +(define rc (make-daemon-record + "localhost" ;; virtual host + 6969 + #f + "CSAN server side ready." + "Scheming..." + "CSAN server signing off." + )) + +(run-daemon-child-CSAN rc) diff --git a/scsh/CSAN/CSAN-server.scm b/scsh/CSAN/CSAN-server.scm new file mode 100644 index 0000000..81076d8 --- /dev/null +++ b/scsh/CSAN/CSAN-server.scm @@ -0,0 +1,39 @@ +;;; server.scm - a full-duplex connect-to-client +;;; +;;; Copyright (c) 2012 Johan Ceuppens +;;; +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the authors may not be used to endorse or promote products +;;; derived from this software without specific prior written permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, +;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(define (CSAN-tell-client request port-number sock) + (call-with-values + (lambda () + (socket-accept sock)) + (lambda (in out) + (display request out) + (close-output-port out) + (let ((answer (make-string-input-port in))) ; returns any server response into some string + (close-input-port in) + answer) + ))) diff --git a/scsh/CSAN/CSAN-util.scm b/scsh/CSAN/CSAN-util.scm new file mode 100644 index 0000000..512345d --- /dev/null +++ b/scsh/CSAN/CSAN-util.scm @@ -0,0 +1,77 @@ +;;; CSAN-util.scm - Compehensive Scheme Archive Network utilities +;;; +;;; Copyright (c) 2012 Johan Ceuppens +;;; +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the authors may not be used to endorse or promote products +;;; derived from this software without specific prior written permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, +;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(define (url-bite-off url) + (let ((s "") + (do ((i 0 (+ i 1))) + ((or (>= i (string-length url)) + (eq? (string-ref url i) #\/) + (eq? (string-ref url i) #\\)) ;; needs scheme URL parsing (e.g. with regexps or other perl things + s) + (set! s (string-append s (string (string-ref url i)))) + (cond ((or (eq? s "http://")(eq? s "ftp://") + (eq? s " http://")(eq? s " ftp://")) + (set! s "")) + ))) + )) + +(define CSAN-generators (make-table)) +(table-set! CSAN-generators "helpfile" (lambda () + (display "Type in your helpfile : commands are 'get ' and 'h'") + (let ((*out (open-outputfile (string-append "/help")))) + (do ((s (read)(read))) + ((eof-object? s)0) + (write s)(write " "))))) + +(define (CSAN-shell-spawn CSAN-dir mirror) + (newline) + (display "span> ") + (do ((s (read)(read))) + ((null? s)0) + (newline) + (display "span> ") + (cond ((symbol? s) + (cond ((string<=? (symbol->string s)(string #\return)) + 0) + ((string=? "h" (symbol->string s)) + (display "Generating helpfile...")(newline) + (let ((*helpfilename (string-append CSAN-dir "/help"))) + (let ((*in (if (file-exists? *helpfilename) + (open-input-file *helpfilename) + (begin + (display "no helpfile...") + ((CSAN-generate "helpfile")))))) + (for-each write (read *in)))) + 0) + ((string<=? "get" (symbol->string s)) + (display "enter package to fetch : ") + (CSAN-ask-server (string-append "get " (symbol->string (read))) + (url-bite-off mirror) 6969)) + )) + )) + (display "span> signing off."))