SPAN - server side daemon - 1

scsh/SPAN/SPAN-server-daemon-record.scm

@@ -0,0 +1,42 @@
+;;; SPAN-server-daemon-record.scm - records for SPAN 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 :SPAN-daemon-record
+  (make-record-type 'SPAN-daemon-record
+		    '(hostname port sock motd ack bye)))
+(define make-SPAN-daemon-record
+  (record-constructor :SPAN-daemon-record
+		      '(hostname port sock motd ack bye)))
+
+(define hostname (record-accessor :SPAN-daemon-record 'hostname))
+(define port (record-accessor :SPAN-daemon-record 'port))
+(define sock (record-accessor :SPAN-daemon-record 'sock))
+(define motd (record-accessor :SPAN-daemon-record 'motd))
+(define ack (record-accessor :SPAN-daemon-record 'ack))
+(define bye (record-accessor :SPAN-daemon-record 'bye))
+

scsh/SPAN/SPAN-server-daemon.scm

@@ -0,0 +1,95 @@
+;;; 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.
+
+(load "SPAN-server-daemon-record.scm")
+
+(define (errormsg) (display " message not understood. "))
+(define (eoln) (string #\newline))
+(define (servermsg) (display "::message::"))
+
+
+(define (run-daemon-child-SPAN 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 SPAN 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 (tmail-get-mail-with-index (getenv "USER") idx) out)))
+                       ((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
+	    "SPAN server side ready."
+	    "Scheming..."
+            "SPAN server signing off."
+            ))
+
+(run-daemon-child-SPAN rc)

scsh/SPAN/packages.scm

@@ -1,10 +1,9 @@
 (define-interface SPAN-interface
   (export
-   make-SPAN-server
-   make-SPAN-client))
+   SPAN-question~))
 
 (define-structure SPAN 
   schemedoc-interface
   (open scheme)
-  (files SPAN-client SPAN-server SPAN))
+  (files SPAN-client SPAN-server SPAN load SPAN-util))
 

scsh/SPAN/pkg-def.scm

@@ -11,5 +11,6 @@
   (install-file "packages.scm" 'scheme)
   (install-file "SPAN-client.scm" 'scheme)
   (install-file "SPAN-server.scm" 'scheme)
+  (install-file "SPAN-util.scm" 'scheme)
   (install-file "load.scm" 'scheme)
   (install-file "SPAN.scm" 'scheme))

scsh/tmail/trecords.scm

@@ -40,6 +40,6 @@
 (define ack (record-accessor :daemon-record 'ack))
 (define apop (record-accessor :daemon-record 'apop))
 (define stat (record-accessor :daemon-record 'stat))
-(define list (record-accessor :daemon-record 'Llist))
+(define list (record-accessor :daemon-record 'list))
 (define bye (record-accessor :daemon-record 'bye))