;;; POP3.scm --- implement the POP3 maildrop protocol in the Scheme Shell
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1998 by Eric Marsden
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; Overview ==============================================================
;;
;; The POP3 protocol allows access to email on a maildrop server. It
;; is often used in configurations where users connect from a client
;; machine which doesn't have a permanent network connection or isn't
;; always turned on, situations which make local SMTP delivery
;; impossible. It is the most common form of email access provided by
;; Internet Service Providers.
;;
;; Two types of authentication are commonly used. The first, most
;; basic type involves sending a user's password in clear over the
;; network, and should be avoided. Unfortunately many POP3 clients
;; only implement this basic authentication. The digest authentication
;; system involves the server sending the client a "challenge" token;
;; the client encodes this token with the pass phrase and sends the
;; coded information to the server. This method avoids sending
;; sensitive information over the network.
;;
;; Once connected, a client may request information about the number
;; and size of the messages waiting on the server, download selected
;; messages (either their headers or the entire content), and delete
;; selected messages.
;;; Entry points =======================================================
;;
;; (pop3-connect [host logfile]) -> connection
;; Connect to the maildrop server named HOST. Optionally log the
;; conversation with the server to LOGFILE, which will be appended
;; to if it exists, and created otherwise. The environment variable
;; MAILHOST, if set, will override the value of HOST.
;;
;; (pop3-login connection [login password]) -> status
;; Log in to the mailhost. If a login and password are not
;; provided, they are first searched for in the user's ~/.netrc
;; file. USER/PASS authentication will be tried first, and if this
;; fails, APOP authentication will be tried.
;;
;; (pop3-login/APOP connection login password) -> status
;; Log in to the mailhost using APOP authentication.
;;
;; (pop3-stat connection) -> integer x integer
;; Return the number of messages and the number of bytes waiting in
;; the maildrop.
;;
;; (pop3-get connection msgid) -> status
;; Download message number MSGID from the mailhost. MSGID must be
;; positive and less than the number of messages returned by the
;; pop3-stat call. The message contents are sent to
;; (current-output-port).
;;
;; (pop3-headers connection msgid) -> status
;; Download the headers of message number MSGID. The data is sent
;; to (current-output-port).
;;
;; (pop3-last connection) -> integer
;; Return the highest accessed message-id number for the current
;; session. This isn't in the RFC, but seems to be supported by
;; several servers.
;;
;; (pop3-delete connection msgid) -> status
;; Mark message number MSGID for deletion. The message will not be
;; deleted until the client logs out.
;;
;; (pop3-reset connection) -> status
;; Any messages which have been marked for deletion are unmarked.
;;
;; (pop3-quit connection) -> status
;; Close the connection with the mailhost.
;;; Related work =====================================================
;;
;; * Emacs is distributed with a C program called movemail which can
;; be compiled with support for the POP protocol. There is also an
;; Emacs Lisp library called pop3.el by Richard Pieri which includes
;; APOP support.
;;
;; * Shriram Krishnamurth has written a POP3 library for MzScheme (as
;; well as support for the NNTP protocol, for SMTP, ...).
;;
;; * Siod (a small-footprint Scheme implementation by George Carette)
;; includes support for the POP3 protocol.
;;
;; * rfc1939 describes the POP3 protocol.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Communication is initiated by the client. The server responds to
;; each request with a status indicator and an explanatory message.
;; The client starts off by opening a connection to a well known port
;; on the server machine (typically TCP 110, or 109 on some broken
;; systems). Messages sent to the server are of the form
;;
;; CMD [ <space> arg ] <CR> <LF>
;;
;; Replies from the server are of the form
;;
;; status [ <space> Informative message ] <CR> <LF>
;;
;; where status is either "+OK" or "-ERR". If the server is sending
;; data (the contents of a message for example), it marks the end of
;; the data by a line consisting only of a decimal point (thus the
;; bytes to look out for are <CR><LF>.<CR><LF>. Any lines in the data
;; starting with a . have an additional . added to the beginning, to
;; avoid the client thinking that the line marks the end of the
;; message. The client should therefore replace double decimal points
;; 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)))
(hst-info (host-info host))
(hostname (host-info:name hst-info))
(srvc-info (service-info "pop3" "tcp"))
(sock (socket-connect protocol-family/internet
socket-type/stream
hostname
(service-info:port srvc-info)))
(connection (make-pop3-connection hostname
sock
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))
;; read the challenge the server sends in its welcome banner
(let* ((banner (pop3-read-response connection))
(match (regexp-search (rx (posix-string "\\+OK .* (<[^>]+>)")) banner))
(challenge (and match (match:substring match 1))))
(set-pop3-connection-challenge! connection challenge))
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))))))
;; Login to the server using APOP authentication (no cleartext
;; passwords are sent over the network). The server appends a token to
;; its welcome message, which is built from the server's fully
;; qualified domain name and a unique serial number. The client
;; concatenates this token and the pass phrase and applies the MD5
;; digest algorithm (a one-way hash) to produce a digest. The user
;; name and the digest are sent to the server to authenticate the
;; user. The following example comes from the RFC:
;;
;; S: +OK POP3 server ready <1896.697170952@dbc.mtview.ca.us>
;; C: APOP mrose c4c9334bac560ecc979e58001b3e22fb
;; S: +OK maildrop has 1 message (369 octets)
;;
;; In this example, the shared secret is the string `tan-
;; staaf'. Hence, the MD5 algorithm is applied to the string
;;
;; <1896.697170952@dbc.mtview.ca.us>tanstaaf
;;
;; which produces a digest value of
;;
;; c4c9334bac560ecc979e58001b3e22fb
;;
;;: connection x string x string -> status
(define (pop3-login/APOP connection login password)
(let* ((key (string-append (pop3-connection-challenge connection)
password))
(digest (md5-digest key))
(status (pop3-send-command connection
(format #f "APOP ~a ~a" login digest))))
(set-pop3-connection-login! connection login)
(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
(define (pop3-stat connection)
(pop3-check-transaction-state connection 'pop3-stat)
(let* ((response (pop3-send-command connection "STAT"))
(match (regexp-search (rx (posix-string "([0-9]+) ([0-9]+)")) response)))
(values (string->number (match:substring match 1))
(string->number (match:substring match 2)))))
;; dump the message number MSGID to (current-output-port)
;;: connection x integer -> status
(define (pop3-get connection msgid)
(pop3-check-transaction-state connection 'pop3-get)
(let ((status (pop3-send-command connection (format #f "RETR ~a" msgid))))
(pop3-dump (socket:inport (pop3-connection-command-socket connection)))
status))
;;: connection x integer -> status
(define (pop3-headers connection msgid)
(pop3-check-transaction-state connection 'pop3-headers)
(let ((status (pop3-send-command connection (format #f "TOP ~a 0" msgid))))
(pop3-dump (socket:inport (pop3-connection-command-socket connection)))
status))
;; Return highest accessed message-id number for the session. This
;; ain't in the RFC, but seems to be supported by several servers.
;;: connection -> integer
(define (pop3-last connection)
(pop3-check-transaction-state connection 'pop3-last)
(let ((response (pop3-send-command connection "LAST")))
(string->number (car ((infix-splitter) response)))))
;; mark the message number MSGID for deletion. Note that the messages
;; are not truly deleted until the QUIT command is sent, and messages
;; can be undeleted using the RSET command.
;;: connection x integer -> status
(define (pop3-delete connection msgid)
(pop3-check-transaction-state connection 'pop3-delete)
(pop3-send-command connection (format #f "DELE ~a" msgid)))
;; any messages which have been marked for deletion are unmarked
;;: connection -> status
(define (pop3-reset connection)
(pop3-check-transaction-state connection 'pop3-reset)
(pop3-send-command connection "RSET"))
;;: connection -> status
(define (pop3-quit connection)
(pop3-check-transaction-state connection 'pop3-quit)
(let ((status (pop3-send-command connection "QUIT")))
(close-socket (pop3-connection-command-socket connection))
status))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Nothing exported below.
(define-record-type pop3-connection :pop3-connection
(make-pop3-connection host-name command-socket logfd login password challenge state)
pop3-connection
(host-name pop3-connection-host-name)
(command-socket pop3-connection-command-socket)
(logfd pop3-connection-logfd)
(login pop3-connection-login set-pop3-connection-login!)
(password pop3-connection-password set-pop3-connection-password!)
(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 (pop3-check-transaction-state connection caller)
(if (not (eq? (pop3-connection-state connection) 'connected))
(call-error "not in transaction state" caller)))
(define (pop3-read-response connection)
(let* ((sock (pop3-connection-command-socket connection))
(IN (socket:inport sock))
(line (read-line IN)))
(pop3-log connection (format #f "-> ~a" line))
line))
;; this could perhaps be improved
(define (pop3-handle-response response command)
(let ((match (regexp-search (rx (posix-string "^\\+OK(.*)")) response)))
(if match
(match:substring match 1)
(let ((match2 (regexp-search (rx (posix-string "^-ERR(.*)")) response)))
(if match2
(signal '-ERR (match:substring match2 1) command)
(signal '-ERR response command))))))
(define (pop3-log connection line)
(let ((LOG (pop3-connection-logfd connection)))
(and LOG
(write-string line LOG)
(write-string "\n" LOG)
(force-output LOG))))
(define (pop3-send-command connection command)
(let* ((sock (pop3-connection-command-socket connection))
(OUT (socket:outport sock)))
(write-string command OUT)
(write-crlf OUT)
(pop3-log connection (format #f "<- ~a" command))
(pop3-handle-response (pop3-read-response connection) command)))
;; who will write this in Scheme?
(define (md5-digest str)
(car (run/strings (md5sum) (<< ,str))))
; the name of the program differs among the distributions
; e.g. in FreeBSD it is called md5
(define (pop3-dump fd)
(let loop ((line (read-line fd)))
(cond ((and (not (eof-object? line))
(not (equal? line ".\r")))
(and (eq? 0 (string-index line #\.)) ; fix byte-stuffed lines
(eq? 1 (string-index line #\. 1))
(set! line (substring line 1 (string-length line))))
(write-string line)
(newline)
(loop (read-line fd))))))
;; EOF