From 27d6be7ddfe896a6901188ee63a3a064ee416b1a Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 5 May 2000 17:18:17 +0000 Subject: [PATCH] Change the way that URLs are handled by the top level. A partial IMAP URL may now be specified, and default values are filled in to complete the URL before it is handed to the IMAP communications layer. --- v7/src/imail/imail-core.scm | 5 +- v7/src/imail/imail-imap.scm | 91 +++++++++++++++--------------- v7/src/imail/imail-top.scm | 107 +++++++++++++++++++++++++++++------- 3 files changed, 134 insertions(+), 69 deletions(-) diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm index a196f95bc..9d92c584d 100644 --- a/v7/src/imail/imail-core.scm +++ b/v7/src/imail/imail-core.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-core.scm,v 1.40 2000/05/04 18:52:52 cph Exp $ +;;; $Id: imail-core.scm,v 1.41 2000/05/05 17:18:10 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -78,9 +78,6 @@ (define url-protocol-parsers (make-string-hash-table)) - -(define-generic url-user-id (url)) -(define-method url-user-id ((url )) url #f) ;;;; Server operations diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm index 546ec8c18..89877fabf 100644 --- a/v7/src/imail/imail-imap.scm +++ b/v7/src/imail/imail-imap.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-imap.scm,v 1.17 2000/05/04 22:21:27 cph Exp $ +;;; $Id: imail-imap.scm,v 1.18 2000/05/05 17:18:14 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -28,7 +28,7 @@ (constructor (user-id auth-type host port mailbox uid))) () ;; User name to connect as. - (user-id accessor url-user-id) + (user-id define accessor) ;; Type of authentication to use. Ignored. (auth-type define accessor) ;; Name or IP address of host to connect to. @@ -41,52 +41,55 @@ (uid define accessor)) (define-url-protocol "imap" - (lambda (string) - (let ((lose (lambda () (error:bad-range-argument string #f)))) - (if (not (string-prefix? "//" string)) - (lose)) + (let ((//server/ + (optional-parser + (sequence-parser (noise-parser (string-matcher "//")) + imap:parse:server + (noise-parser (string-matcher "/"))))) + (mbox (optional-parser imap:parse:simple-message))) + (lambda (string) (let ((end (string-length string))) - (let ((slash (substring-find-next-char string 2 end #\/))) - (if (not slash) - (lose)) - (let ((pv1 (parse-substring imap:parse:server string 2 slash))) - (if (not pv1) - (lose)) - (let ((pv2 - (parse-substring imap:parse:simple-message - string (fix:+ slash 1) end))) - (if (not pv2) - (lose)) - (make-imap-url (parser-token pv1 'USER-ID) - (parser-token pv1 'AUTH-TYPE) - (parser-token pv1 'HOST) - (parser-token pv1 'PORT) - (parser-token pv2 'MAILBOX) - (parser-token pv2 'UID))))))))) + (let ((pv1 (//server/ string 0 end))) + (let ((pv2 + (or (parse-substring mbox string (car pv1) end) + (error:bad-range-argument string 'STRING->URL)))) + (make-imap-url (parser-token pv1 'USER-ID) + (parser-token pv1 'AUTH-TYPE) + (parser-token pv1 'HOST) + (let ((port (parser-token pv1 'PORT))) + (and port + (string->number port))) + (parser-token pv2 'MAILBOX) + (parser-token pv2 'UID)))))))) (define-method url-body ((url )) (string-append - "//" - (let ((user-id (url-user-id url)) - (auth-type (imap-url-auth-type url))) - (if (or user-id auth-type) - (string-append (if user-id - (url:encode-string user-id) - "") - (if auth-type - (string-append ";auth=" - (if (string=? auth-type "*") - auth-type - (url:encode-string auth-type))) - "") - "@") - "")) - (imap-url-host url) - (let ((port (imap-url-port url))) - (if port - (string-append ":" port) + (let ((user-id (imap-url-user-id url)) + (auth-type (imap-url-auth-type url)) + (host (imap-url-host url)) + (port (imap-url-port url))) + (if (or user-id auth-type host port) + (string-append + "//" + (if (or user-id auth-type) + (string-append (if user-id + (url:encode-string user-id) + "") + (if auth-type + (string-append + ";auth=" + (if (string=? auth-type "*") + auth-type + (url:encode-string auth-type))) + "") + "@") + "") + host + (if port + (string-append ":" (number->string port)) + "") + "/") "")) - "/" (url:encode-string (imap-url-mailbox url)) (let ((uid (imap-url-uid url))) (if uid @@ -158,7 +161,7 @@ (define (get-imap-connection url) (let ((host (imap-url-host url)) (ip-port (imap-url-port url)) - (user-id (or (url-user-id url) (imail-default-user-id)))) + (user-id (or (imap-url-user-id url) (imail-default-user-id)))) (let loop ((connections memoized-imap-connections) (prev #f)) (if (weak-pair? connections) (let ((connection (weak-car connections))) diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm index 94d5223c9..402bd0352 100644 --- a/v7/src/imail/imail-top.scm +++ b/v7/src/imail/imail-top.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-top.scm,v 1.35 2000/05/04 22:37:06 cph Exp $ +;;; $Id: imail-top.scm,v 1.36 2000/05/05 17:18:17 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -77,15 +77,30 @@ The procedure is called with one argument, a list of headers, #f boolean?) -(define-variable imail-user-name - "A user name to use when authenticating to a mail server. -#f means use the default user name." +(define-variable imail-primary-folder + "URL for the primary folder that you read your mail from." #f string-or-false?) -(define-variable imail-primary-folder - "URL for the primary folder that you read your mail from." - "rmail:RMAIL" +(define-variable imail-default-imap-server + "The hostname of an IMAP server to connect to if none is otherwise specified. +May contain an optional port suffix \":\". +May be overridden by an explicit hostname in imail-primary-folder." + "localhost" + string?) + +(define-variable imail-default-user-id + "A user id to use when authenticating to a mail server. +#F means use the id of the user running Edwin. +May be overridden by an explicit user id in imail-primary-folder." + #f + string-or-false?) + +(define-variable imail-default-imap-mailbox + "The name of the default mailbox to connect to on an IMAP server, +if none is otherwise specified. +May be overridden by an explicit mailbox in imail-primary-folder." + "inbox" string?) (define-command imail @@ -100,7 +115,9 @@ May be called with an IMAIL folder URL as argument; (bind-authenticator imail-authenticator (lambda () (let* ((url - (->url (or url-string (ref-variable imail-primary-folder)))) + (if url-string + (imail-parse-partial-url url-string) + (imail-default-url))) (folder (open-folder url))) (select-buffer (let ((buffer @@ -117,19 +134,6 @@ May be called with an IMAIL folder URL as argument; " on host " host) receiver)) -(define (imail-default-user-id) - (or (ref-variable imail-user-name) - (current-user-name))) - -(define (imail-present-user-alert procedure) - (call-with-output-to-temporary-buffer " *IMAP alert*" - '(READ-ONLY SHRINK-WINDOW - FLUSH-ON-SPACE) - procedure)) - -(define (imail-message-wrapper . arguments) - (apply message-wrapper #f arguments)) - (define (associate-imail-folder-with-buffer folder buffer) (buffer-put! buffer 'IMAIL-FOLDER folder) (folder-put! folder 'BUFFER buffer) @@ -163,6 +167,67 @@ May be called with an IMAIL folder URL as argument; (and (if (default-object? error?) #t error?) (error:bad-range-argument buffer 'SELECTED-FOLDER)))))) +(define (imail-default-url) + (let ((primary-folder (ref-variable imail-primary-folder))) + (if primary-folder + (imail-parse-partial-url primary-folder) + (imail-default-imap-url)))) + +(define (imail-parse-partial-url string) + (let ((url + (->url + (let ((colon (string-find-next-char string #\:))) + (if colon + string + (string-append "imap:" string)))))) + (if (and (imap-url? url) + (not (and (imap-url-user-id url) + (imap-url-host url) + (imap-url-port url) + (imap-url-mailbox url)))) + (let ((url* (imail-default-imap-url))) + (make-imap-url (or (imap-url-user-id url) + (imap-url-user-id url*)) + (or (imap-url-auth-type url) + (imap-url-auth-type url*)) + (or (imap-url-host url) + (imap-url-host url*)) + (or (imap-url-port url) + (imap-url-port url*)) + (or (imap-url-mailbox url) + (imap-url-mailbox url*)) + (or (imap-url-uid url) + (imap-url-uid url*)))) + url))) + +(define (imail-default-imap-url) + (call-with-values + (lambda () + (let ((server (ref-variable imail-default-imap-server))) + (let ((colon (string-find-next-char server #\:))) + (if colon + (values (string-head server colon) + (or (string->number (string-tail server (+ colon 1))) + (error "Invalid port specification:" server))) + (values server #f))))) + (lambda (host port) + (make-imap-url (or (ref-variable imail-default-user-id) + (current-user-name)) + #f + host + port + (ref-variable imail-default-imap-mailbox) + #f)))) + +(define (imail-present-user-alert procedure) + (call-with-output-to-temporary-buffer " *IMAP alert*" + '(READ-ONLY SHRINK-WINDOW + FLUSH-ON-SPACE) + procedure)) + +(define (imail-message-wrapper . arguments) + (apply message-wrapper #f arguments)) + (define-major-mode imail read-only "IMAIL" "IMAIL mode is used by \\[imail] for editing IMAIL files. All normal editing commands are turned off. -- 2.25.1