Re: [Chicken-users] Wierd diagnostic, and gripe!

[Julian Morrison]

felix winkelmann wrote:

> This looks more like a bug in the compiler. Can you send me the
> code, or a snippet containing code that triggers this behaviour?
>  
I'll attach it. I hope the mailing list doesn't drop attachments!

I'm new to Scheme, and cook-booking a bit, so if I made any dumb 
mistakes please say.

> What Chicken version are you using?
>  
The chicken -version command says "Version 1, Build 63 - 
linux-unix-gnu-x86". It's the debian package version 1.63-2.
;; This is the advanced-pop3 library (in Chicken scheme)
;;
;; All functions of RFC 1939 Post Office Protocol version 3 are supported.
;; All errors are recovered if recoverable, signalled with (exn advanced-pop3) 
if not.
;;
;; Requires: library extras tcp regex
;;
;; Requires-eggs: md5
;;
;; Author: Julian Morrison <address@hidden>
;;
;; Copying conditions: this file has been placed in the public domain by the 
author.

(declare
 (uses library extras tcp regex md5)
 (export advanced-pop3:connect
         advanced-pop3:connected?
         advanced-pop3:user
         advanced-pop3:pass
         advanced-pop3:apop
         advanced-pop3:connect-and-authenticate
         advanced-pop3:stat
         advanced-pop3:list
         advanced-pop3:retr
         advanced-pop3:dele
         advanced-pop3:noop
         advanced-pop3:rset
         advanced-pop3:top
         advanced-pop3:uidl
         advanced-pop3:quit
         advanced-pop3:fetch-each
         advanced-pop3:fetch-everything
         advanced-pop3:pop3-connection?))

(require 'tcp)
(require 'regex)
(require 'md5)

(define default-port 110)

(define-record pop3-connection
   state ; 'authorization 'transaction or 'closed
   logger-proc ; or #f
   apop-timestamp ; or #f
   in
   out)

;; just forward the predicate for export
(define advanced-pop3:pop3-connection? pop3-connection?)

;; test the state machine for sanity
(define (require-state pop3 state)
   (ensure symbol? state)
   (ensure pop3-connection? pop3)
   (ensure (lambda (x) (eq? x state)) (pop3-connection-state pop3)))

(define (advanced-pop3:connected? pop3)
   (ensure pop3-connection? pop3)
   (not (eq? (pop3-connection-state pop3) 'closed)))

(define (has-apop-capability? pop3)
   (ensure pop3-connection? pop3)
   (if (pop3-connection-apop-timestamp pop3) #t #f))

;; error handling
;; errors are either recoverable or not
(define recoverable (make-property-condition 'recoverable))
(define non-recoverable (make-property-condition 'non-recoverable))
(define (pop3-exception is-recoverable msg location . etc)
   (ensure condition? is-recoverable)
   (ensure string? msg)
   (abort (make-composite-condition
           (make-property-condition 'exn 'message msg 'location location 
'arguments etc)
           (make-property-condition 'advanced-pop3)
           is-recoverable)))
   

;; the logger takes a message generator or a message
;; this avoids constructing log output unless necessary
(define (log pop3 message-generator)
   (ensure pop3-connection? pop3)
   (let ((logger (pop3-connection-logger-proc pop3)))
      (when logger
         (let ((message (if (procedure? message-generator)
                            (apply message-generator '())  ; run it
                            message-generator))) ; otherwise just use it 
directly
            (ensure string? message)
            (logger message)))))

;; all subs should handle unidentified exceptions
(define-macro (with-fallback-error-handling . code)
   ;`(begin ,@code)) ;; does nothing
   `(condition-case
     (begin ,@code)
     (rethrow-me (exn advanced-pop3) (abort rethrow-me))
     (exn (exn)
        (let ((msg ((condition-property-accessor 'exn 'message) exn))
              (location ((condition-property-accessor 'exn 'location) exn)))
           (pop3-exception non-recoverable (sprintf "Caught exception ~S msg:~S 
location:~S" exn msg location ) location exn)))
     (other () (pop3-exception non-recoverable (sprintf "Caught unrecognized 
condition ~S" other) "unknown" other))))

;; if pop3 signals an error, turn it into a recoverable exception
;; if the line is garbled, throw a nonrecoverable exception
;; otherwise return the whole line
(define (input-line pop3)
   (ensure pop3-connection? pop3)
   (with-fallback-error-handling
    (let* ((line (read-line (pop3-connection-in pop3))))
       (log pop3 (lambda () (sprintf ">~A" line)))
       (cond
          ((zero? (string-length line)) (pop3-exception non-recoverable 
"unexpected blank line from server" 'input-line line))
          ((substring=? line "+OK") line)
          ((substring=? line "-ERR") (pop3-exception recoverable line))
          (else (pop3-exception non-recoverable "garbled line from server" 
'input-line line))))))

;; emit the line and return the response
;; implicitly tests the response and will exception if it is an error
(define (output-line pop3 format-string . format-args)
   (ensure pop3-connection? pop3)
   (ensure string? format-string)
   (with-fallback-error-handling
    (log pop3 (lambda () (sprintf "<~?" format-string format-args)))
    (fprintf (pop3-connection-out pop3) "~?\r\n" format-string format-args)
    (flush-output (pop3-connection-out pop3))
    (input-line pop3)))

;; this just establishes a connection and parses the apop timestamp (if any 
exists)
;; Args: server - must be a string, the remote server to connect to
;;       port   - must be an integer and a valid port number, optional
;;       logger - a procedure with one argument to callback with log strings
(define (advanced-pop3:connect server . etc)
   (let-optionals etc ((port default-port) (logger #f))
      (ensure string? server)
      (ensure (lambda (x) (and (integer? x) (> x 0) (< x 65535))) port)
      (ensure (lambda (x) (or (not x) (procedure? x))) logger)
      (with-fallback-error-handling
       (let-values (((in out) (tcp-connect server port)))
          (let* ((pop3 (make-pop3-connection
                        'authorization ; state
                        logger
                        #f ; apop-timestamp
                        in
                        out))
                 (hello-from-server (input-line pop3))
                 (apop-timestamp-matched (string-match ".*?(<.*?>).*" 
hello-from-server)))
             (when apop-timestamp-matched
                (let ((apop-timestamp (list-ref apop-timestamp-matched 1)))
                   (pop3-connection-apop-timestamp-set! pop3 apop-timestamp)
                   (log pop3 (lambda () (sprintf "!An APOP timestamp was 
detected, it was ~S" apop-timestamp)))))
             ;; and return
             pop3)))))

(define (advanced-pop3:user pop3 username)
   (ensure pop3-connection? pop3)
   (ensure string? username)
   (require-state pop3 'authorization)
   (output-line pop3 "USER ~A" username))

;; warning, insecure, password is sent in plain-text
;; must be called after advanced-pop3:user
(define (advanced-pop3:pass pop3 password)
   (ensure pop3-connection? pop3)
   (ensure string? password)
   (require-state pop3 'authorization)
   (output-line pop3 "PASS ~A" password)
   ;;implicit success
   (pop3-connection-state-set! pop3 'transaction)
   (log pop3 "!Authentication success"))

;; authenticate securely with md5
;; this POP3 command is optional and may exception if unsupported
(define (advanced-pop3:apop pop3 username password)
   (ensure pop3-connection? pop3)
   (ensure string? username)
   (ensure string? password)
   (require-state pop3 'authorization)
   (let ((timestamp (pop3-connection-apop-timestamp pop3)))
      (unless timestamp
         (pop3-exception recoverable "APOP is not supported" 
'advanced-pop3:apop))
      (let ((digest (md5:digest (string-append timestamp password))))
         (output-line pop3 "APOP ~A ~S" username digest)
         ;;implicit success
         (pop3-connection-state-set! pop3 'transaction)
         (log pop3 "!Authentication success"))))

;; connect-and-authenticate chooses between PASS and APOP automatically
;; if it chooses APOP, and fails, it falls back to PASS
(define (advanced-pop3:connect-and-authenticate server username password . etc)
  (define (do-pass pop3)
     (advanced-pop3:user pop3 username)
     (advanced-pop3:pass pop3 password))
  (let ((pop3 (apply advanced-pop3:connect server etc))) ;; using apply to 
splice the etc list
     (cond ((has-apop-capability? pop3)
            (condition-case ;; begin exception trapping
             (begin
                (advanced-pop3:apop pop3 username password)
                pop3)
             ((exn advanced-pop3 recoverable)
              (do-pass pop3)
              pop3)
             (other () (abort other)))) ;; rethrow
           ;; no apop, so only try pass
           (else
            (do-pass pop3)
            pop3))))

;; returns a list of how many mails, and the total bytesize
(define (advanced-pop3:stat pop3)
   (ensure pop3-connection? pop3)
   (require-state pop3 'transaction)
   (let* ((status (output-line pop3 "STAT"))
          (fields (string-split status))
          (count (string->number (list-ref fields 0)))
          (bytes (string->number (list-ref fields 1))))
      (list count bytes)))

(define (lines-until-period pop3 . accumulator) ;; cuteness
   (define (unstuff line) (cond
                             ((zero? (string-length line)) line)
                             ((substring=? line ".")
                              (substring line 1 (string-length line))) ;; chop 
first char
                             (else line)))
   (define line (read-line (pop3-connection-in pop3)))
   (if (string=? line ".")
       ;; return the list of values
       (reverse accumulator)
       ;; otherwise tail-recurse prepending the line to the accumulator
       (let ((line (unstuff line)))
          (log pop3 (lambda () (sprintf ">~A" line)))
          (apply lines-until-period pop3 (cons line accumulator)))))

;; return message IDs and byte sizes
;; with the optional message-id, one byte-size is returned as an integer
;; without the optional message-id, a list of lists of (msgid byte-size) is 
returned
(define (advanced-pop3:list pop3 . etc)
   (let-optionals etc ((message-id #f))
      (ensure pop3-connection? pop3)
      (require-state pop3 'transaction)
      (cond
         (message-id
          (ensure integer? message-id)
          (let* ((response (output-line pop3 "LIST ~A" message-id))
                 (fields (string-split response))
                 (message-bytes (string->number (list-ref fields 2))))
             message-bytes))
         (else
          (output-line pop3 "LIST")
          (let ((lines (lines-until-period pop3)))
             (map
              (lambda (line)
                 (let* ((fields (string-split line))
                        (message-id (string->number (list-ref fields 0)))
                        (message-bytes (string->number (list-ref fields 1))))
                    (list message-id message-bytes)))
              lines))))))
             

;; returns the raw unparsed email
(define (advanced-pop3:retr pop3 message-id)
   (ensure pop3-connection? pop3)
   (require-state pop3 'transaction)
   (ensure integer? message-id)
   (output-line pop3 "RETR ~A" message-id)
   (string-append (string-intersperse (lines-until-period pop3) "\n") "\n"))

;; mark the message for deletion at quit
(define (advanced-pop3:dele pop3 message-id)
   (ensure pop3-connection? pop3)
   (require-state pop3 'transaction)
   (ensure integer? message-id)
   (output-line pop3 "DELE ~A" message-id))

;; not very useful, but completeness is good
(define (advanced-pop3:noop pop3)
   (ensure pop3-connection? pop3)
   (require-state pop3 'transaction)
   (output-line pop3 "NOOP"))

;; cancel all deletions
(define (advanced-pop3:rset pop3) 
   (ensure pop3-connection? pop3)
   (require-state pop3 'transaction)
   (output-line pop3 "RSET"))

;; returns a string consisting of the headers, a blank line, and the indicated 
number of lines of message body
;; this POP3 command is optional and may exception if unsupported
(define (advanced-pop3:top pop3 message-id count-of-lines)
   (ensure pop3-connection? pop3)
   (require-state pop3 'transaction)
   (ensure integer? message-id)
   (ensure integer? count-of-lines)
   (output-line pop3 "TOP ~A ~A" message-id count-of-lines)
   (string-append (string-intersperse (lines-until-period pop3) "\n") "\n"))

;; return non-repeating unique IDs
;; with the optional message-id, one uid is returned as a string
;; without the optional message-id, a list of lists of (msgid uid) is returned
;; this POP3 command is optional and may exception if unsupported
(define (advanced-pop3:uidl pop3 . etc)
   (let-optionals etc ((message-id #f))
      (require-state pop3 'transaction)
      (ensure pop3-connection? pop3)
      (cond
         (message-id
          (ensure integer? message-id)
          (let* ((response (output-line pop3 "UIDL ~A" message-id))
                 (fields (string-split response))
                 (message-uidl (list-ref fields 2)))
             message-uidl))
         (else
          (output-line pop3 "UIDL")
          (let ((lines (lines-until-period pop3)))
             (map
              (lambda (line)
                 (let* ((fields (string-split line))
                        (message-id (string->number (list-ref fields 0)))
                        (message-uidl (list-ref fields 1)))
                    (list message-id message-uidl)))
              lines))))))

;; perform all pending deletions and close the connection
(define (advanced-pop3:quit pop3)
   (output-line pop3 "QUIT")
   (close-input-port (pop3-connection-in pop3))
   (close-output-port (pop3-connection-out pop3))
   (pop3-connection-state-set! pop3 'closed))

;; connects, calls handler-proc once for each email, deletes each email after 
handler-proc returns, and quits
;; deletion is guaranteed not to occur until after handler-proc has returned
(define (advanced-pop3:fetch-each handler-proc server username password . etc)
   (ensure procedure? handler-proc)
   (define pop3 (apply advanced-pop3:connect-and-authenticate server username 
password etc))
   (define (fetch x)
      (let ((message-id (list-ref fields 0)))
         (handler-proc (advanced-pop3:retr pop3 message-id)))
         (advanced-pop3:dele pop3 message-id))
   (condition-case ;; begin exception trapping
    (begin
       (for-each fetch (advanced-pop3:list pop3))
       (advanced-pop3:quit pop3))
    ;; handle clean quit if there was a problem
    (rethrow-me ()
       (when (advanced-pop3:connected? pop3)
          (advanced-pop3:rset pop3)
          (advanced-pop3:quit pop3))
       (abort rethrow-me))))

;; connects, performs LIST, RETR, DELE to obtain all emails in a list of 
strings, and QUITs
(define (advanced-pop3:fetch-everything server username password . etc)
   (define messages '())
   (define (handler-proc message)
      (set! messages (cons message messages)))
   (apply advanced-pop3:fetch-each handler-proc server username password etc)
   ;; and return
   messages)

;; this is the test harness
; (begin
;    (define (log-to-screen log)
;       (with-output-to-port (current-error-port)
;        (lambda ()
;           (display log)
;           (newline))))
;    (condition-case
;     (begin
;        (define pop3 (advanced-pop3:connect-and-authenticate "servername" 
"username" "password" default-port log-to-screen))
;        (advanced-pop3:list pop3)
;        (advanced-pop3:uidl pop3)
;        (advanced-pop3:retr pop3 1)
;        (advanced-pop3:quit pop3))
;     (exn (exn)
;        (printf "There was an exception: ~S~%" exn)
;        (printf "- ~A~%" ((condition-property-accessor 'exn 'message) exn))
;        (printf "- location: ~A~%" ((condition-property-accessor 'exn 
'location) exn)))
;     (problem ()
;        (printf "There was a problem: ~S~%" problem))))