(module pop3-unit mzscheme
  (require (lib "unitsig.ss")
	   (lib "etc.ss"))

  (require "pop3-sig.ss")

  (provide net:pop3@)
  (define net:pop3@
    (unit/sig net:pop3^
      (import)

      ;; Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose

      ;; sender : oport
      ;; receiver : iport
      ;; server : string
      ;; port : number
      ;; state : symbol = (disconnected, authorization, transaction)

      (define-struct communicator (sender receiver server port state))

      (define-struct (pop3 exn) ())
      (define-struct (cannot-connect pop3) ())
      (define-struct (username-rejected pop3) ())
      (define-struct (password-rejected pop3) ())
      (define-struct (not-ready-for-transaction pop3) (communicator))
      (define-struct (not-given-headers pop3) (communicator message))
      (define-struct (illegal-message-number pop3) (communicator message))
      (define-struct (cannot-delete-message exn) (communicator message))
      (define-struct (disconnect-not-quiet pop3) (communicator))
      (define-struct (malformed-server-response pop3) (communicator))

      ;; signal-error :
      ;; (exn-args ... -> exn) x format-string x values ... ->
      ;;   exn-args -> ()

      (define signal-error
	(lambda (constructor format-string . args)
	  (lambda exn-args
	    (raise (apply constructor
			  (string->immutable-string
			   (apply format format-string args))
			  (current-continuation-marks)
			  exn-args)))))

      ;; signal-malformed-response-error :
      ;; exn-args -> ()

      ;; -- in practice, it takes only one argument: a communicator.

      (define signal-malformed-response-error
	(signal-error make-malformed-server-response
		      "malformed response from server"))

      ;; confirm-transaction-mode :
      ;; communicator x string -> ()

      ;; -- signals an error otherwise.

      (define confirm-transaction-mode
	(lambda (communicator error-message)
	  (unless (eq? (communicator-state communicator) 'transaction)
	    ((signal-error make-not-ready-for-transaction error-message)
	     communicator))))

      ;; default-pop-port-number :
      ;; number

      (define default-pop-port-number 110)

      (define-struct server-responses ())
      (define-struct (+ok server-responses) ())
      (define-struct (-err server-responses) ())

      ;; connect-to-server*:
      ;; input-port output-port -> communicator

      (define connect-to-server*
	(case-lambda
	  [(receiver sender) (connect-to-server* receiver sender "unspecified" "unspecified")]
	  [(receiver sender server-name port-number)
	   (let ((communicator  (make-communicator sender receiver server-name port-number
				  'authorization)))
	     (let ((response (get-status-response/basic communicator)))
	       (cond
		 ((+ok? response) communicator)
		 ((-err? response)
		  ((signal-error make-cannot-connect
		     "cannot connect to ~a on port ~a"
		     server-name port-number))))))]))
      
      ;; connect-to-server :
      ;; string [x number] -> communicator

      (define connect-to-server
	(opt-lambda (server-name (port-number default-pop-port-number))
	  (let-values (((receiver sender) (tcp-connect server-name port-number)))
	    (connect-to-server* receiver sender server-name port-number))))

      ;; authenticate/plain-text :
      ;; string x string x communicator -> ()

      ;; -- if authentication succeeds, sets the communicator's state to
      ;; transaction.

      (define authenticate/plain-text
	(lambda (username password communicator)
	  (let ((sender (communicator-sender communicator)))
	    (send-to-server communicator "USER ~a" username)
	    (let ((status (get-status-response/basic communicator)))
	      (cond
	       ((+ok? status)
		(send-to-server communicator "PASS ~a" password)
		(let ((status (get-status-response/basic communicator)))
		  (cond
		   ((+ok? status)
		    (set-communicator-state! communicator 'transaction))
		   ((-err? status)
		    ((signal-error make-password-rejected
				   "password was rejected"))))))
	       ((-err? status)
		((signal-error make-username-rejected
			       "username was rejected"))))))))

      ;; get-mailbox-status :
      ;; communicator -> number x number

      ;; -- returns number of messages and number of octets.

      (define get-mailbox-status
        (lambda (communicator)
          (confirm-transaction-mode
           communicator
           "cannot get mailbox status unless in transaction mode")
          (send-to-server communicator "STAT")
          (apply values
                 (map string->number
                      (let-values (((status result)
                                    (get-status-response/match
                                     communicator
                                     #rx"([0-9]+) ([0-9]+)"
                                     #f)))
                        result)))))

      ;; get-message/complete :
      ;; communicator x number -> list (string) x list (string)

      (define get-message/complete
	(lambda (communicator message)
	  (confirm-transaction-mode communicator
				    "cannot get message headers unless in transaction state")
	  (send-to-server communicator "RETR ~a" message)
	  (let ((status (get-status-response/basic communicator)))
	    (cond
	     ((+ok? status)
	      (split-header/body (get-multi-line-response communicator)))
	     ((-err? status)
	      ((signal-error make-illegal-message-number
			     "not given message ~a" message)
	       communicator message))))))

      ;; get-message/headers :
      ;; communicator x number -> list (string)

      (define get-message/headers
	(lambda (communicator message)
	  (confirm-transaction-mode communicator
				    "cannot get message headers unless in transaction state")
	  (send-to-server communicator "TOP ~a 0" message)
	  (let ((status (get-status-response/basic communicator)))
	    (cond
	     ((+ok? status)
	      (let-values (((headers body)
			    (split-header/body
			     (get-multi-line-response communicator))))
		headers))
	     ((-err? status)
	      ((signal-error make-not-given-headers
			     "not given headers to message ~a" message)
	       communicator message))))))

      ;; get-message/body :
      ;; communicator x number -> list (string)

      (define get-message/body
	(lambda (communicator message)
	  (let-values (((headers body)
			(get-message/complete communicator message)))
	    body)))

      ;; split-header/body :
      ;; list (string) -> list (string) x list (string)

      ;; -- returns list of headers and list of body lines.

      (define split-header/body
	(lambda (lines)
	  (let loop ((lines lines) (header null))
	    (if (null? lines)
		(values (reverse header) null)
		(let ((first (car lines))
		      (rest (cdr lines)))
		  (if (string=? first "")
		      (values (reverse header) rest)
		      (loop rest (cons first header))))))))

      ;; delete-message :
      ;; communicator x number -> ()

      (define delete-message
	(lambda (communicator message)
	  (confirm-transaction-mode communicator
				    "cannot delete message unless in transaction state")
	  (send-to-server communicator "DELE ~a" message)
	  (let ((status (get-status-response/basic communicator)))
	    (cond
	     ((-err? status)
	      ((signal-error make-cannot-delete-message
			     "no message numbered ~a available to be deleted" message)
	       communicator message))
	     ((+ok? status)
	      'deleted)))))

      ;; regexp for UIDL responses

      (define uidl-regexp #rx"([0-9]+) (.*)")

      ;; get-unique-id/single :
      ;; communicator x number -> string

      (define (get-unique-id/single communicator message)
	(confirm-transaction-mode communicator
				  "cannot get unique message id unless in transaction state")
	(send-to-server communicator "UIDL ~a" message)
	(let-values (((status result)
		      (get-status-response/match communicator
						 uidl-regexp
						 ".*")))
	  ;; The server response is of the form
	  ;; +OK 2 QhdPYR:00WBw1Ph7x7
	  (cond
	   ((-err? status)
	    ((signal-error make-illegal-message-number
			   "no message numbered ~a available for unique id" message)
	     communicator message))
	   ((+ok? status)
	    (cadr result)))))

      ;; get-unique-id/all :
      ;; communicator -> list(number x string)

      (define (get-unique-id/all communicator)
	(confirm-transaction-mode communicator
				  "cannot get unique message ids unless in transaction state")
	(send-to-server communicator "UIDL")
	(let ((status (get-status-response/basic communicator)))
	  ;; The server response is of the form
	  ;; +OK
	  ;; 1 whqtswO00WBw418f9t5JxYwZ
	  ;; 2 QhdPYR:00WBw1Ph7x7
	  ;; .
	  (map (lambda (l)
		 (let ((m (regexp-match uidl-regexp l)))
		   (cons (string->number (cadr m)) (caddr m))))
	       (get-multi-line-response communicator))))

      ;; close-communicator :
      ;; communicator -> ()

      (define close-communicator
	(lambda (communicator)
	  (close-input-port (communicator-receiver communicator))
	  (close-output-port (communicator-sender communicator))))

      ;; disconnect-from-server :
      ;; communicator -> ()

      (define disconnect-from-server
	(lambda (communicator)
	  (send-to-server communicator "QUIT")
	  (set-communicator-state! communicator 'disconnected)
	  (let ((response (get-status-response/basic communicator)))
	    (close-communicator communicator)
	    (cond
	     ((+ok? response) (void))
	     ((-err? response)
	      ((signal-error make-disconnect-not-quiet
			     "got error status upon disconnect")
	       communicator))))))

      ;; send-to-server :
      ;; communicator x format-string x list (values) -> ()

      (define send-to-server
	(lambda (communicator message-template . rest)
	  (apply fprintf (communicator-sender communicator)
		 (string-append message-template "\r\n")
		 rest)
	  (flush-output (communicator-sender communicator))))

      ;; get-one-line-from-server :
      ;; iport -> string

      (define get-one-line-from-server
	(lambda (server->client-port)
	  (read-line server->client-port 'return-linefeed)))

      ;; get-server-status-response :
      ;; communicator -> server-responses x string

      ;; -- provides the low-level functionality of checking for +OK
      ;; and -ERR, returning an appropriate structure, and returning the
      ;; rest of the status response as a string to be used for further
      ;; parsing, if necessary.

      (define get-server-status-response
	(lambda (communicator)
          (let* ((receiver (communicator-receiver communicator))
                 (status-line (get-one-line-from-server receiver))
                 (r (regexp-match #rx"^\\+OK(.*)" status-line)))
            (if r
              (values (make-+ok) (cadr r))
              (let ((r (regexp-match #rx"^\\-ERR(.*)" status-line)))
                (if r
                  (values (make--err) (cadr r))
                  (signal-malformed-response-error communicator)))))))

      ;; get-status-response/basic :
      ;; communicator -> server-responses

      ;; -- when the only thing to determine is whether the response
      ;; was +OK or -ERR.

      (define get-status-response/basic
	(lambda (communicator)
	  (let-values (((response rest)
			(get-server-status-response communicator)))
	    response)))

      ;; get-status-response/match :
      ;; communicator x regexp x regexp -> (status x list (string))

      ;; -- when further parsing of the status response is necessary.
      ;; Strips off the car of response from regexp-match.

      (define get-status-response/match
	(lambda (communicator +regexp -regexp)
	  (let-values (((response rest)
			(get-server-status-response communicator)))
	    (if (and +regexp (+ok? response))
		(let ((r (regexp-match +regexp rest)))
		  (if r (values response (cdr r))
		      (signal-malformed-response-error communicator)))
		(if (and -regexp (-err? response))
		    (let ((r (regexp-match -regexp rest)))
		      (if r (values response (cdr r))
			  (signal-malformed-response-error communicator)))
		    (signal-malformed-response-error communicator))))))

      ;; get-multi-line-response :
      ;; communicator -> list (string)

      (define get-multi-line-response
	(lambda (communicator)
	  (let ((receiver (communicator-receiver communicator)))
	    (let loop ()
	      (let ((l (get-one-line-from-server receiver)))
		(cond
		 ((eof-object? l)
		  (signal-malformed-response-error communicator))
		 ((string=? l ".")
		  '())
		 ((and (> (string-length l) 1)
		       (char=? (string-ref l 0) #\.))
		  (cons (substring l 1 (string-length l)) (loop)))
		 (else
		  (cons l (loop)))))))))

      ;; make-desired-header :
      ;; string -> desired

      (define make-desired-header
	(lambda (raw-header)
	  (regexp
	   (string-append
	    "^"
	    (list->string
	     (apply append
		    (map (lambda (c)
			   (cond
			    ((char-lower-case? c)
			     (list #\[ (char-upcase c) c #\]))
			    ((char-upper-case? c)
			     (list #\[ c (char-downcase c) #\]))
			    (else
			     (list c))))
			 (string->list raw-header))))
	    ":"))))

      ;; extract-desired-headers :
      ;; list (string) x list (desired) -> list (string)

      (define extract-desired-headers
	(lambda (headers desireds)
	  (let loop ((headers headers))
	    (if (null? headers) null
		(let ((first (car headers))
		      (rest (cdr headers)))
		  (if (ormap (lambda (matcher)
			       (regexp-match matcher first))
			     desireds)
		      (cons first (loop rest))
		      (loop rest))))))))))