-(define (process-smtp smtp config)
- (let loop ((msg (make-empty-message))
- (line-orig (smtp 'get-line)))
- (if (string? line-orig)
- (let ((line (string-downcase line-orig)))
- (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)))
- ((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)
- (loop msg (smtp 'get-line)))
- ((string-prefix? "rcpt to:" line)
- (message-to-set! msg (string-drop line (string-length "rcpt to:")))
- (smtp 'ok)
- (loop msg (smtp 'get-line)))
- ((string-prefix? "data" line)
- (smtp 'intermediate)
- (let text-loop ((text-line (smtp 'get-line))
- (text ""))
- (if (string=? "." text-line)
- (message-text-set! msg text)
- (text-loop (smtp 'get-line)
- (conc text text-line "\n"))))
- (process-message msg config)
- (smtp 'ok)
- (loop (make-empty-message)
- (smtp 'get-line)))
- ((string-prefix? "quit" line)
- (smtp 'close)
- 'done)
- ((string=? "" line)
- (loop msg (smtp 'get-line)))
- (else
- (smtp 'not-implemented)
- (loop msg (smtp 'get-line)))))
- 'done)))
+(define (process-smtp smtp-session config)
+ (let loop ((msg (make-empty-message)))
+ (let ((line-orig (smtp-session 'get-line)))
+ (if (string? line-orig)
+ (let ((line (string-downcase line-orig)))
+ (print "got " line-orig)
+ (cond
+ ((string-prefix? "helo" line)
+ (message-helo-set! msg (string-drop line (string-length "helo")))
+ (smtp-session 'ok)
+ (loop msg))
+ ((string-prefix? "ehlo" line)
+ (smtp-session 'ehlo (string-drop line (+ 1 (string-length "ehlo"))))
+ (loop msg))
+ ((string-prefix? "auth plain" line)
+ (let* ((auth-string (string-drop line-orig (+ 1 (string-length "auth plain"))))
+ (auth-decoded (base64-decode auth-string))
+ (auth-list (string-split auth-decoded "\x00"))
+ (user (car auth-list))
+ (password (cadr auth-list)))
+ (smtp-session 'set-user! user)
+ (smtp-session 'set-password! password)
+ (print "Attempted login, user: " user ", password: " password)
+ (smtp-session 'auth-success)
+ (loop msg)))
+ ((string-prefix? "mail from:" line)
+ (message-from-set! msg (string-drop line (string-length "mail from:")))
+ (smtp-session 'ok)
+ (loop msg))
+ ((string-prefix? "rcpt to:" line)
+ (message-to-set! msg (string-drop line (string-length "rcpt to:")))
+ (smtp-session 'ok)
+ (loop msg))
+ ((string-prefix? "data" line)
+ (smtp-session 'intermediate)
+ (let text-loop ((text-line (smtp-session 'get-line))
+ (text ""))
+ (if (string=? "." text-line)
+ (message-text-set! msg text)
+ (text-loop (smtp-session 'get-line)
+ (conc text text-line "\n"))))
+ (process-message msg config)
+ (smtp-session 'ok)
+ (loop (make-empty-message)))
+ ((string-prefix? "quit" line)
+ (smtp-session 'close)
+ 'done)
+ ((string=? "" line)
+ (loop msg))
+ (else
+ (smtp-session 'not-implemented)
+ (loop msg))))
+ 'done))))