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
;;;
@ -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)

159
scsh/tmail/tforks.scm
View File

@ -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))
))))
((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)
))

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
;;;
@ -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))

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
;;;
@ -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::"))