scsh-conservatory
/
sunterlib
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

schemedoc regexps - 1

This commit is contained in:
erana 2012-01-17 18:39:47 +09:00
parent 92499b2635
commit bffa65529b
4 changed files with 106 additions and 139 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
scsh/tmail/tdaemon.scm
View File

@ -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 ;;; Copyright (c) 2011-2012 Johan Ceuppens
;;; ;;;
@ -26,34 +26,22 @@
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; 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 "trecords.scm")
(load "tclient.scm")
(load "tserver.scm")
(load "tforks.scm") (load "tforks.scm")
(display "FIXMES: mail-daemon structure needs carriage return statement")
(newline) (newline)
(define rc (make-daemon-record (define rc (make-daemon-record
(delay "localhost") ;; virtual host "localhost" ;; virtual host
(delay 1110) 1110
(delay (open-socket (force (port rc)))) #f
(delay "POP3 tmail server ready") "POP3 tmail server ready"
(delay "+OK ") "+OK "
(delay "APOP ") "APOP "
(delay "STAT") "STAT"
(delay "LIST") "LIST"
(delay "+OK POP3 server signing off") "+OK POP3 server signing off"
(delay "Exceeded maximum transactions.") ))
(delay "500 Command not understood.") (run-daemon-child-mail rc)
(delay "HELO")
(delay "EHLO")))
(run-daemon-child rc)
(display "mail-daemon ends.") (display "mail-daemon ends.")
(newline) (newline)

159
scsh/tmail/tforks.scm
View File

@ -26,93 +26,84 @@
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(load "util.scm")
(load "trecords.scm") (load "trecords.scm")
(load "tserver.scm")
(load "tmailbox-load.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) (set! *socket (open-socket *port))
(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)
(for-each display '("Opening listening socket on host : "
*hostname
" port : "
*port
(eoln)))
(call-with-values ;; FIXME (let ((answer2 (read in))) ((lambda (portnumber)
(lambda () (call-with-values
(list (read in)(read in))) (lambda ()
(lambda (answer) (socket-accept *socket))
(let ((answer2 (car answer)) (lambda (in out)
(answer3 (if (not (null? (cdr answer))) (write *motd out)
(cadr answer) (do ((i 0 (+ i 1))) ;; iterate
'foo))) ((> i 9)(display *bye)(newline))
(display "Asked something : ")(display (symbol->string answer2))(display " ")(display answer3)(newline) (call-with-values
(if (symbol? answer2) (lambda ()
(cond ((eq? 'APOP answer2) '((read in)(read in)(read in)))
(write mailbox-contents out) (lambda (answer)
;; FIXME write "" to user's mailbox file (let ((answer2 (car answer))
;;(let ((out2 (open-output-file (string-append spooldirectory (getenv "USER"))))) (answer3 (if (not (null? (cdr answer)))
;; (write out2 "")) (cadr answer)
) 'foo)))
((eq? 'STAT answer2) (for-each display '((servermsg) (symbol->string answer2) " " answer3 (eoln)))
#t) (if (symbol? answer2)
((eq? 'LIST answer2) (cond ((eq? 'APOP answer2)
#t) (write mailbox-contents out)
((eq? 'RETR answer2) )
(let ((idx (string->number (symbol->string answer3)))) ((eq? 'STAT answer2)
(if idx #t)
(write (tmail-get-mail-with-index (getenv "USER") idx) out)))) ((eq? 'LIST answer2)
;; for brokeness #t)
((eq? 'USER answer2) ((eq? 'RETR answer2)
;;FIXME overflow (let ((idx (string->number (symbol->string answer3))))
(let ((username (if (number? answer3) (if idx
(number->string answer3) (write (tmail-get-mail-with-index (getenv "USER") idx) out))))
(symbol->string answer3)))) ((eq? 'USER answer2)
(setenv "USER" username) (let ((username (if (number? answer3)
(write "+OK user accepted - not implemented" out))) (number->string answer3)
((eq? 'PASS answer2) (symbol->string answer3))))
(let ((pass (if (number? answer3) (setenv "USER" username)
(number->string answer3) (write "+OK user accepted - not implemented" out)))
(symbol->string answer3)))) ((eq? 'PASS answer2)
(write "+OK password accepted - not implemented" out))) (let ((pass (if (number? answer3)
((eq? 'QUIT answer2) (number->string answer3)
(write (force (BYE rec)) out) (symbol->string answer3))))
(close-input-port in) (write "+OK password accepted - not implemented" out)))
(close-socket socket) ((eq? 'QUIT answer2)
(close-output-port out) (write *bye out)
(exit)) (close-input-port in)
(else (close-socket *socket)
(write (force (ERROR500 rec)) out)) (close-output-port out)
)) (exit))
)))) (else
(write (force (SPAWNEND rec)) out) (write (errormsg) out))
(write (force (BYE rec)) out) ))
))))
(close-input-port in) (write *bye out)
(close-socket socket) (close-input-port in)
(close-output-port out) (close-socket *socket)
(close-output-port out)
(exit) (exit)
)))
))) *port)
(force (MOTD rec)) (port rec)) ))
))))

40
scsh/tmail/trecords.scm
View File

@ -1,4 +1,4 @@
;;; trecords.scm - records for tmail ;;; trecords.scm - records for tmail
;;; ;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens ;;; Copyright (c) 2011-2012 Johan Ceuppens
;;; ;;;
@ -27,31 +27,19 @@
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(define :daemon-record (define :daemon-record
(make-record-type 'daemon-record (make-record-type 'daemon-record
'(hostname port sock MOTD ACK APOP STAT LIST BYE SPAWNEND ERROR500 HELO EHLO))) '(hostname port sock motd ack apop stat list bye)))
(define make-daemon-record (define make-daemon-record
(record-constructor :daemon-record (record-constructor :daemon-record
'(hostname port sock MOTD ACK APOP STAT LIST BYE SPAWNEND ERROR500 HELO EHLO))) '(hostname port sock motd ack apop stat list bye)))
;; (define make-daemon-record-default
;; (record-constructor :daemon-record
;; '(hostname
;; 1025 #f
;; "Hello."
;; "OK."
;; "Bye."
;; "500 Command not understood."
;; "EHLO Server ready.")))
(define hostname (record-accessor :daemon-record 'hostname)) (define hostname (record-accessor :daemon-record 'hostname))
(define port (record-accessor :daemon-record 'port)) (define port (record-accessor :daemon-record 'port))
(define sock (record-accessor :daemon-record 'sock)) (define sock (record-accessor :daemon-record 'sock))
(define MOTD (record-accessor :daemon-record 'MOTD)) (define motd (record-accessor :daemon-record 'motd))
(define ACK (record-accessor :daemon-record 'ACK)) (define ack (record-accessor :daemon-record 'ack))
(define APOP (record-accessor :daemon-record 'APOP)) (define apop (record-accessor :daemon-record 'apop))
(define STAT (record-accessor :daemon-record 'STAT)) (define stat (record-accessor :daemon-record 'stat))
(define LIST (record-accessor :daemon-record 'LIST)) (define list (record-accessor :daemon-record 'Llist))
(define BYE (record-accessor :daemon-record 'BYE)) (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))

8
scsh/tmail/util.scm
View File

@ -1,4 +1,4 @@
;;; util.scm - tmail utilities ;;; util.scm - tmail utilities
;;; ;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens ;;; Copyright (c) 2011-2012 Johan Ceuppens
;;; ;;;
@ -26,6 +26,6 @@
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; 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::"))