suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source 
original commit: ebe32a3daa3d375c8b6e89ec9ac14a476fa713e9
This commit is contained in:
Matthew Flatt 2002-02-13 16:31:43 +00:00
parent 83e284db87
commit dc5a48f857
4 changed files with 1127 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
collects/net/mime-sig.ss Normal file
View File

@ -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
)))

812
collects/net/mime-unit.ss Normal file
View File

@ -0,0 +1,812 @@
;;;
;;; <mime-unit.ss> ---- 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 <solsona@acm.org>
;;
;;
;; 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 := <Any RFC 822 header field which
;; begins with the string
;; "Content-">
;;
(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 := <An extension token defined by a
;; standards-track RFC and registered
;; with IANA.>
(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 := <The two characters "X-" or "x-" followed, with
;; no intervening white space, by any 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 := <A publicly-defined extension token. Tokens
;; of this form must be registered with IANA
;; as specified in RFC 2048.>
(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*<any (US-ASCII) CHAR except SPACE, CTLs,
;; or tspecials>
;; 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)
)))

17
collects/net/qp-sig.ss Normal file
View File

@ -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
)))

265
collects/net/qp-unit.ss Normal file
View File

@ -0,0 +1,265 @@
;;;
;;; <qp-unit.ss> ---- 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 <solsona@acm.org>
;;
;;
;; 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 := <any octet with decimal value of 33 through
;; 60 inclusive, and 62 through 126>
;; ; 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