1#lang racket/base
2
3;; Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose
4
5#|
6> (require net/pop3)
7> (define c (connect-to-server "cs.rice.edu"))
8> (authenticate/plain-text "scheme" "********" c)
9> (get-mailbox-status c)
10100
11177824
12> (get-message/headers c 100)
13("Date: Thu, 6 Nov 1997 12:34:18 -0600 (CST)"
14 "Message-Id: <199711061834.MAA11961@new-world.cs.rice.edu>"
15 "From: Shriram Krishnamurthi <shriram@cs.rice.edu>"
16 ...
17 "Status: RO")
18> (get-message/complete  c 100)
19("Date: Thu, 6 Nov 1997 12:34:18 -0600 (CST)"
20 "Message-Id: <199711061834.MAA11961@new-world.cs.rice.edu>"
21 "From: Shriram Krishnamurthi <shriram@cs.rice.edu>"
22 ...
23 "Status: RO")
24("some body" "text" "goes" "." "here" "." "")
25> (disconnect-from-server c)
26|#
27
28(require racket/tcp)
29
30(provide (struct-out communicator)
31         connect-to-server connect-to-server* disconnect-from-server
32         authenticate/plain-text
33         get-mailbox-status
34         get-message/complete get-message/headers get-message/body
35         delete-message
36         get-unique-id/single get-unique-id/all
37
38         make-desired-header extract-desired-headers
39
40         (struct-out pop3)
41         (struct-out cannot-connect)
42         (struct-out username-rejected)
43         (struct-out password-rejected)
44         (struct-out not-ready-for-transaction)
45         (struct-out not-given-headers)
46         (struct-out illegal-message-number)
47         (struct-out cannot-delete-message)
48         (struct-out disconnect-not-quiet)
49         (struct-out malformed-server-response))
50
51;; sender : oport
52;; receiver : iport
53;; server : string
54;; port : number
55;; state : symbol = (disconnected, authorization, transaction)
56
57(define-struct communicator (sender receiver server port [state #:mutable]))
58
59(define-struct (pop3 exn) ())
60(define-struct (cannot-connect pop3) ())
61(define-struct (username-rejected pop3) ())
62(define-struct (password-rejected pop3) ())
63(define-struct (not-ready-for-transaction pop3) (communicator))
64(define-struct (not-given-headers pop3) (communicator message))
65(define-struct (illegal-message-number pop3) (communicator message))
66(define-struct (cannot-delete-message exn) (communicator message))
67(define-struct (disconnect-not-quiet pop3) (communicator))
68(define-struct (malformed-server-response pop3) (communicator))
69
70;; signal-error :
71;; (exn-args ... -> exn) x format-string x values ... ->
72;;   exn-args -> ()
73
74(define (signal-error constructor format-string . args)
75  (lambda exn-args
76    (raise (apply constructor
77                  (apply format format-string args)
78                  (current-continuation-marks)
79                  exn-args))))
80
81;; signal-malformed-response-error :
82;; exn-args -> ()
83
84;; -- in practice, it takes only one argument: a communicator.
85
86(define signal-malformed-response-error
87  (signal-error make-malformed-server-response
88                "malformed response from server"))
89
90;; confirm-transaction-mode :
91;; communicator x string -> ()
92
93;; -- signals an error otherwise.
94
95(define (confirm-transaction-mode communicator error-message)
96  (unless (eq? (communicator-state communicator) 'transaction)
97    ((signal-error make-not-ready-for-transaction error-message)
98     communicator)))
99
100;; default-pop-port-number :
101;; number
102
103(define default-pop-port-number 110)
104
105(define-struct server-responses ())
106(define-struct (+ok server-responses) ())
107(define-struct (-err server-responses) ())
108
109;; connect-to-server*:
110;; input-port output-port -> communicator
111
112(define connect-to-server*
113  (case-lambda
114   [(receiver sender) (connect-to-server* receiver sender "unspecified" "unspecified")]
115   [(receiver sender server-name port-number)
116    (let ([communicator (make-communicator sender receiver server-name port-number
117                                           'authorization)])
118      (let ([response (get-status-response/basic communicator)])
119        (cond
120         [(+ok? response) communicator]
121         [(-err? response)
122          ((signal-error make-cannot-connect
123                         "cannot connect to ~a on port ~a"
124                         server-name port-number))])))]))
125
126;; connect-to-server :
127;; string [x number] -> communicator
128
129(define connect-to-server
130  (lambda (server-name (port-number default-pop-port-number))
131    (let-values ([(receiver sender) (tcp-connect server-name port-number)])
132      (connect-to-server* receiver sender server-name port-number))))
133
134;; authenticate/plain-text :
135;; string x string x communicator -> ()
136
137;; -- if authentication succeeds, sets the communicator's state to
138;; transaction.
139
140(define (authenticate/plain-text username password communicator)
141  (let ([sender (communicator-sender communicator)])
142    (send-to-server communicator "USER ~a" username)
143    (let ([status (get-status-response/basic communicator)])
144      (cond
145       [(+ok? status)
146        (send-to-server communicator "PASS ~a" password)
147        (let ([status (get-status-response/basic communicator)])
148          (cond
149           [(+ok? status)
150            (set-communicator-state! communicator 'transaction)]
151           [(-err? status)
152            ((signal-error make-password-rejected
153                           "password was rejected"))]))]
154       [(-err? status)
155        ((signal-error make-username-rejected
156                       "username was rejected"))]))))
157
158;; get-mailbox-status :
159;; communicator -> number x number
160
161;; -- returns number of messages and number of octets.
162
163(define (get-mailbox-status communicator)
164  (confirm-transaction-mode
165   communicator
166   "cannot get mailbox status unless in transaction mode")
167  (send-to-server communicator "STAT")
168  (apply values
169         (map string->number
170              (let-values ([(status result)
171                            (get-status-response/match
172                             communicator
173                             #rx"([0-9]+) ([0-9]+)"
174                             #f)])
175                result))))
176
177;; get-message/complete :
178;; communicator x number -> list (string) x list (string)
179
180(define (get-message/complete communicator message)
181  (confirm-transaction-mode
182   communicator
183   "cannot get message headers unless in transaction state")
184  (send-to-server communicator "RETR ~a" message)
185  (let ([status (get-status-response/basic communicator)])
186    (cond
187     [(+ok? status)
188      (split-header/body (get-multi-line-response communicator))]
189     [(-err? status)
190      ((signal-error make-illegal-message-number
191                     "not given message ~a" message)
192       communicator message)])))
193
194;; get-message/headers :
195;; communicator x number -> list (string)
196
197(define (get-message/headers communicator message)
198  (confirm-transaction-mode
199   communicator
200   "cannot get message headers unless in transaction state")
201  (send-to-server communicator "TOP ~a 0" message)
202  (let ([status (get-status-response/basic communicator)])
203    (cond
204     [(+ok? status)
205      (let-values ([(headers body)
206                    (split-header/body
207                     (get-multi-line-response communicator))])
208        headers)]
209     [(-err? status)
210      ((signal-error make-not-given-headers
211                     "not given headers to message ~a" message)
212       communicator message)])))
213
214;; get-message/body :
215;; communicator x number -> list (string)
216
217(define (get-message/body communicator message)
218  (let-values ([(headers body) (get-message/complete communicator message)])
219    body))
220
221;; split-header/body :
222;; list (string) -> list (string) x list (string)
223
224;; -- returns list of headers and list of body lines.
225
226(define (split-header/body lines)
227  (let loop ([lines lines] [header null])
228    (if (null? lines)
229        (values (reverse header) null)
230        (let ([first (car lines)]
231              [rest (cdr lines)])
232          (if (string=? first "")
233              (values (reverse header) rest)
234              (loop rest (cons first header)))))))
235
236;; delete-message :
237;; communicator x number -> ()
238
239(define (delete-message communicator message)
240  (confirm-transaction-mode
241   communicator
242   "cannot delete message unless in transaction state")
243  (send-to-server communicator "DELE ~a" message)
244  (let ([status (get-status-response/basic communicator)])
245    (cond
246     [(-err? status)
247      ((signal-error make-cannot-delete-message
248                     "no message numbered ~a available to be deleted" message)
249       communicator message)]
250     [(+ok? status)
251      'deleted])))
252
253;; regexp for UIDL responses
254
255(define uidl-regexp #rx"([0-9]+) (.*)")
256
257;; get-unique-id/single :
258;; communicator x number -> string
259
260(define (get-unique-id/single communicator message)
261  (confirm-transaction-mode
262   communicator
263   "cannot get unique message id unless in transaction state")
264  (send-to-server communicator "UIDL ~a" message)
265  (let-values ([(status result)
266                (get-status-response/match communicator uidl-regexp ".*")])
267    ;; The server response is of the form
268    ;; +OK 2 QhdPYR:00WBw1Ph7x7
269    (cond
270     [(-err? status)
271      ((signal-error make-illegal-message-number
272                     "no message numbered ~a available for unique id" message)
273       communicator message)]
274     [(+ok? status)
275      (cadr result)])))
276
277;; get-unique-id/all :
278;; communicator -> list(number x string)
279
280(define (get-unique-id/all communicator)
281  (confirm-transaction-mode communicator
282                            "cannot get unique message ids unless in transaction state")
283  (send-to-server communicator "UIDL")
284  (let ([status (get-status-response/basic communicator)])
285    ;; The server response is of the form
286    ;; +OK
287    ;; 1 whqtswO00WBw418f9t5JxYwZ
288    ;; 2 QhdPYR:00WBw1Ph7x7
289    ;; .
290    (map (lambda (l)
291           (let ([m (regexp-match uidl-regexp l)])
292             (cons (string->number (cadr m)) (caddr m))))
293         (get-multi-line-response communicator))))
294
295;; close-communicator :
296;; communicator -> ()
297
298(define (close-communicator communicator)
299  (close-input-port (communicator-receiver communicator))
300  (close-output-port (communicator-sender communicator)))
301
302;; disconnect-from-server :
303;; communicator -> ()
304
305(define (disconnect-from-server communicator)
306  (send-to-server communicator "QUIT")
307  (set-communicator-state! communicator 'disconnected)
308  (let ([response (get-status-response/basic communicator)])
309    (close-communicator communicator)
310    (cond
311     [(+ok? response) (void)]
312     [(-err? response)
313      ((signal-error make-disconnect-not-quiet
314                     "got error status upon disconnect")
315       communicator)])))
316
317;; send-to-server :
318;; communicator x format-string x list (values) -> ()
319
320(define (send-to-server communicator message-template . rest)
321  (apply fprintf (communicator-sender communicator)
322         (string-append message-template "\r\n")
323         rest)
324  (flush-output (communicator-sender communicator)))
325
326;; get-one-line-from-server :
327;; iport -> string
328
329(define (get-one-line-from-server server->client-port)
330  (read-line server->client-port 'return-linefeed))
331
332;; get-server-status-response :
333;; communicator -> server-responses x string
334
335;; -- provides the low-level functionality of checking for +OK
336;; and -ERR, returning an appropriate structure, and returning the
337;; rest of the status response as a string to be used for further
338;; parsing, if necessary.
339
340(define (get-server-status-response communicator)
341  (let* ([receiver (communicator-receiver communicator)]
342         [status-line (get-one-line-from-server receiver)]
343         [r (regexp-match #rx"^\\+OK(.*)" status-line)])
344    (if r
345        (values (make-+ok) (cadr r))
346        (let ([r (regexp-match #rx"^\\-ERR(.*)" status-line)])
347          (if r
348              (values (make--err) (cadr r))
349              (signal-malformed-response-error communicator))))))
350
351;; get-status-response/basic :
352;; communicator -> server-responses
353
354;; -- when the only thing to determine is whether the response
355;; was +OK or -ERR.
356
357(define (get-status-response/basic communicator)
358  (let-values ([(response rest)
359                (get-server-status-response communicator)])
360    response))
361
362;; get-status-response/match :
363;; communicator x regexp x regexp -> (status x list (string))
364
365;; -- when further parsing of the status response is necessary.
366;; Strips off the car of response from regexp-match.
367
368(define (get-status-response/match communicator +regexp -regexp)
369  (let-values ([(response rest)
370                (get-server-status-response communicator)])
371    (if (and +regexp (+ok? response))
372        (let ([r (regexp-match +regexp rest)])
373          (if r (values response (cdr r))
374              (signal-malformed-response-error communicator)))
375        (if (and -regexp (-err? response))
376            (let ([r (regexp-match -regexp rest)])
377              (if r (values response (cdr r))
378                  (signal-malformed-response-error communicator)))
379            (signal-malformed-response-error communicator)))))
380
381;; get-multi-line-response :
382;; communicator -> list (string)
383
384(define (get-multi-line-response communicator)
385  (let ([receiver (communicator-receiver communicator)])
386    (let loop ()
387      (let ([l (get-one-line-from-server receiver)])
388        (cond
389         [(eof-object? l)
390          (signal-malformed-response-error communicator)]
391         [(string=? l ".")
392          '()]
393         [(and (> (string-length l) 1)
394               (char=? (string-ref l 0) #\.))
395          (cons (substring l 1 (string-length l)) (loop))]
396         [else
397          (cons l (loop))])))))
398
399;; make-desired-header :
400;; string -> desired
401
402(define (make-desired-header raw-header)
403  (regexp
404   (string-append
405    "^"
406    (list->string
407     (apply append
408            (map (lambda (c)
409                   (cond
410                    [(char-lower-case? c)
411                     (list #\[ (char-upcase c) c #\])]
412                    [(char-upper-case? c)
413                     (list #\[ c (char-downcase c) #\])]
414                    [else
415                     (list c)]))
416                 (string->list raw-header))))
417    ":")))
418
419;; extract-desired-headers :
420;; list (string) x list (desired) -> list (string)
421
422(define (extract-desired-headers headers desireds)
423  (let loop ([headers headers])
424    (if (null? headers) null
425        (let ([first (car headers)]
426              [rest (cdr headers)])
427          (if (ormap (lambda (matcher)
428                       (regexp-match matcher first))
429                     desireds)
430              (cons first (loop rest))
431              (loop rest))))))
432