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