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

34
scsh/tmail/tdaemon.scm
View File

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

77
scsh/tmail/tforks.scm
View File

@ -26,52 +26,49 @@
;;; (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))) (for-each display '("Opening listening socket on host : "
(display " port unknown at this stage, default 1110 ") *hostname
(display " ...") " port : "
(newline) *port
(fork-and-forget (eoln)))
(let ((socket (force (sock rec))))
(begin ((lambda (portnumber)
(
(lambda (request portnumber)
(call-with-values (call-with-values
(lambda () (lambda ()
(socket-accept socket)) (socket-accept *socket))
(lambda (in out) (lambda (in out)
(write request out) (write *motd out)
(do ((i 0 (+ i 1))) (do ((i 0 (+ i 1))) ;; iterate
((> i 9)(display "Quitting mail daemon child.")(newline)) ((> i 9)(display *bye)(newline))
;; (iterate loop (call-with-values
;; ((count* i 0))
;; ()
;; (if (>= i 10)
;; (display "Quitting mail daemon child.")(newline)
(call-with-values ;; FIXME (let ((answer2 (read in)))
(lambda () (lambda ()
(list (read in)(read in))) '((read in)(read in)(read in)))
(lambda (answer) (lambda (answer)
(let ((answer2 (car answer)) (let ((answer2 (car answer))
(answer3 (if (not (null? (cdr answer))) (answer3 (if (not (null? (cdr answer)))
(cadr answer) (cadr answer)
'foo))) 'foo)))
(display "Asked something : ")(display (symbol->string answer2))(display " ")(display answer3)(newline) (for-each display '((servermsg) (symbol->string answer2) " " answer3 (eoln)))
(if (symbol? answer2) (if (symbol? answer2)
(cond ((eq? 'APOP answer2) (cond ((eq? 'APOP answer2)
(write mailbox-contents out) (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) ((eq? 'STAT answer2)
#t) #t)
@ -81,9 +78,7 @@
(let ((idx (string->number (symbol->string answer3)))) (let ((idx (string->number (symbol->string answer3))))
(if idx (if idx
(write (tmail-get-mail-with-index (getenv "USER") idx) out)))) (write (tmail-get-mail-with-index (getenv "USER") idx) out))))
;; for brokeness
((eq? 'USER answer2) ((eq? 'USER answer2)
;;FIXME overflow
(let ((username (if (number? answer3) (let ((username (if (number? answer3)
(number->string answer3) (number->string answer3)
(symbol->string answer3)))) (symbol->string answer3))))
@ -95,24 +90,20 @@
(symbol->string answer3)))) (symbol->string answer3))))
(write "+OK password accepted - not implemented" out))) (write "+OK password accepted - not implemented" out)))
((eq? 'QUIT answer2) ((eq? 'QUIT answer2)
(write (force (BYE rec)) out) (write *bye out)
(close-input-port in) (close-input-port in)
(close-socket socket) (close-socket *socket)
(close-output-port out) (close-output-port out)
(exit)) (exit))
(else (else
(write (force (ERROR500 rec)) out)) (write (errormsg) out))
)) ))
)))) ))))
(write (force (SPAWNEND rec)) out) (write *bye out)
(write (force (BYE rec)) out)
(close-input-port in) (close-input-port in)
(close-socket socket) (close-socket *socket)
(close-output-port out) (close-output-port out)
(exit) (exit)
))) )))
(force (MOTD rec)) (port rec)) *port)
)))) ))

30
scsh/tmail/trecords.scm
View File

@ -28,30 +28,18 @@
(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))

6
scsh/tmail/util.scm
View File

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