From bffa65529b37db14f8236236e6980d1abbe736eb Mon Sep 17 00:00:00 2001 From: erana Date: Tue, 17 Jan 2012 18:39:47 +0900 Subject: [PATCH] schemedoc regexps - 1 --- scsh/tmail/tdaemon.scm | 38 ++++------ scsh/tmail/tforks.scm | 159 +++++++++++++++++++--------------------- scsh/tmail/trecords.scm | 40 ++++------ scsh/tmail/util.scm | 8 +- 4 files changed, 106 insertions(+), 139 deletions(-) diff --git a/scsh/tmail/tdaemon.scm b/scsh/tmail/tdaemon.scm index 285b928..0d0d000 100644 --- a/scsh/tmail/tdaemon.scm +++ b/scsh/tmail/tdaemon.scm @@ -1,4 +1,4 @@ -;;; tdaemon.scm - a scheme pop mail daemon (instantiated) +;;; tdaemon.scm - a scheme pop mail daemon (instantiated) ;;; ;;; Copyright (c) 2011-2012 Johan Ceuppens ;;; @@ -26,34 +26,22 @@ ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF ;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -;;#!/home/erana/scheme/bin/scsh -ds \ -;;!# - -;;#!/home/erana/scheme/bin/scsh \ -;;-lm tmail.scm -o mail-daemon -s - (load "trecords.scm") -(load "tclient.scm") -(load "tserver.scm") (load "tforks.scm") -(display "FIXMES: mail-daemon structure needs carriage return statement") (newline) -(define rc (make-daemon-record - (delay "localhost") ;; virtual host - (delay 1110) - (delay (open-socket (force (port rc)))) - (delay "POP3 tmail server ready") - (delay "+OK ") - (delay "APOP ") - (delay "STAT") - (delay "LIST") - (delay "+OK POP3 server signing off") - (delay "Exceeded maximum transactions.") - (delay "500 Command not understood.") - (delay "HELO") - (delay "EHLO"))) -(run-daemon-child rc) +(define rc (make-daemon-record + "localhost" ;; virtual host + 1110 + #f + "POP3 tmail server ready" + "+OK " + "APOP " + "STAT" + "LIST" + "+OK POP3 server signing off" + )) +(run-daemon-child-mail rc) (display "mail-daemon ends.") (newline) diff --git a/scsh/tmail/tforks.scm b/scsh/tmail/tforks.scm index e54ee83..4813a47 100644 --- a/scsh/tmail/tforks.scm +++ b/scsh/tmail/tforks.scm @@ -26,93 +26,84 @@ ;;; (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 "util.scm") (load "trecords.scm") -(load "tserver.scm") (load "tmailbox-load.scm") -;; You can spawn this +(define (run-daemon-child-mail 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))) -(define (run-daemon-child rec) - (display "Opening listening socket on host : ") - (display (force (hostname rec))) - (display " port unknown at this stage, default 1110 ") - (display " ...") - (newline) - (fork-and-forget - (let ((socket (force (sock rec)))) - (begin - ( - (lambda (request portnumber) - (call-with-values - (lambda () - (socket-accept socket)) - (lambda (in out) - (write request out) - (do ((i 0 (+ i 1))) - ((> i 9)(display "Quitting mail daemon child.")(newline)) - ;; (iterate loop - ;; ((count* i 0)) - ;; () - ;; (if (>= i 10) - ;; (display "Quitting mail daemon child.")(newline) + (set! *socket (open-socket *port)) + (for-each display '("Opening listening socket on host : " + *hostname + " port : " + *port + (eoln))) - (call-with-values ;; FIXME (let ((answer2 (read in))) - (lambda () - (list (read in)(read in))) - (lambda (answer) - (let ((answer2 (car answer)) - (answer3 (if (not (null? (cdr answer))) - (cadr answer) - 'foo))) - (display "Asked something : ")(display (symbol->string answer2))(display " ")(display answer3)(newline) - (if (symbol? answer2) - (cond ((eq? 'APOP answer2) - (write mailbox-contents out) - ;; FIXME write "" to user's mailbox file - ;;(let ((out2 (open-output-file (string-append spooldirectory (getenv "USER"))))) - ;; (write out2 "")) - ) - ((eq? 'STAT answer2) - #t) - ((eq? 'LIST answer2) - #t) - ((eq? 'RETR answer2) - (let ((idx (string->number (symbol->string answer3)))) - (if idx - (write (tmail-get-mail-with-index (getenv "USER") idx) out)))) - ;; for brokeness - ((eq? 'USER answer2) - ;;FIXME overflow - (let ((username (if (number? answer3) - (number->string answer3) - (symbol->string answer3)))) - (setenv "USER" username) - (write "+OK user accepted - not implemented" out))) - ((eq? 'PASS answer2) - (let ((pass (if (number? answer3) - (number->string answer3) - (symbol->string answer3)))) - (write "+OK password accepted - not implemented" out))) - ((eq? 'QUIT answer2) - (write (force (BYE rec)) out) - (close-input-port in) - (close-socket socket) - (close-output-port out) - (exit)) - (else - (write (force (ERROR500 rec)) out)) - )) - )))) - (write (force (SPAWNEND rec)) out) - (write (force (BYE rec)) out) - - (close-input-port in) - (close-socket socket) - (close-output-port out) - - (exit) - - ))) - (force (MOTD rec)) (port rec)) - )))) \ No newline at end of file + ((lambda (portnumber) + (call-with-values + (lambda () + (socket-accept *socket)) + (lambda (in out) + (write *motd out) + (do ((i 0 (+ i 1))) ;; iterate + ((> i 9)(display *bye)(newline)) + (call-with-values + (lambda () + '((read in)(read in)(read in))) + (lambda (answer) + (let ((answer2 (car answer)) + (answer3 (if (not (null? (cdr answer))) + (cadr answer) + 'foo))) + (for-each display '((servermsg) (symbol->string answer2) " " answer3 (eoln))) + (if (symbol? answer2) + (cond ((eq? 'APOP answer2) + (write mailbox-contents out) + ) + ((eq? 'STAT answer2) + #t) + ((eq? 'LIST answer2) + #t) + ((eq? 'RETR answer2) + (let ((idx (string->number (symbol->string answer3)))) + (if idx + (write (tmail-get-mail-with-index (getenv "USER") idx) out)))) + ((eq? 'USER answer2) + (let ((username (if (number? answer3) + (number->string answer3) + (symbol->string answer3)))) + (setenv "USER" username) + (write "+OK user accepted - not implemented" out))) + ((eq? 'PASS answer2) + (let ((pass (if (number? answer3) + (number->string answer3) + (symbol->string answer3)))) + (write "+OK password accepted - not implemented" out))) + ((eq? 'QUIT answer2) + (write *bye out) + (close-input-port in) + (close-socket *socket) + (close-output-port out) + (exit)) + (else + (write (errormsg) out)) + )) + )))) + (write *bye out) + (close-input-port in) + (close-socket *socket) + (close-output-port out) + (exit) + ))) + *port) + )) \ No newline at end of file diff --git a/scsh/tmail/trecords.scm b/scsh/tmail/trecords.scm index 6782ac5..d7bb7d7 100644 --- a/scsh/tmail/trecords.scm +++ b/scsh/tmail/trecords.scm @@ -1,4 +1,4 @@ -;;; trecords.scm - records for tmail +;;; trecords.scm - records for tmail ;;; ;;; Copyright (c) 2011-2012 Johan Ceuppens ;;; @@ -27,31 +27,19 @@ ;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (define :daemon-record - (make-record-type 'daemon-record - '(hostname port sock MOTD ACK APOP STAT LIST BYE SPAWNEND ERROR500 HELO EHLO))) -(define make-daemon-record - (record-constructor :daemon-record - '(hostname port sock MOTD ACK APOP STAT LIST BYE SPAWNEND ERROR500 HELO EHLO))) -;; (define make-daemon-record-default -;; (record-constructor :daemon-record -;; '(hostname -;; 1025 #f -;; "Hello." -;; "OK." -;; "Bye." -;; "500 Command not understood." -;; "EHLO Server ready."))) + (make-record-type 'daemon-record + '(hostname port sock motd ack apop stat list bye))) +(define make-daemon-record + (record-constructor :daemon-record + '(hostname port sock motd ack apop stat list bye))) + (define hostname (record-accessor :daemon-record 'hostname)) (define port (record-accessor :daemon-record 'port)) (define sock (record-accessor :daemon-record 'sock)) -(define MOTD (record-accessor :daemon-record 'MOTD)) -(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 'LIST)) -(define BYE (record-accessor :daemon-record 'BYE)) -(define SPAWNEND (record-accessor :daemon-record 'SPAWNEND)) -(define ERROR500 (record-accessor :daemon-record 'ERROR500)) -(define HELO (record-accessor :daemon-record 'HELO)) -(define EHLO (record-accessor :daemon-record 'EHLO)) - +(define motd (record-accessor :daemon-record 'motd)) +(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 bye (record-accessor :daemon-record 'bye)) + diff --git a/scsh/tmail/util.scm b/scsh/tmail/util.scm index f6a5e40..2a3e875 100644 --- a/scsh/tmail/util.scm +++ b/scsh/tmail/util.scm @@ -1,4 +1,4 @@ -;;; util.scm - tmail utilities +;;; util.scm - tmail utilities ;;; ;;; Copyright (c) 2011-2012 Johan Ceuppens ;;; @@ -26,6 +26,6 @@ ;;; (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 (aspecterror) (display " message not understood. ")) - - +(define (errormsg) (display " message not understood. ")) +(define (eoln) (string #\newline)) +(define (servermsg) (display "::message::"))