diff --git a/scheme/lib/pop3.scm b/scheme/lib/pop3.scm index 682ef7d..1d3b2a2 100644 --- a/scheme/lib/pop3.scm +++ b/scheme/lib/pop3.scm @@ -45,20 +45,13 @@ ;; at the beginning of a line by a single decimal point. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;: [host x logfile] -> connection (define (pop3-connect . args) - (let-optionals - args - ((host-arg #f) - (logfile #f)) - (let* ((host (or (getenv "MAILHOST") - host-arg)) - (LOG (and logfile - (open-output-file logfile - (if (file-exists? logfile) - (bitwise-ior open/write open/append) - (bitwise-ior open/write open/create)) - #o600))) + (let-optionals args ((host-arg #f) + (login #f) + (password #f) + (log #f)) + (let* ((host (or host-arg + (getenv "MAILHOST"))) (hst-info (host-info host)) (hostname (host-info:name hst-info)) (srvc-info (service-info "pop3" "tcp")) @@ -68,47 +61,57 @@ (service-info:port srvc-info))) (connection (make-pop3-connection hostname sock - LOG "" "" #f #f))) + log "" "" #f #f))) (pop3-log connection - (format #f "~%-- ~a: opened POP3 connection to ~a" - ;; (date->string (date)) - "Dummy date" ; (format-time-zone) is broken in v0.5.1 - hostname)) + (string-append "-- " + (date->string (date)) + ": opened POP3 connection to " + hostname)) ;; read the challenge the server sends in its welcome banner (let* ((banner (pop3-read-response connection)) - (match (regexp-search (rx (posix-string "\\+OK .* (<[^>]+>)")) banner)) + (match (regexp-search (rx (: "+OK " (* (~ #\<)) + #\< (submatch (+ (~ #\>))) #\>)) + banner)) (challenge (and match (match:substring match 1)))) (set-pop3-connection-challenge! connection challenge)) + (pop3-login connection login password) + connection))) - ;; first try standard USER/PASS authentication, and switch to APOP ;; authentication if the server prefers. -;;: [string x string] -> status -(define (pop3-login connection . args) - (let ((netrc (and (< (length args) 2) (netrc-parse)))) - (let-optionals - args - ((login (or (netrc-lookup-login netrc (pop3-connection-host-name connection) #f) - (call-error "must provide a login" pop3-login args))) - (password (or (netrc-lookup-password netrc - (pop3-connection-host-name connection) #f) - (call-error "must provide a password" pop3-login args)))) - (with-handler - (lambda (result punt) - (if (-ERR? result) - (if (pop3-connection-challenge connection) - (pop3-login/APOP connection login password) - (error "login failed")))) - (lambda () - (pop3-send-command connection (format #f "USER ~a" login)) - (pop3-send-command connection (format #f "PASS ~a" password)) - (set-pop3-connection-login! connection login) - (set-pop3-connection-password! connection password) - (set-pop3-connection-state! connection 'connected)))))) +(define (pop3-login connection login password) + (let* ((netrc-record #f) + (get-netrc-record + (lambda () + (cond + (netrc-record) + (else + (set! netrc-record (netrc-parse)) + netrc-record))))) + (let ((login (or login + (netrc-lookup-login (get-netrc-record) + (pop3-connection-host-name connection) + #f))) + (password (or password + (netrc-lookup-password (get-netrc-record) + (pop3-connection-host-name connection) + #f)))) + (with-fatal-error-handler* + (lambda (result punt) + (cond + ((not (pop3-error? result)) (punt)) + ((pop3-connection-challenge connection) + (pop3-apop-login connection login password)))) + (lambda () + (pop3-send-command connection (format #f "USER ~a" login)) + (pop3-send-command connection (format #f "PASS ~a" password)) + (set-pop3-connection-login! connection login) + (set-pop3-connection-password! connection password) + (set-pop3-connection-state! connection 'connected)))))) ;; Login to the server using APOP authentication (no cleartext ;; passwords are sent over the network). The server appends a token to @@ -133,7 +136,7 @@ ;; c4c9334bac560ecc979e58001b3e22fb ;; ;;: connection x string x string -> status -(define (pop3-login/APOP connection login password) +(define (pop3-apop-login connection login password) (let* ((key (string-append (pop3-connection-challenge connection) password)) (digest (number->string @@ -145,7 +148,7 @@ (set-pop3-connection-password! connection password) (set-pop3-connection-state! connection 'connected) status)) - + ;; return number of messages and number of bytes waiting at the maildrop ;;: connection -> integer x integer @@ -216,10 +219,8 @@ (challenge pop3-connection-challenge set-pop3-connection-challenge!) (state pop3-connection-state set-pop3-connection-state!)) -;; cf /usr/local/src/scheme48-0.49/scheme/rts/condition.scm -(define-condition-type '-ERR '(error)) -(define -ERR? (condition-predicate '-ERR)) - +(define-condition-type 'pop3-error '(error)) +(define pop3-error? (condition-predicate 'pop3-error)) (define (pop3-check-transaction-state connection caller) (if (not (eq? (pop3-connection-state connection) 'connected)) diff --git a/scheme/packages.scm b/scheme/packages.scm index fc5738b..1b38d10 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -127,7 +127,6 @@ (define-interface pop3-interface (export pop3-connect - pop3-login pop3-stat pop3-get pop3-headers @@ -448,7 +447,7 @@ netrc define-record-types handle - conditions + conditions handle-fatal-error signals (subset srfi-13 (string-index)) let-opt