;;;; pop3.scm
;
; Copyright (c) 2000-2010, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer. 
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution. 
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission. 
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.


(module pop3 (pop3:connect pop3:disconnect pop3:list pop3:open pop3:delete pop3:pop3?)
  
(import scheme chicken)
(use extras regex tcp ports matchable)


(define-constant default-pop3-port 110)

(define (pop3-error msg . args)
  (abort
   (make-composite-condition
    (make-property-condition 'exn 'message msg 'arguments args)
    (make-property-condition 'pop3) ) ) )

(define-record pop3
  open					; bool
  verbose				; bool
  count					; integer | #f
  in					; port
  out)					; port

(define pop3:pop3? pop3?)

(define (send pop3 fstr . args)
  (when (pop3-verbose pop3) (printf "POP3: ~?~%" fstr args))
  (fprintf (pop3-out pop3) "~?\r\n" fstr args) 
  (fetch pop3) )

(define (fetch pop3)
  (let ((ln (read-line (pop3-in pop3))))
    (when (pop3-verbose pop3) (printf "POP3: [~A]~%" ln))
    (if (eof-object? ln)
	ln
	(match (string-match "(\\+OK|\\-ERR) (.*)" ln)
	  ((_ mode msg)
	   (if (string=? "-ERR" mode)
	       (pop3-error msg)
	       msg) )
	  (_ (pop3-error "invalid response from POP3 server" ln)) ) ) ) )

(define (pop3:connect host user pass . more)
  (let-optionals more ((verbose #t) (port default-pop3-port))
    (let-values (((i o) (tcp-connect host port)))
      (let ((pop3 (make-pop3 #f verbose #f i o)))
	(condition-case 
	    (begin
	      (fetch pop3)
	      (send pop3 "USER ~A" user)
	      (send pop3 "PASS ~A" pass) 
	      (let ((stat (send pop3 "STAT")))
		(match (string-match "([0-9]+) ([0-9]+).*" stat)
		  ((_ n _)
		   (pop3-count-set! pop3 (string->number n)) )
		  (_ (pop3-error "invalid response from STAT command" stat)) ) )
	      pop3)
	  (ex (pop3)
	      (when (pop3-open pop3)
		(pop3:disconnect pop3))
	      (signal ex) )
	  (ex () (signal ex)) ) ) ) ) )

(define (pop3:disconnect pop3)
  (send pop3 "QUIT") 
  (close-input-port (pop3-in pop3))
  (close-output-port (pop3-out pop3)) )

(define (pop3:list pop3)
  (send pop3 "LIST")
  (let loop ((lst '()))
    (let ((ln (read-line (pop3-in pop3))))
      (cond ((eof-object? ln) (pop3-error "unexpected end of POP3 reply"))
	    ((string=? "." ln) (reverse lst))
	    (else
	     (match (string-match "([0-9]+) ([0-9]+).*" ln)
	       ((_ i s) 
		(loop (cons (cons (string->number i) (string->number s)) lst)) )
	       (_ (pop3-error "invalid response from LIST command" ln)) ) ) ) ) ) )

(define (pop3:open pop3 index . del)
  (when (pop3-open pop3)
    (pop3-error "POP3 transfer already in progress") )
  (let ((del (optional del #f)))
    (send pop3 "RETR ~A" index)
    (pop3-open-set! pop3 #t)
    (let ((ln #f)
	  (closed #f)
	  (pos 0) 
	  (len 0) 
	  (nl (string #\newline)) )
      (make-input-port
       (lambda ()
	 (let loop ()
	   (cond ((eq? #t ln) #!eof)
		 ((fx>= pos len)
		  (set! ln (string-append (read-line (pop3-in pop3)) nl))
		  (set! pos 0)
		  (set! len (string-length ln))
		  (cond ((string=? ".\n" ln)
			 (set! ln #t)
			 #!eof)
			((and (fx> (string-length ln) 0) (char=? #\. (string-ref ln 0)))
			 (set! pos 1)
			 (loop) ) 
			(else (loop)) ) )
		 (else
		  (let ((c (string-ref ln pos)))
		    (set! pos (fx+ pos 1))
		    c) ) ) ) )
       (lambda ()
	 (or (fx< pos len)
	     (char-ready? (pop3-in pop3)) ) )
       (lambda ()
	 (when (and del (not closed))
	   (send pop3 "DELE ~A" index) )
	 (pop3-open-set! pop3 #f)
	 (set! closed #t) ) ) ) ) )

(define (pop3:delete pop3 index)
  (send pop3 "DELE ~A" index) )

)