diff --git a/collects/net/mime-sig.ss b/collects/net/mime-sig.ss new file mode 100644 index 0000000..c4cb120 --- /dev/null +++ b/collects/net/mime-sig.ss @@ -0,0 +1,33 @@ +(module mime-sig mzscheme + (require (lib "unitsig.ss")) + + (provide net:mime^) + + (define-signature net:mime^ + ( + ;; -- exceptions raised -- + (struct mime-error () -setters (- make-mime-error)) + (struct unexpected-termination (msg) -setters (- make-unexpected-termination)) + (struct missing-multipart-boundary-parameter () -setters + (- make-missing-multipart-boundary-parameter)) + (struct malformed-multipart-entity (msg) -setters (- make-malformed-multipart-entity)) + (struct empty-mechanism () -setters (- make-empty-mechanism)) + (struct empty-type () -setters (- make-empty-type)) + (struct empty-subtype () -setters (- make-empty-subtype)) + (struct empty-disposition-type () -setters (- make-empty-disposition-type)) + + ;; -- basic mime structures -- + (struct message (version entity fields)) + (struct entity + (type subtype charset encoding + disposition params id + description other fields + parts body close)) + (struct disposition + (type filename creation + modification read + size params)) + + ;; -- mime methods -- + mime-analyze + ))) diff --git a/collects/net/mime-unit.ss b/collects/net/mime-unit.ss new file mode 100644 index 0000000..51d500f --- /dev/null +++ b/collects/net/mime-unit.ss @@ -0,0 +1,812 @@ +;;; +;;; ---- MIME support +;;; +;;; Copyright (C) 2001 by Wish Computing. +;;; +;;; This file is part of mime + +;;; mime-plt is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2, or (at your option) +;;; any later version. + +;;; mime-plt is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. + +;;; You should have received a copy of the GNU General Public License +;;; along with mime-plt; see the file COPYING. If not, write to the +;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;;; Boston, MA 02111-1307, USA. + +;;; Author: Francisco Solsona +;; +;; +;; Commentary: MIME support for PLT Scheme: an implementation of +;; rfc2045, rfc2046, rfc2047, rfc2048, and rfc2049. + +(module mime-unit mzscheme + (require "mime-sig.ss" + "qp-sig.ss" + "base64-sig.ss" + "mime-util.ss" + (lib "unitsig.ss") + (lib "etc.ss")) + + (provide net:mime@) + (define net:mime@ + (unit/sig net:mime^ + (import net:base64^ + net:qp^) + + ;; Constants: + (define discrete-alist '(("text" . text) + ("image" . image) + ("audio" . audio) + ("video" . video) + ("application" . application))) + + (define disposition-alist '(("inline" . inline) + ("attachment" . attachment) + ("file" . attachment) ;; This is used + ;; (don't know why) + ;; by multipart/form-data + ("form-data" . form-data))) + + (define composite-alist '(("message" . message) + ("multipart" . multipart))) + + (define mechanism-alist '(("7bit" . 7bit) + ("8bit" . 8bit) + ("binary" . binary) + ("quoted-printable" . qp) + ("base64" . base64))) + + (define ietf-extensions '()) + (define iana-extensions '(;; text + ("plain" . plain) + ("richtext" . richtext) + ("tab-separated-values" . tab-separated-values) + ;; Multipart + ("mixed" . mixed) + ("alternative" . alternative) + ("digest" . digest) + ("parallel" . parallel) + ("appledouble" . appledouble) + ("header-set" . header-set) + ("form-data" . form-data) + ;; Message + ("rfc822" . rfc822) + ("partial" . partial) + ("external-body" . external-body) + ("news" . news) + ;; Application + ("octet-stream" . octet-stream) + ("postscript" . postscript) + ("oda" . oda) + ("atomicmail" . atomicmail) + ("andrew-inset" . andrew-inset) + ("slate" . slate) + ("wita" . wita) + ("dec-dx" . dec-dx) + ("dca-rf" . dca-rf) + ("activemessage" . activemessage) + ("rtf" . rtf) + ("applefile" . applefile) + ("mac-binhex40" . mac-binhex40) + ("news-message-id" . news-message-id) + ("news-transmissio" . news-transmissio) + ("wordperfect5.1" . wordperfect5.1) + ("pdf" . pdf) + ("zip" . zip) + ("macwritei" . macwritei) + ;; "image" + ("jpeg" . jpeg) + ("gif" . gif) + ("ief" . ief) + ("tiff" . tiff) + ;; "audio" + ("basic" . basic) + ;; "video" . + ("mpeg" . mpeg) + ("quicktime" . quicktime))) + + ;; Basic structures + (define-struct message (version entity fields)) + (define-struct entity + (type subtype charset encoding disposition params id description other fields parts body close)) + (define-struct disposition + (type filename creation modification read size params)) + + ;; Exceptions + (define-struct mime-error ()) + (define-struct (unexpected-termination mime-error) (msg)) + (define-struct (missing-multipart-boundary-parameter mime-error) ()) + (define-struct (malformed-multipart-entity mime-error) (msg)) + (define-struct (empty-mechanism mime-error) ()) + (define-struct (empty-type mime-error) ()) + (define-struct (empty-subtype mime-error) ()) + (define-struct (empty-disposition-type mime-error) ()) + + ;; ************************************* + ;; Practical stuff, aka MIME in action: + ;; ************************************* + (define CRLF (format "~a~a" #\return #\newline)) + (define CRLF-binary "=0D=0A") ;; quoted printable representation + + ;; get-headers : input-port -> string + ;; returns the header part of a message/part conforming to rfc822, + ;; and rfc2045. + (define get-headers + (lambda (in) + (let loop ((headers "") (ln (read-line in 'any))) + (cond ((eof-object? ln) + (raise (make-unexpected-termination + "eof reached! while parsing headers"))) + ((string=? ln "") headers) + (else + ;; Quoting rfc822: + ;; " Headers occur before the message body and are + ;; terminated by a null line (i.e., two contiguous + ;; CRLFs)." + ;; That is: Two empty lines. But most MUAs seem to count + ;; the CRLF ending the last field (header) as the first + ;; CRLF of the null line. + (loop (string-append headers ln CRLF) + (read-line in 'any))))))) + + (define make-default-disposition + (lambda () + (make-disposition + 'inline ;; type + "" ;; filename + #f ;; creation + #f ;; modification + #f ;; read + #f ;; size + null ;; params + ))) + + (define make-default-entity + (lambda () + (make-entity + 'text ;; type + 'plain ;; subtype + 'us-ascii ;; charset + '7bit ;; encoding + (make-default-disposition) ;; disposition + null ;; params + "" ;; id + "" ;; description + null ;; other MIME fields (MIME-extension-fields) + null ;; fields + null ;; parts + null ;; body + void ;; thunk to kill body buffer + ))) + + (define make-default-message + (lambda () + (make-message 1.0 (make-default-entity) null))) + + (define mime-decode + (lambda (entity input) + (case (entity-encoding entity) + ((quoted-printable) + (let-values ([(body close-body) + (qp-decode-stream input)]) + (set-entity-body! entity body) + (set-entity-close! entity close-body))) + ((base64) + (let-values + ([(body no-base64-in) (make-pipe 4096)]) + (let ((body-thread + (thread (lambda () + (base64-decode-stream input no-base64-in) + (close-output-port no-base64-in))))) + (set-entity-body! entity body) + (set-entity-close! entity (lambda () + (kill-thread body-thread)))))) + (else ;; 7bit, 8bit, binary + (let-values + ([(body body-in) (make-pipe 4096)]) + (let ((body-thread + (thread (lambda () + (let loop ((c (read-char input))) + (cond ((eof-object? c) + (close-input-port input) + (close-output-port body-in)) + (else + (display c body-in) + (loop (read-char input))))))))) + (set-entity-body! entity body) + (set-entity-close! entity (lambda () + (kill-thread body-thread))))))))) + + (define mime-analyze + (opt-lambda (input (part #f)) + (let* ((iport (if (string? input) + (open-input-string input) + input)) + (headers (get-headers iport)) + (msg (if part + (MIME-part-headers headers) + (MIME-message-headers headers))) + (entity (message-entity msg))) + ;; OK we have in msg a MIME-message structure, lets see what we have: + (case (entity-type entity) + ((text image audio video application) + ;; decode part, and save port and thunk + (mime-decode entity iport)) + ((message multipart) + (let ((boundary (entity-boundary entity))) + (when (not boundary) + (raise (make-missing-multipart-boundary-parameter))) + (set-entity-parts! entity + (map (lambda (part) + (mime-analyze part #t)) + (multipart-body iport boundary))))) + (else + ;; Unrecognized type, you're on your own! (sorry) + (mime-decode entity iport))) + ;; return mime structure + msg))) + + + (define entity-boundary + (lambda (entity) + (let* ((params (entity-params entity)) + (ans (assoc "boundary" params))) + (and ans + (cdr ans))))) + + ;; ************************************************* + ;; MIME Specific: rfc2045-2049, and rfc0822, rfc2183 + ;; ************************************************* + + ;;multipart-body := [preamble CRLF] + ;; dash-boundary transport-padding CRLF + ;; body-part *encapsulation + ;; close-delimiter transport-padding + ;; [CRLF epilogue] + ;; Returns a list of input ports, each one containing the correspongind part. + (define multipart-body + (lambda (input boundary) + (letrec ((eat-part (lambda () + (let-values ([(pin pout) (make-pipe)]) + (let loop ((ln (read-line input))) + (cond ((eof-object? ln) + (close-output-port pout) + (values pin;; part + #f;; close-delimiter? + #t;; eof reached? + )) + ((regexp-match + (regexp (string-append "^--" + boundary + "--.*";; Transpor padding + )) ln) + (close-output-port pout) + (values pin #t #f)) + ((regexp-match + (regexp (string-append "^--" + boundary + ".*";; Transpor padding + )) ln) + (close-output-port pout) + (values pin #f #f)) + (else + (fprintf pout "~a~n" ln) + (loop (read-line input))))))))) + (let loop ((id 0) (parts null)) + (cond ((zero? id) + ;; Discard preamble + (eat-part) (loop (add1 id) null)) + (else + (let-values ([(part close? eof?) (eat-part)]) + (cond (close? (append parts (list part))) + (eof? + (raise + (make-malformed-multipart-entity + "eof found while scanning multipart"))) + (else + (loop id (append parts (list part)))))))))))) + + ;; MIME-message-headers := entity-headers + ;; fields + ;; version CRLF + ;; ; The ordering of the header + ;; ; fields implied by this BNF + ;; ; definition should be ignored. + (define MIME-message-headers + (lambda (headers) + (let ((in (open-input-string headers)) + (message (make-default-message))) + (entity-headers in message #t) + message))) + + ;; MIME-part-headers := entity-headers + ;; [ fields ] + ;; ; Any field not beginning with + ;; ; "content-" can have no defined + ;; ; meaning and may be ignored. + ;; ; The ordering of the header + ;; ; fields implied by this BNF + ;; ; definition should be ignored. + (define MIME-part-headers + (lambda (headers) + (let ((in (open-input-string headers)) + (message (make-default-message))) + (entity-headers in message #f) + message))) + + ;; entity-headers := [ content CRLF ] + ;; [ encoding CRLF ] + ;; [ id CRLF ] + ;; [ description CRLF ] + ;; *( MIME-extension-field CRLF ) + (define entity-headers + (lambda (in message version?) + (let ((entity (message-entity message))) + (let-values ([(mime non-mime) (get-fields in)]) + (let loop ((fields mime)) + (unless (null? fields) + ;; Process MIME field + (let ((trimmed-h (trim-comments (car fields)))) + (or (and version? (version trimmed-h message)) + (content trimmed-h entity) + (encoding trimmed-h entity) + (dispositione trimmed-h entity) + (id trimmed-h entity) + (description trimmed-h entity) + (MIME-extension-field trimmed-h entity)) + ;; keep going + (loop (cdr fields))))) + ;; NON-mime headers (or semantically incorrect). In + ;; order to make this implementation of rfc2045 robuts, + ;; we will save the header in the fields field of the + ;; message struct: + (set-message-fields! message non-mime) + ;; Return message + message)))) + + (define get-fields + (lambda (in) + (let ((mime null) (non-mime null) (r (regexp "^[ ]+([^ ]+)"))) + (letrec ((store-field + (lambda (f) + (unless (string=? f "") + (if (mime-header? f) + (set! mime (append mime (list (trim-spaces f)))) + (set! non-mime (append non-mime (list (trim-spaces f))))))))) + (let loop ((ln (read-line in 'return-linefeed)) + (field "")) + (cond ((eof-object? ln) + ;; Store last field (if any) + (store-field field) + ;; return values to user + (values mime non-mime)) + ;; Line continues previous field + ((regexp-match r ln) + (when (string=? field "") + ;; we will ignore this to be robust, though. + (warning + "This is not a valid header according to rfc822: `~a'" + ln)) + (loop (read-line in 'return-linefeed) + (format "~a~a" field + (regexp-replace r ln "\\1")))) + (else ;; ln starts a new field + ;; Store previous field + (store-field field) + (loop (read-line in 'return-linefeed) ln)))))))) + + (define mime-header? + (lambda (h) + (let ((content (regexp "^[Cc]ontent-")) + (mime (regexp "^MIME-Version:"))) + (or (regexp-match content h) + (regexp-match mime h))))) + + + ;;; Headers + ;;; Content-type follows this BNF syntax: + ;; content := "Content-Type" ":" type "/" subtype + ;; *(";" parameter) + ;; ; Matching of media type and subtype + ;; ; is ALWAYS case-insensitive. + (define content + (lambda (header entity) + (let* ((params (string-tokenizer #\; header)) + (one (regexp "^[Cc]ontent-[Tt]ype:([^/]+)/([^/]+)$")) + (h (trim-all-spaces (car params))) + (target (regexp-match one h)) + (old-param (entity-params entity))) + (and target + (set-entity-type! entity + (type (regexp-replace one h "\\1"))) ;; type + (set-entity-subtype! entity + (subtype (regexp-replace one h "\\2"))) ;; subtype + (set-entity-params! + entity + (append old-param + (let loop ((p (cdr params));; parameters + (ans null)) + (cond ((null? p) ans) + (else + (let ((par-pair (parameter (trim-all-spaces (car p))))) + (cond (par-pair + (when (string=? (car par-pair) "charset") + (set-entity-charset! entity (cdr par-pair))) + (loop (cdr p) + (append ans + (list par-pair)))) + (else + (warning "Invalid parameter for Content-Type: `~a'" (car p)) + ;; go on... + (loop (cdr p) ans))))))))))))) + + ;; From rfc2183 Content-Disposition + ;; disposition := "Content-Disposition" ":" + ;; disposition-type + ;; *(";" disposition-parm) + (define dispositione + (lambda (header entity) + (let* ((params (string-tokenizer #\; header)) + (reg (regexp "^[Cc]ontent-[Dd]isposition:(.+)$")) + (h (trim-all-spaces (car params))) + (target (regexp-match reg h)) + (disp-struct (entity-disposition entity))) + (and target + (set-disposition-type! + disp-struct + (disp-type (regexp-replace reg h "\\1"))) + (disp-params (cdr params) disp-struct))))) + + ;; version := "MIME-Version" ":" 1*DIGIT "." 1*DIGIT + (define version + (lambda (header message) + (let* ((reg (regexp "^MIME-Version:([0-9]+)\\.([0-9]+)$")) + (h (trim-all-spaces header)) + (target (regexp-match reg h))) + (and target + (set-message-version! + message + (string->number (regexp-replace reg h "\\1.\\2"))))))) + + ;; description := "Content-Description" ":" *text + (define description + (lambda (header entity) + (let* ((reg (regexp "^[Cc]ontent-[Dd]escription:[ ]*(.*)$")) + (target (regexp-match reg header))) + (and target + (set-entity-description! + entity + (trim-spaces (regexp-replace reg header "\\1"))))))) + + ;; encoding := "Content-Transfer-Encoding" ":" mechanism + (define encoding + (lambda (header entity) + (let* ((reg (regexp "^[Cc]ontent-[Tt]ransfer-[Ee]ncoding:(.+)$")) + (h (trim-all-spaces header)) + (target (regexp-match reg h))) + (and target + (set-entity-encoding! + entity + (mechanism (regexp-replace reg h "\\1"))))))) + + ;; id := "Content-ID" ":" msg-id + (define id + (lambda (header entity) + (let* ((reg (regexp "^[Cc]ontent-ID:(.+)$")) + (h (trim-all-spaces header)) + (target (regexp-match reg h))) + (and target + (set-entity-id! + entity + (msg-id (regexp-replace reg h "\\1"))))))) + + ;; From rfc822: + ;; msg-id = "<" addr-spec ">" ; Unique message id + ;; addr-spec = local-part "@" domain ; global address + ;; local-part = word *("." word) ; uninterpreted + ;; ; case-preserved + ;; domain = sub-domain *("." sub-domain) + ;; sub-domain = domain-ref / domain-literal + ;; domain-literal = "[" *(dtext / quoted-pair) "]" + ;; domain-ref = atom ; symbolic reference + (define msg-id + (lambda (str) + (let* ((r (regexp "^<[^@>]+@[^\ + .]+(\\.[^\ + .]+)*>$")) + (ans (regexp-match r str))) + (if ans + str + (begin (warning "Invalid msg-id: ~a" str) + str))))) + + ;; mechanism := "7bit" / "8bit" / "binary" / + ;; "quoted-printable" / "base64" / + ;; ietf-token / x-token + (define mechanism + (lambda (mech) + (if (not mech) + (raise (make-empty-mechanism)) + (let ((val (assoc (lowercase mech) mechanism-alist))) + (or (and val (cdr val)) + (ietf-token mech) + (x-token mech)))))) + + ;; MIME-extension-field := + ;; + (define MIME-extension-field + (lambda (header entity) + (let* ((reg (regexp "^[Cc]ontent-(.+):[ ]*(.+)$")) + (target (regexp-match reg header))) + (and target + (set-entity-other! + entity + (append (entity-other entity) + (list + (cons (regexp-replace reg header "\\1") + (trim-spaces (regexp-replace reg header "\\2")))))))))) + + ;; type := discrete-type / composite-type + (define type + (lambda (value) + (if (not value) + (raise (make-empty-type)) + (or (discrete-type value) + (composite-type value))))) + + ;; disposition-type := "inline" / "attachment" / extension-token + (define disp-type + (lambda (value) + (if (not value) + (raise (make-empty-disposition-type)) + (let ((val (assoc (trim-spaces value) disposition-alist))) + (if val (cdr val) (extension-token value)))))) + + ;; discrete-type := "text" / "image" / "audio" / "video" / + ;; "application" / extension-token + (define discrete-type + (lambda (value) + (let ((val (assoc (trim-spaces value) discrete-alist))) + (if val (cdr val) (extension-token value))))) + + ;; composite-type := "message" / "multipart" / extension-token + (define composite-type + (lambda (value) + (let ((val (assoc (trim-spaces value) composite-alist))) + (if val (cdr val) (extension-token value))))) + + ;; extension-token := ietf-token / x-token + (define extension-token + (lambda (value) + (or (ietf-token value) + (x-token value)))) + + ;; ietf-token := + (define ietf-token + (lambda (value) + (let ((ans (assoc (trim-spaces value) ietf-extensions))) + (and ans + (cdr ans))))) + + ;; Directly from RFC 1700: + ;; Type Subtype Description Reference + ;; ---- ------- ----------- --------- + ;; text plain [RFC1521,NSB] + ;; richtext [RFC1521,NSB] + ;; tab-separated-values [Paul Lindner] + ;; + ;; multipart mixed [RFC1521,NSB] + ;; alternative [RFC1521,NSB] + ;; digest [RFC1521,NSB] + ;; parallel [RFC1521,NSB] + ;; appledouble [MacMime,Patrik Faltstrom] + ;; header-set [Dave Crocker] + ;; + ;; message rfc822 [RFC1521,NSB] + ;; partial [RFC1521,NSB] + ;; external-body [RFC1521,NSB] + ;; news [RFC 1036, Henry Spencer] + ;; + ;; application octet-stream [RFC1521,NSB] + ;; postscript [RFC1521,NSB] + ;; oda [RFC1521,NSB] + ;; atomicmail [atomicmail,NSB] + ;; andrew-inset [andrew-inset,NSB] + ;; slate [slate,terry crowley] + ;; wita [Wang Info Transfer,Larry Campbell] + ;; dec-dx [Digital Doc Trans, Larry Campbell] + ;; dca-rft [IBM Doc Content Arch, Larry Campbell] + ;; activemessage [Ehud Shapiro] + ;; rtf [Paul Lindner] + ;; applefile [MacMime,Patrik Faltstrom] + ;; mac-binhex40 [MacMime,Patrik Faltstrom] + ;; news-message-id [RFC1036, Henry Spencer] + ;; news-transmission [RFC1036, Henry Spencer] + ;; wordperfect5.1 [Paul Lindner] + ;; pdf [Paul Lindner] + ;; zip [Paul Lindner] + ;; macwriteii [Paul Lindner] + ;; msword [Paul Lindner] + ;; remote-printing [RFC1486,MTR] + ;; + ;; image jpeg [RFC1521,NSB] + ;; gif [RFC1521,NSB] + ;; ief Image Exchange Format [RFC1314] + ;; tiff Tag Image File Format [MTR] + ;; + ;; audio basic [RFC1521,NSB] + ;; + ;; video mpeg [RFC1521,NSB] + ;; quicktime [Paul Lindner] + + + ;; x-token := + (define x-token + (lambda (value) + (let* ((r (regexp "^[xX]-(.*)")) + (h (trim-spaces value)) + (ans (regexp-match r h))) + (and ans + (token (regexp-replace r h "\\1")) + h)))) + + ;; subtype := extension-token / iana-token + (define subtype + (lambda (value) + (if (not value) + (raise (make-empty-subtype)) + (or (extension-token value) + (iana-token value))))) + + ;; iana-token := + (define iana-token + (lambda (value) + (let ((ans (assoc (trim-spaces value) iana-extensions))) + (and ans + (cdr ans))))) + + ;; parameter := attribute "=" value + (define parameter + (lambda (par) + (let* ((r (regexp "([^=]+)=(.+)")) + (att (attribute (regexp-replace r par "\\1"))) + (val (value (regexp-replace r par "\\2")))) + (and (regexp-match r par) + att val (cons att val))))) + + ;; value := token / quoted-string + (define value + (lambda (val) + (or (token val) + (quoted-string val)))) + + ;; token := 1* + ;; tspecials := "(" / ")" / "<" / ">" / "@" / + ;; "," / ";" / ":" / "\" / <"> + ;; "/" / "[" / "]" / "?" / "=" + ;; ; Must be in quoted-string, + ;; ; to use within parameter values + (define token + (lambda (value) + (let* ((tspecials (regexp "[^][()<>@,;:\\\"/?= ]+")) + (ans (regexp-match tspecials value))) + (and ans + (string=? value (car ans)) + (car ans))))) + + ;; attribute := token + ;; ; Matching of attributes + ;; ; is ALWAYS case-insensitive. + (define attribute token) + + + (define quoted-string + (lambda (str) + (let* ((quotes (regexp "\"(.+)\"")) + (ans (regexp-match quotes str))) + (and ans + (regexp-replace quotes str "\\1"))))) + + ;; disposition-parm := filename-parm + ;; / creation-date-parm + ;; / modification-date-parm + ;; / read-date-parm + ;; / size-parm + ;; / parameter + ;; + ;; filename-parm := "filename" "=" value + ;; + ;; creation-date-parm := "creation-date" "=" quoted-date-time + ;; + ;; modification-date-parm := "modification-date" "=" quoted-date-time + ;; + ;; read-date-parm := "read-date" "=" quoted-date-time + ;; + ;; size-parm := "size" "=" 1*DIGIT + (define disp-params + (lambda (lst disp) + (let loop ((lst lst)) + (unless (null? lst) + (let* ((p (parameter (trim-all-spaces (car lst)))) + (parm (car p)) + (value (cdr p))) + (cond ((string=? parm "filename") + (set-disposition-filename! disp value)) + ((string=? parm "creation-date") + (set-disposition-creation! + disp + (disp-quoted-data-time value))) + ((string=? parm "modification-date") + (set-disposition-modification! + disp + (disp-quoted-data-time value))) + ((string=? parm "read-date") + (set-disposition-read! + disp + (disp-quoted-data-time value))) + ((string=? parm "size") + (set-disposition-size! + disp + (string->number value))) + (else + (set-disposition-params! + disp + (append (disposition-params disp) (list p))))) + (loop (cdr lst))))))) + + ;; date-time = [ day "," ] date time ; dd mm yy + ;; ; hh:mm:ss zzz + ;; + ;; day = "Mon" / "Tue" / "Wed" / "Thu" + ;; / "Fri" / "Sat" / "Sun" + ;; + ;; date = 1*2DIGIT month 2DIGIT ; day month year + ;; ; e.g. 20 Jun 82 + ;; + ;; month = "Jan" / "Feb" / "Mar" / "Apr" + ;; / "May" / "Jun" / "Jul" / "Aug" + ;; / "Sep" / "Oct" / "Nov" / "Dec" + ;; + ;; time = hour zone ; ANSI and Military + ;; + ;; hour = 2DIGIT ":" 2DIGIT [":" 2DIGIT] + ;; ; 00:00:00 - 23:59:59 + ;; + ;; zone = "UT" / "GMT" ; Universal Time + ;; ; North American : UT + ;; / "EST" / "EDT" ; Eastern: - 5/ - 4 + ;; / "CST" / "CDT" ; Central: - 6/ - 5 + ;; / "MST" / "MDT" ; Mountain: - 7/ - 6 + ;; / "PST" / "PDT" ; Pacific: - 8/ - 7 + ;; / 1ALPHA ; Military: Z = UT; + ;; ; A:-1; (J not used) + ;; ; M:-12; N:+1; Y:+12 + ;; / ( ("+" / "-") 4DIGIT ) ; Local differential + ;; ; hours+min. (HHMM) + (define date-time + (lambda (str) + ;; Fix Me: I have to return a date structure, or time in seconds. + str)) + + ;; quoted-date-time := quoted-string + ;; ; contents MUST be an RFC 822 `date-time' + ;; ; numeric timezones (+HHMM or -HHMM) MUST be used + + (define disp-quoted-data-time date-time) + + ))) diff --git a/collects/net/qp-sig.ss b/collects/net/qp-sig.ss new file mode 100644 index 0000000..c381844 --- /dev/null +++ b/collects/net/qp-sig.ss @@ -0,0 +1,17 @@ +(module qp-sig mzscheme + (require (lib "unitsig.ss")) + + (provide net:qp^) + (define-signature net:qp^ + ( + ;; -- exceptions raised -- + (struct qp-error () -setters (- make-qp-error)) + (struct qp-wrong-input () -setters (- make-qp-wrong-input)) + (struct qp-wrong-line-size (size) -setters (- make-qp-wrong-line-size)) + + ;; -- qp methods -- + qp-encode + qp-decode + qp-encode-stream + qp-decode-stream + ))) diff --git a/collects/net/qp-unit.ss b/collects/net/qp-unit.ss new file mode 100644 index 0000000..5dac824 --- /dev/null +++ b/collects/net/qp-unit.ss @@ -0,0 +1,265 @@ +;;; +;;; ---- Quoted Printable Implementation +;;; Time-stamp: <01/04/23 09:28:43 solsona> +;;; +;;; Copyright (C) 2001 by Francisco Solsona. +;;; +;;; This file is part of mime-plt. + +;;; mime-plt is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 2.1 of the License, or (at your option) any later version. + +;;; mime-plt is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. + +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with mime-plt; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +;;; Author: Francisco Solsona +;; +;; +;; Commentary: + +(module qp-unit mzscheme + (require "qp-sig.ss" + (lib "unitsig.ss") + (lib "etc.ss")) + + (provide net:qp@) + (define net:qp@ + (unit/sig net:qp^ + (import) + + ;; Exceptions: + ;; String or input-port expected: + (define-struct qp-error ()) + (define-struct (qp-wrong-input qp-error) ()) + (define-struct (qp-wrong-line-size qp-error) (size)) + + ;; qp-encode : string -> string + ;; returns the quoted printable representation of STR. + (define qp-encode + (lambda (str) + (let-values ([(in close) (quoted-printable-encode str)]) + (let ((out (open-output-string))) + (let loop ((c (read-char in))) + (cond ((eof-object? c) (close) (get-output-string out)) + (else + (display c out) + (loop (read-char in))))))))) + + ;; qp-decode : string -> string + ;; returns STR unqp. + (define qp-decode + (lambda (str) + (let-values ([(in close) (quoted-printable-decode str)]) + (let ((out (open-output-string))) + (let loop ((c (read-char in))) + (cond ((eof-object? c) (close) (get-output-string out)) + (else + (display c out) + (loop (read-char in))))))))) + + (define qp-encode-stream quoted-printable-encode) + (define qp-decode-stream quoted-printable-decode) + + (define quoted-printable-decode + (lambda (input) + (let-values + ([(no-qp-out no-qp-in) (make-pipe 4096)]) + (let ((no-qp-thread + (thread (lambda () + (quoted-printable-do-decode input no-qp-in) + (close-output-port no-qp-in))))) + (values no-qp-out + (lambda () + (kill-thread no-qp-thread))))))) + + (define quoted-printable-do-decode + (lambda (in out) + (let ((iport (cond ((input-port? in) in) + ((string? in) (open-input-string in)) + (else + (raise (make-qp-wrong-input)))))) + (let loop ((ln (read-line iport 'return-linefeed))) + (cond ((eof-object? ln) (void)) ;; done reading + ((> (string-length ln) 76) + (raise (make-qp-wrong-line-size (string-length ln)))) + (else + (quoted-printable-decode-line ln out) + (loop (read-line iport 'return-linefeed)))))))) + + (define quoted-printable-decode-line + (lambda (line out) + (let ((in (open-input-string line))) + (let loop ((ch (read-char in))) + (unless (eof-object? ch) + (case ch + ((#\=);; quoted-printable stuff + (let ((next (read-char in))) + (cond ((eof-object? next);; end of qp-line + null) + ((hex-digit? next) + (let ((next-next (read-char in))) + (cond ((eof-object? next-next) + (warning "Illegal qp sequence: `=~a'" next) + (display "=" out) + (display next out)) + ((hex-digit? next-next) + ;; qp-encoded + (display (hex-octet->char + (format "~a~a" next next-next)) + out)) + (else + (warning "Illegal qp sequence: `=~a~a'" next next-next) + (display "=" out) + (display next out) + (display next-next out))))) + (else + ;; Warning: invalid + (warning "Illegal qp sequence: `=~a'" next) + (display "=" out) + (display next out)))) + (loop (read-char in))) + (else + (display ch out) + (loop (read-char in))))))))) + + (define warning + (lambda (msg . args) + (fprintf (current-error-port) + (apply format (cons msg args))) + (newline (current-error-port)))) + + (define hex-digit? + (lambda (char) + (regexp-match (regexp "[0-9abcdefABCDEF]") + (string char)))) + + (define hex-octet->char + (lambda (str) + (integer->char (string->number str 16)))) + + ;; quoted-printable-encode : + ;; (string | input-port) -> (values qp-input-port thunk) + ;; the quoted-printable representation of input is given in the first + ;; value returned value, a thunk to kill this port is given as second + ;; returning value. + (define quoted-printable-encode + (lambda (input) + (let-values + ([(qp-out qp-in) (make-pipe 4096)]) + (let ((qp-thread + (thread (lambda () + (quoted-printable-do-encode input qp-in) + (close-output-port qp-in))))) + (values qp-out + (lambda () + (kill-thread qp-thread))))))) + + (define qp-blank? + (lambda (char) + (or (char=? char #\space) + (char=? char #\tab)))) + + (define qp-newline + (lambda (port) + (display #\return port) + (display #\linefeed port))) + + (define qp-uppercase + (lambda (hex-octet) + (list->string (map char-upcase (string->list hex-octet))))) + + (define char->hex-octet + (lambda (char) + (let* ((ans (qp-uppercase + (number->string (char->integer char) 16))) + (padding? (< (string-length ans) 2))) + (if padding? + (format "=0~a" ans) + (format "=~a" ans))))) + + (define display-qp-encoded + (lambda (line out) + (let* ((blanks (regexp "[ ]+$")) + (pos (regexp-match-positions blanks line)) + (col (caar pos)) + (rest-of-line (substring line col (string-length line)))) + ;; Print everything up to the last non-blank char in line. + (display (substring line 0 col) out) + ;; hex-encode the following blanks + (let loop ((str rest-of-line) (len (string-length rest-of-line)) (column (add1 col))) + (cond ((= column 76) + ;; Add CRLF to output + (qp-newline out) + ;; return the remainder blanks + str) + ;; Done, the whole line fitted on 76 chars. + ((zero? len) "") + ((<= column 73) + (display (char->hex-octet (string-ref str 0)) out) + (loop (substring str 1 len) + (sub1 len) + (+ column 3))) + (else + (display "=" out);; soft line break + (qp-newline out) + ;; return the remainder blanks + str)))))) + + (define quoted-printable-do-encode + (lambda (in out) + (let ((iport (cond ((input-port? in) in) + ((string? in) (open-input-string in)) + (else + (raise (make-qp-wrong-input)))))) + (let loop ((c (read-char iport)) (line "") (column 0)) + (cond ((eof-object? c) + (if (qp-blank? (string-ref line (sub1 column))) + (let loop ((rem (display-qp-encoded line out))) + (unless (string=? rem "") + (loop (display-qp-encoded rem out)))) + (display line out))) + ((= column 76);; Only 76 chars per line + (if (qp-blank? (string-ref line (sub1 column))) + ;; line ends in blank, we 8-bit encode blanks, + ;; print them out, and the remaining is pass to the + ;; following line. + (let ((rem (display-qp-encoded line out))) + (loop c rem (string-length rem))) + (begin + (display line out) + (qp-newline out) + (loop c "" 0)))) + ((or (safe-char? c) (qp-blank? c)) + (loop (read-char iport) + (string-append line (string c)) + (add1 column))) + ;; OK octet is greater than 127. + ((<= column 72) + (loop (read-char iport) + (string-append line (char->hex-octet c)) + (+ column 3))) + (else + (display line out);; is shorter that 76! (and greater that 72) + (display "=" out);; soft line break + (qp-newline out) + (loop (read-char iport) "" 0))))))) + + ;; safe-char := + ;; ; Characters not listed as "mail-safe" in + ;; ; RFC 2049 are also not recommended. + (define safe-char? + (lambda (octet) + (let ((dec (char->integer octet))) + (or (and (<= 33 dec) (<= dec 60)) + (and (<= 62 dec) (<= dec 126))))))))) + +;;; qpr.ss ends here \ No newline at end of file