;;; -*-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
;;;
(define url-protocol-parsers
(make-string-hash-table))
-
-(define-generic url-user-id (url))
-(define-method url-user-id ((url <url>)) url #f)
\f
;;;; Server operations
;;; -*-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
;;;
(constructor (user-id auth-type host port mailbox uid)))
(<url>)
;; 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.
(uid define accessor))
(define-url-protocol "imap" <imap-url>
- (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 <imap-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
(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)))
;;; -*-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
;;;
#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 \":<port>\".
+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?)
\f
(define-command imail
(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
" 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)
(and (if (default-object? error?) #t error?)
(error:bad-range-argument buffer 'SELECTED-FOLDER))))))
\f
+(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))
+\f
(define-major-mode imail read-only "IMAIL"
"IMAIL mode is used by \\[imail] for editing IMAIL files.
All normal editing commands are turned off.
projects / mit-scheme.git / commitdiff