The Lambda Lab
/
projects
/
lambdamail.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
4106bac
)
Implementing AUTH PLAIN authentication.
author
Tim Vaughan
<tgvaughan@gmail.com>
Mon, 2 Sep 2019 13:34:20 +0000
(15:34 +0200)
committer
Tim Vaughan
<tgvaughan@gmail.com>
Mon, 2 Sep 2019 13:34:20 +0000
(15:34 +0200)
lambdamail.scm
patch
|
blob
|
history
diff --git
a/lambdamail.scm
b/lambdamail.scm
index
cffc81f
..
1e9fb4d
100644
(file)
--- a/
lambdamail.scm
+++ b/
lambdamail.scm
@@
-14,7
+14,7
@@
(chicken process-context)
(chicken process-context posix)
(chicken condition)
(chicken process-context)
(chicken process-context posix)
(chicken condition)
- srfi-1 srfi-13)
+ srfi-1 srfi-13
matchable
)
(define lambdamail-version "0.0.1")
(define lambdamail-version "0.0.1")
@@
-28,17
+28,19
@@
;;; SMTP transactions
;;
;;; SMTP transactions
;;
-(define ((make-smtp in-port out-port config)
type
)
- (if (eq
? type 'get-line
)
+(define ((make-smtp in-port out-port config)
. msg
)
+ (if (eq
ual? msg '(get-line)
)
(read-line in-port)
(write-line (conc
(read-line in-port)
(write-line (conc
- (
case type
- ((greeting) (conc "220 " (config-host config)
+ (
match msg
+ ((
'
greeting) (conc "220 " (config-host config)
" LambdaMail v" lambdamail-version))
" LambdaMail v" lambdamail-version))
- ((ok) "250 ok")
- ((intermediate) "354 intermediate")
- ((close) "221 closing transmission channel")
- ((not-implemented) "502 command not implemented"))
+ (('ok) "250 ok")
+ (('ehlo host) (conc "250-" (config-host config) " Hello " host "\r\n"
+ "250 AUTH PLAIN"))
+ (('intermediate) "354 intermediate")
+ (('close) "221 closing transmission channel")
+ (('not-implemented) "502 command not implemented"))
"\r") out-port)))
"\r") out-port)))
@@
-90,12
+92,15
@@
(line-orig (smtp 'get-line)))
(if (string? line-orig)
(let ((line (string-downcase line-orig)))
(line-orig (smtp 'get-line)))
(if (string? line-orig)
(let ((line (string-downcase line-orig)))
- (print "got " line)
+ (print "got " line
-orig
)
(cond
((string-prefix? "helo" line)
(message-helo-set! msg (string-drop line (string-length "helo")))
(smtp 'ok)
(loop msg (smtp 'get-line)))
(cond
((string-prefix? "helo" line)
(message-helo-set! msg (string-drop line (string-length "helo")))
(smtp 'ok)
(loop msg (smtp 'get-line)))
+ ((string-prefix? "ehlo" line)
+ (smtp 'ehlo (string-drop line (+ 1 (string-length "ehlo"))))
+ (loop msg (smtp 'get-line)))
((string-prefix? "mail from:" line)
(message-from-set! msg (string-drop line (string-length "mail from:")))
(smtp 'ok)
((string-prefix? "mail from:" line)
(message-from-set! msg (string-drop line (string-length "mail from:")))
(smtp 'ok)
@@
-142,14
+147,6
@@
(right-idx (substring-index ">" addr)))
(substring addr (+ left-idx 1) right-idx)))
(right-idx (substring-index ">" addr)))
(substring addr (+ left-idx 1) right-idx)))
-(define (deliver-message-mbox msg dest-file)
- (print "Delivering to mbox " dest-file)
- (with-output-to-file dest-file
- (lambda ()
- (print "\nFrom " (remove-angle-brackets (message-from msg)))
- (print (message-text msg)))
- #:append))
-
(define (deliver-message-maildir msg dest-dir)
(print "Delivering to maildir " dest-dir)
(with-output-to-file (conc dest-dir "/" (current-seconds))
(define (deliver-message-maildir msg dest-dir)
(print "Delivering to maildir " dest-dir)
(with-output-to-file (conc dest-dir "/" (current-seconds))
@@
-209,7
+206,7
@@
(unless (null? rest-args)
(config-port-set! config (string->number (car rest-args)))
(unless (null? (cdr rest-args))
(unless (null? rest-args)
(config-port-set! config (string->number (car rest-args)))
(unless (null? (cdr rest-args))
- (config-spool-dir-set! (cadr rest-args))))
+ (config-spool-dir-set!
config
(cadr rest-args))))
(run-server config))))))))
(main)
(run-server config))))))))
(main)