[squeak-dev] The Trunk: Network-pre.213.mczcommits at source.squeak.org commits at source.squeak.orgThu Dec 7 11:08:28 UTC 2017
Patrick Rein uploaded a new version of Network to project The Trunk: http://source.squeak.org/trunk/Network-pre.213.mcz ==================== Summary ==================== Name: Network-pre.213 Author: pre Time: 7 December 2017, 12:08:21.729608 pm UUID: c8734836-b900-d542-8a4b-bcd0ced9670b Ancestors: Network-nice.212 This commit includes a major refactoring of the mail message infrastructure and some new logic for handling attachments. The refactoring extracts the logic dealing with MIMEDocuments from the MailMessage and puts it into the MIMEDocument class. Before that multi part MailMessages contained MailMessage objects as body parts. This might make sense from a re-use perspective as they share some methods (mostly for handling meta data stored in header fields) but at the same time it is conceptually confusing and complicates the serialization logic. =============== Diff against Network-nice.212 =============== Item was changed: Object subclass: #MIMEDocument + instanceVariableNames: 'mainType subType content fields url parts' - instanceVariableNames: 'mainType subType content parameters url' classVariableNames: 'MIMEdatabase' poolDictionaries: '' category: 'Network-Url'! !MIMEDocument commentStamp: '<historical>' prior: 0! a MIME object, along with its type and the URL it was found at (if any)! Item was changed: ----- Method: MIMEDocument class>>contentType:content: (in category 'instance creation') ----- + contentType: aString content: content - contentType: aString content: content "create a MIMEObject with the given content-type and content" "MIMEDocument contentType: 'text/plain' content: 'This is a test'" | ans | ans := self new. + ans contentTypeHeaderValue: (MIMEHeaderValue fromMIMEHeader: aString). - "parse the content-type" - ((aString isNil or: [ (aString includes: $/) not])) - ifTrue: [ - ans privateMainType: 'application'. - ans privateSubType: 'octet-stream' ] - ifFalse: [ | value parts | - value := MIMEHeaderValue fromMIMEHeader: aString. - parts := value mainValue splitBy: '/'. - ans privateMainType: parts first. - ans privateSubType: parts second. - ans privateParameters: value parameters ]. (ans isPlaintext or: [ans isHTML]) + ifTrue: [ans content: (self tryToDecodeBody: content as: ans charset)] + ifFalse: [ans isMultipart + ifTrue: [| separator | + separator := ans attachmentSeparator asLowercase. + separator ifNil: [self error: 'Bad attachment separater']. + + separator := '--', separator withoutTrailingBlanks. + ans addAllParts: (self parseParts: content withSeparator:separator).] + ifFalse: [ans content: content]]. - ifTrue: [ans privateContent: (self tryToDecodeBody: content as: (ans parameterNamed: 'charset' ifAbsent: [nil]))] - ifFalse: [ans privateContent: content]. ^ ans ! Item was added: + ----- Method: MIMEDocument class>>contentTypeMultipartAlternative (in category 'content-types') ----- + contentTypeMultipartAlternative + ^'multipart/alternative'! Item was added: + ----- Method: MIMEDocument class>>contentTypeMultipartMixed (in category 'content-types') ----- + contentTypeMultipartMixed + ^'multipart/mixed'! Item was added: + ----- Method: MIMEDocument class>>fromPartString: (in category 'instance creation') ----- + fromPartString: aString + "This method allows for easy creation of MIME documents + representing parts in a multipart MIME document" + + ^ self new initializeFromString: aString! Item was added: + ----- Method: MIMEDocument class>>newMultipart (in category 'instance creation') ----- + newMultipart + + | ans | + + ans := self new. + + ans contentTypeHeaderValue: (MIMEHeaderValue fromMIMEHeader: self contentTypeMultipartMixed). + ans contentTypeHeaderValue parameterAt: 'boundary' put: MailMessage generateSeparator. + + ^ ans! Item was added: + ----- Method: MIMEDocument class>>parseParts:withSeparator: (in category 'instance creation') ----- + parseParts: bodyText withSeparator: separator + "private -- parse the parts of the message and store them into a collection" + + | parseStream msgStream messages normalizedSeparator | + + parseStream := ReadStream on: bodyText. + + msgStream := LimitingLineStreamWrapper on: parseStream delimiter: separator. + normalizedSeparator := separator asLowercase. + msgStream limitingBlock: [:aLine | | normalizedLine | + normalizedLine := aLine withoutTrailingBlanks asLowercase. + normalizedLine = normalizedSeparator or: "Match the separator" + [normalizedLine = ('--',normalizedSeparator)] or: "or -- and the separator" + [normalizedLine = (normalizedSeparator, '--')]]. "or the final separator with --" + + "Throw away everything up to and including the first separator" + msgStream upToEnd. + msgStream skipThisLine. + + "Extract each of the multi-parts as strings" + messages := OrderedCollection new. + [parseStream atEnd] + whileFalse: + [messages add: msgStream upToEnd. + msgStream skipThisLine]. + + ^ messages collect: [:e | MIMEDocument fromPartString: e]! Item was changed: + ----- Method: MIMEDocument class>>resetMIMEdatabase (in category 'initialize-release') ----- - ----- Method: MIMEDocument class>>resetMIMEdatabase (in category 'content-types') ----- resetMIMEdatabase MIMEdatabase := self extendedMIMEdatabase! Item was changed: ----- Method: MIMEDocument class>>tryToDecodeBody:as: (in category 'instance creation') ----- tryToDecodeBody: content as: encodingName ^ [(MultiByteBinaryOrTextStream with: content encoding: encodingName) contents] + on: InvalidUTF8 , NoConverterFound do: [(MultiByteBinaryOrTextStream + with: content + encoding: 'latin1') contents]! - on: InvalidUTF8 do: [(MultiByteBinaryOrTextStream - with: content - encoding: 'latin1') contents]! Item was added: + ----- Method: MIMEDocument class>>tryToEncodeBody:as: (in category 'instance creation') ----- + tryToEncodeBody: content as: encodingName + + ^ content convertToEncoding: encodingName! Item was added: + ----- Method: MIMEDocument>>addAllParts: (in category 'parts') ----- + addAllParts: MIMEDocuments + + parts addAll: MIMEDocuments! Item was added: + ----- Method: MIMEDocument>>addPart: (in category 'parts') ----- + addPart: aMIMEDocument + + parts add: aMIMEDocument! Item was added: + ----- Method: MIMEDocument>>asSendableBodyText (in category 'serializing') ----- + asSendableBodyText + + | sendableBodyText | + sendableBodyText := self isMultipart + ifTrue: [self sendableMultipartBodyText] + ifFalse: [(self isPlaintext or: [self isHTML]) + ifTrue: [self class tryToEncodeBody: self contents as: self charset] + ifFalse: [self contents]]. + + ^ (self hasFieldNamed: 'content-transfer-encoding') + ifFalse: [sendableBodyText] + ifTrue: [ | transferEncoding | + transferEncoding := self contentTransferEncoding. + (MimeConverter forEncoding: transferEncoding) mimeEncode: sendableBodyText readStream ] ! Item was added: + ----- Method: MIMEDocument>>asSendablePartText (in category 'serializing') ----- + asSendablePartText + + ^ String streamContents: [ :str | | | + "first put the header" + fields keysAndValuesDo: [ :fieldName :fieldValues | + fieldValues do: [ :fieldValue | + str + nextPutAll: fieldName capitalized ; + nextPutAll: ': '; + nextPutAll: fieldValue asHeaderValue; + cr ]. ]. + + str cr. + + str nextPutAll: self asSendableBodyText].! Item was added: + ----- Method: MIMEDocument>>attachmentSeparator (in category 'accessing') ----- + attachmentSeparator + ^(self fieldNamed: 'content-type' ifAbsent: [^nil]) parameters + at: 'boundary' ifAbsent: [^nil]! Item was added: + ----- Method: MIMEDocument>>bodyTextFormatted (in category 'serializing') ----- + bodyTextFormatted + "Answer a version of the text in my body suitable for display. This will parse multipart forms, decode HTML, and other such things" + + self isMultipart ifTrue: [ + self isMultipartAlternative ifTrue: [ + "it's multipart/alternative. search for a part that we can display, biasing towards simpler formats" + #('text/plain' 'text/html') do: [ :format | + self parts do: [ :part | + part contentType = format ifTrue: [ ^ part bodyTextFormatted ] ] ]. + + "couldn't find a desirable part to display; just display the first part" + ^self parts first bodyTextFormatted ]. + + "not alternative parts. put something for each part" + ^Text streamContents: [ :str | + self parts do: [ :part | + ((#('text' 'multipart') includes: part mainType) or: + [ part contentType = 'message/rfc822']) + ifTrue: [ + "try to inline the message part" + str nextPutAll: part bodyTextFormatted. ] + ifFalse: [ + |descript | + str cr. + descript := part name ifNil: [ 'attachment' ]. + str nextPutAll: (Text string: '[', descript, ']' attribute: (TextMessageLink message: part)). ] ] ]. ]. + + + "check for HTML" + (self contentType = 'text/html') ifTrue: [ + Smalltalk at: #HtmlParser ifPresent: [ :htmlParser | + ^(htmlParser parse: (ReadStream on: self content)) formattedText]. + Smalltalk at: #HtmlReadWriter ifPresent: [:html | + ^ self content asTextFromHtml] + ]. + + "check for an embedded message" + self contentType = 'message/rfc822' ifTrue: [ + ^(MailMessage from: self content) formattedText ]. + + "nothing special--just return the text" + ^self content. + ! Item was changed: ----- Method: MIMEDocument>>charset (in category 'accessing') ----- charset + ^ self contentTypeHeaderValue parameterAt: #charset ifAbsent: ['us-ascii']! - ^ self parameterNamed: 'charset' ifAbsent: ['us-ascii']! Item was changed: ----- Method: MIMEDocument>>charset: (in category 'accessing') ----- charset: aString + ^ self contentTypeHeaderValue parameterAt: #charset put: aString! - ^ parameters at: 'charset' put: aString! Item was added: + ----- Method: MIMEDocument>>containsViewableImage (in category 'testing') ----- + containsViewableImage + + ^ self isJpeg or: [self isGif or: [self isPng]]! Item was changed: ----- Method: MIMEDocument>>content (in category 'accessing') ----- content "Answer the receiver's raw data." + - ^ content! Item was added: + ----- Method: MIMEDocument>>content: (in category 'accessing') ----- + content: aString + content := aString! Item was added: + ----- Method: MIMEDocument>>contentTransferEncoding (in category 'accessing') ----- + contentTransferEncoding + + ^ self contentTransferEncodingHeaderValue mainValue! Item was added: + ----- Method: MIMEDocument>>contentTransferEncodingHeaderValue (in category 'accessing') ----- + contentTransferEncodingHeaderValue + + ^ self fieldNamed: 'content-transfer-encoding' ifAbsent: [nil]! Item was changed: ----- Method: MIMEDocument>>contentType (in category 'accessing') ----- contentType - "Answer the MIME contents type." + ^ self contentTypeHeaderValue mainValue! - ^ self mainType , '/' , self subType! Item was added: + ----- Method: MIMEDocument>>contentTypeHeaderValue (in category 'accessing') ----- + contentTypeHeaderValue + + ^ self fieldNamed: 'content-type' ifAbsent: [self error: 'MIMEDocument requires a content-type field']! Item was added: + ----- Method: MIMEDocument>>contentTypeHeaderValue: (in category 'accessing') ----- + contentTypeHeaderValue: aMIMEHeaderValue + + ^ self setField: 'content-type' to: aMIMEHeaderValue! Item was added: + ----- Method: MIMEDocument>>fieldNamed:ifAbsent: (in category 'fields') ----- + fieldNamed: aString ifAbsent: aBlock + | matchingFields | + "return the value of the field with the specified name. If there is more than one field, then return the first one" + matchingFields := fields at: aString asLowercase ifAbsent: [ ^aBlock value ]. + ^matchingFields first! Item was added: + ----- Method: MIMEDocument>>fieldsFrom:do: (in category 'fields') ----- + fieldsFrom: aStream do: aBlock + "Invoke the given block with each of the header fields from the given stream. The block arguments are the field name and value. The streams position is left right after the empty line separating header and body. + Duplicate of code in MailMessage" + + | savedLine line s | + savedLine := aStream nextLine. + [aStream atEnd] whileFalse: [ + line := savedLine. + (line isEmpty) ifTrue: [^self]. "quit when we hit a blank line" + [savedLine := aStream nextLine. + savedLine notNil and: [savedLine notEmpty] and: [savedLine first isSeparator]] whileTrue: [ + "lines starting with white space are continuation lines" + s := ReadStream on: savedLine. + s skipSeparators. + line := line, ' ', s upToEnd]. + self reportField: line withBlanksTrimmed to: aBlock]. + + "process final header line of a body-less message" + (savedLine isEmpty) ifFalse: [self reportField: savedLine withBlanksTrimmed to: aBlock]. + ! Item was added: + ----- Method: MIMEDocument>>hasFieldNamed: (in category 'fields') ----- + hasFieldNamed: aString + ^fields includesKey: aString asLowercase! Item was added: + ----- Method: MIMEDocument>>initialize (in category 'testing') ----- + initialize + + parts := OrderedCollection new. + fields := Dictionary new. + self setField: 'content-type' toString: self class defaultContentType.! Item was added: + ----- Method: MIMEDocument>>initializeFromString: (in category 'initialize-release') ----- + initializeFromString: aString + "This can only be used for MIME documents which are not multipart." + + | parseStream contentType bodyText contentTransferEncoding text | + + text := aString withoutTrailingBlanks, String cr, String cr. + parseStream := ReadStream on: text. + contentType := 'text/plain'. + contentTransferEncoding := nil. + fields := Dictionary new. + + "Extract information out of the header fields" + self fieldsFrom: parseStream do: + [:fName :fValue | + "NB: fName is all lowercase" + + fName = 'content-type' ifTrue: [contentType := fValue asLowercase]. + fName = 'content-transfer-encoding' ifTrue: [contentTransferEncoding := fValue asLowercase]. + + (fields at: fName ifAbsentPut: [OrderedCollection new: 1]) + add: (MIMEHeaderValue forField: fName fromString: fValue)]. + + "Extract the body of the message" + bodyText := parseStream upToEnd. + bodyText := (MimeConverter forEncoding: contentTransferEncoding) + mimeDecode: (ReadStream on: bodyText) as: String. + bodyText := self class tryToDecodeBody: bodyText as: self charset. + + self isMultipart + ifTrue: [parts := self class parseParts: bodyText withSeparator: self attachmentSeparator] + ifFalse: [content := bodyText] + ! Item was changed: ----- Method: MIMEDocument>>mainType (in category 'accessing') ----- mainType + ^ (self contentType splitBy: '/') first! - ^ mainType! Item was added: + ----- Method: MIMEDocument>>name (in category 'accessing') ----- + name + "return a default name for this part, if any was specified. If not, return nil" + | type nameField disposition | + + "try in the content-type: header" + type := self fieldNamed: 'content-type' ifAbsent: [nil]. + (type notNil and: [(nameField := type parameters at: 'name' ifAbsent: [nil]) notNil]) + ifTrue: [^ nameField]. + + "try in content-disposition:" + disposition := self fieldNamed: 'content-disposition' ifAbsent: [nil]. + (disposition notNil and: [(nameField := disposition parameters at: 'filename' ifAbsent: [nil]) notNil]) + ifTrue: [^ nameField]. + + "give up" + ^ nil! Item was added: + ----- Method: MIMEDocument>>parameterizedContentTransferEncoding (in category 'accessing') ----- + parameterizedContentTransferEncoding + + ^ self contentTransferEncoding asHeaderValue! Item was added: + ----- Method: MIMEDocument>>parameterizedContentType (in category 'accessing') ----- + parameterizedContentType + + ^ self contentTypeHeaderValue asHeaderValue + + ! Item was changed: ----- Method: MIMEDocument>>parts (in category 'accessing') ----- parts + ^ parts - "Return the parts of this message. There is a far more reliable implementation of parts in MailMessage, but for now we are continuing to use this implementation" - - | parseStream currLine separator msgStream messages | - self isMultipart ifFalse: [^ #()]. - parseStream := ReadStream on: self content. - currLine := ''. - ['--*' match: currLine] - whileFalse: [currLine := parseStream nextLine]. - separator := currLine copy. - msgStream := LimitingLineStreamWrapper on: parseStream delimiter: separator. - messages := OrderedCollection new. - [parseStream atEnd] - whileFalse: - [messages add: msgStream upToEnd. - msgStream skipThisLine]. - ^ messages collect: [:e | MailMessage from: e] ! Item was changed: ----- Method: MIMEDocument>>privateMainType: (in category 'private') ----- privateMainType: aString + + self contentTypeHeaderValue mainValue: (aString , '/' , self subType)! - mainType := aString! Item was changed: ----- Method: MIMEDocument>>privateSubType: (in category 'private') ----- privateSubType: aString + + self contentTypeHeaderValue mainValue: (self mainType , '/' , aString)! - subType := aString! Item was added: + ----- Method: MIMEDocument>>reportField:to: (in category 'fields') ----- + reportField: aString to: aBlock + "Evaluate the given block with the field name a value in the given field. Do nothing if the field is malformed. + Duplicate of code in MailMessage" + + | s fieldName fieldValue | + (aString includes: $:) ifFalse: [^self]. + s := ReadStream on: aString. + fieldName := (s upTo: $:) asLowercase. "fieldname must be lowercase" + fieldValue := s upToEnd withBlanksTrimmed. + fieldValue isEmpty ifFalse: [aBlock value: fieldName value: fieldValue]. + ! Item was added: + ----- Method: MIMEDocument>>save (in category 'interactions') ----- + save + "save the part to a file" + | fileName file | + fileName := self name + ifNil: ['attachment' , Utilities dateTimeSuffix]. + (fileName includes: $.) ifFalse: [ + #(isJpeg 'jpg' isGif 'gif' isPng 'png' isPnm 'pnm') pairsDo: [ :s :e | + (self perform: s) ifTrue: [fileName := fileName, '.', e] + ] + ]. + fileName := UIManager default request: 'File name for save?' initialAnswer: fileName. + fileName isEmpty + ifTrue: [^ nil]. + + + file := FileStream newFileNamed: fileName. + self contentTransferEncoding = 'base64' ifTrue: [file binary]. + file nextPutAll: self contents. + file close! Item was added: + ----- Method: MIMEDocument>>sendableMultipartBodyText (in category 'serializing') ----- + sendableMultipartBodyText + + ^ String streamContents: [ :str | + str cr. + parts do: [ :part | + str + cr; + nextPutAll: '--'; + nextPutAll: self attachmentSeparator; + cr; + nextPutAll: part asSendablePartText ]. + + str + cr; + nextPutAll: '--'; + nextPutAll: self attachmentSeparator; + nextPutAll: '--'; + cr ]! Item was added: + ----- Method: MIMEDocument>>setField:to: (in category 'fields') ----- + setField: fieldName to: aFieldValue + "set a field. If any field of the specified name exists, it will be overwritten" + fields at: fieldName asLowercase put: (OrderedCollection with: aFieldValue).! Item was added: + ----- Method: MIMEDocument>>setField:toString: (in category 'fields') ----- + setField: fieldName toString: fieldValue + ^self setField: fieldName to: (MIMEHeaderValue forField: fieldName fromString: fieldValue)! Item was changed: ----- Method: MIMEDocument>>subType (in category 'accessing') ----- subType + ^ (self contentType splitBy: '/') second! - ^ subType! Item was added: + ----- Method: MIMEDocument>>text (in category 'accessing') ----- + text + "Compatibility with MailMessage protocol" + ^self contents! Item was added: + ----- Method: MIMEDocument>>view (in category 'interactions') ----- + view + + self containsViewableImage + ifTrue: [^ self viewImage]. + (StringHolder new contents: self bodyTextFormatted; + yourself) + openLabel: (self name ifNil: ['(a message part)'])! Item was added: + ----- Method: MIMEDocument>>viewImage (in category 'interactions') ----- + viewImage + | stream image | + stream := self contentStream. + image := Form fromBinaryStream: stream. + (Project current world drawingClass withForm: image) openInWorld! Item was changed: ----- Method: MIMEHeaderValue>>asHeaderValue (in category 'printing') ----- asHeaderValue | strm | strm := WriteStream on: (String new: 20). strm nextPutAll: mainValue. + parameters associationsDo: [:e | + strm + nextPut: $; ; + nextPutAll: e key; + nextPutAll: '='; + nextPutAll: e value]. - parameters associationsDo: [:e | strm nextPut: $; ; nextPutAll: e key; - nextPutAll: '="'; - nextPutAll: e value , '"']. ^ strm contents! Item was changed: ----- Method: MIMEHeaderValue>>mainValue (in category 'accessing') ----- mainValue + ^ [mainValue decodeMimeHeader] + on: InvalidUTF8 , NoConverterFound do: [:e | mainValue]! - ^mainValue decodeMimeHeader! Item was added: + ----- Method: MIMEHeaderValue>>parameterAt:ifAbsent: (in category 'accessing') ----- + parameterAt: aParameter ifAbsent: absentBlock + + ^ parameters at: aParameter ifAbsent: absentBlock! Item was changed: ----- Method: MailMessage class>>from: (in category 'instance creation') ----- from: aString "Initialize a new instance from the given string." + ^(self new) initializeFromString: aString! - ^ self new - setText: aString; - yourself! Item was added: + ----- Method: MailMessage class>>replyAllFor: (in category 'instance creation') ----- + replyAllFor: aMailMessage + + ^ self replyFor: aMailMessage excluding: {}! Item was added: + ----- Method: MailMessage class>>replyAllFor:excluding: (in category 'instance creation') ----- + replyAllFor: aMailMessage excluding: ignoredEmailAddresses + + | replySubject references replyReceivers ccReceivers | + + replyReceivers := MailAddressParser addressesIn: (aMailMessage fieldsNamed: 'to' separatedBy: ', '). + replyReceivers := replyReceivers reject: [:m | + ignoredEmailAddresses includes: m ]. + replyReceivers addFirst: aMailMessage replyReceiver. + + replySubject := aMailMessage replySubject. + references := aMailMessage references. + + ccReceivers := MailAddressParser addressesIn: aMailMessage cc. + ccReceivers := ccReceivers reject: [:m | + ignoredEmailAddresses includes: m ]. + + ^ self empty + to: (replyReceivers joinSeparatedBy: ','); + cc: (ccReceivers joinSeparatedBy: ','); + subject: replySubject; + setField: 'in-reply-to' toString: aMailMessage messageId; + setField: 'references' toString: references; + yourself + ! Item was changed: ----- Method: MailMessage class>>replyFor: (in category 'instance creation') ----- replyFor: aMailMessage | replyReceiver replySubject references | + replyReceiver := aMailMessage replyReceiver. + replySubject := aMailMessage replySubject. + references := aMailMessage references. - replyReceiver := (aMailMessage - fieldNamed: 'reply-to' - ifAbsent: [aMailMessage - fieldNamed: 'from' - ifAbsent: [self error: 'there is a field missing in the original message']]) mainValue. - - replySubject := (aMailMessage subject beginsWith: 'Re:') - ifTrue: [aMailMessage subject] - ifFalse: ['Re: ' , aMailMessage subject]. - - references := (aMailMessage hasFieldNamed: 'references') - ifTrue: [(aMailMessage fieldNamed: 'references' ifAbsent: [self error: 'Something changed the mail between the check and now']) mainValue , ', ' , aMailMessage messageId] - ifFalse: [aMailMessage messageId]. ^ self empty to: replyReceiver; subject: replySubject; setField: 'in-reply-to' toString: aMailMessage messageId; setField: 'references' toString: references; yourself ! Item was removed: - ----- Method: MailMessage class>>selfTest (in category 'testing') ----- - selfTest - - | msgText msg | - - msgText := - 'Date: Tue, 20 Feb 2001 13:52:53 +0300 - From: mdr at scn.rg (Me Ru) - Subject: RE: Windows 2000 on your laptop - To: "Greg Y" <to1 at mail.com> - cc: cc1 at scn.org, cc1also at test.org - To: to2 at no.scn.org, to2also at op.org - cc: cc2 at scn.org - - Hmmm... Good. I will try to swap my German copy for something in - English, and then do the deed. Oh, and expand my RAM to 128 first. - - Mike - '. - - msg := self new from: msgText. - - [msg text = msgText] assert. - [msg subject = 'RE: Windows 2000 on your laptop'] assert. - [msg from = 'mdr at scn.rg (Me Ru)'] assert. - [msg date = '2/20/01'] assert. - [msg time = 667133573] assert. - "[msg name] assert." - [msg to = '"Greg Y" <to1 at mail.com>, to2 at no.scn.org, to2also at op.org'] assert. - [msg cc = 'cc1 at scn.org, cc1also at test.org, cc2 at scn.org'] assert. - - "MailMessage selfTest" - ! Item was changed: ----- Method: MailMessage>>addAttachmentFrom:withName: (in category 'multipart') ----- addAttachmentFrom: aStream withName: aName + "add an attachment, encoding with base64. aName is the optional filename" - "add an attachment, encoding with base64. aName is the option filename to encode" | newPart | self makeMultipart. - self parts. "make sure parts have been parsed" + newPart := MIMEDocument contentType: (MIMEDocument guessTypeFromName: aName) content: ''. - "create the attachment as a MailMessage" - newPart := MailMessage empty. - newPart setField: 'content-type' toString: 'application/octet-stream'. newPart setField: 'content-transfer-encoding' toString: 'base64'. + newPart setField: 'content-disposition' toString: 'attachment'. + aName ifNotNil: [ + | dispositionField contentTypeField | + dispositionField := newPart fieldNamed: 'content-disposition' + ifAbsent: [self error: 'Should be initialized by now']. + dispositionField parameterAt: 'filename' put: '"' , aName , '"'. + + contentTypeField := newPart fieldNamed: 'content-type' + ifAbsent: [self error: 'Should be initialized by now']. + contentTypeField parameterAt: 'name' put: '"' , aName , '"'.]. + + newPart content: aStream upToEnd. + self body addPart: newPart.! - | dispositionField | - dispositionField := MIMEHeaderValue fromMIMEHeader: 'attachment'. - dispositionField parameterAt: 'filename' put: aName. - newPart setField: 'content-disposition' to: dispositionField ]. - newPart body: (MIMEDocument contentType: 'application/octet-stream' content: aStream upToEnd). - - - "regenerate our text" - parts := parts copyWith: newPart. - self regenerateBodyFromParts. - text := nil.! Item was changed: ----- Method: MailMessage>>asSendableText (in category 'printing/formatting') ----- asSendableText + + | serializedMail | + serializedMail := self text. + ^ self wrapLinesOf: serializedMail! - "break lines in the given string into shorter lines" - | result atAttachment width aString pastHeader | - width := 72. - aString := self text. - result := WriteStream on: (String new: aString size * 50 // 49). - pastHeader := false. - atAttachment := false. - aString asString - linesDo: - [:line | | end start | - line isEmpty ifTrue: [pastHeader := true]. - pastHeader - ifTrue: - ["(line beginsWith: '--==') - ifTrue: [atAttachment := true]." - atAttachment - ifTrue: - ["at or after an attachment line; no more - wrapping for the rest of the message" - result nextPutAll: line. - result cr] - ifFalse: [(line beginsWith: '>') - ifTrue: - ["it's quoted text; don't wrap it" - result nextPutAll: line. - result cr] - ifFalse: - ["regular old line. Wrap it to multiple - lines " - start := 1. - "output one shorter line each time - through this loop" - [start + width <= line size] - whileTrue: - ["find the end of the line" - end := start + width - 1. - [end >= start and: [(line at: end + 1) isSeparator not]] - whileTrue: [end := end - 1]. - end < start ifTrue: ["a word spans the entire - width!! " - end := start + width - 1]. - "copy the line to the output" - result nextPutAll: (line copyFrom: start to: end). - result cr. - "get ready for next iteration" - start := end + 1. - (line at: start) isSeparator ifTrue: [start := start + 1]]. - "write out the final part of the line" - result nextPutAll: (line copyFrom: start to: line size). - result cr]]] - ifFalse: - [result nextPutAll: line. - result cr]]. - ^ result contents! Item was changed: + ----- Method: MailMessage>>body (in category 'accessing') ----- - ----- Method: MailMessage>>body (in category 'access') ----- body "return just the body of the message" ^body! Item was changed: ----- Method: MailMessage>>body: (in category 'initialize-release') ----- body: newBody + + self isMultipart + ifTrue: [self body parts at: 1 put: newBody] + ifFalse: [body := newBody]! - "change the body" - body := newBody. - text := nil.! Item was changed: + ----- Method: MailMessage>>bodyText (in category 'accessing') ----- - ----- Method: MailMessage>>bodyText (in category 'access') ----- bodyText "return the text of the body of the message" + ^ body asSendableBodyText! - ^body content! Item was changed: ----- Method: MailMessage>>bodyTextFormatted (in category 'printing/formatting') ----- bodyTextFormatted - "Answer a version of the text in my body suitable for display. This will parse multipart forms, decode HTML, and other such things" + ^ self body bodyTextFormatted - "check for multipart" - self body isMultipart ifTrue: [ - "check for alternative forms" - self body isMultipartAlternative ifTrue: [ - "it's multipart/alternative. search for a part that we can display, biasing towards nicer formats" - #('text/html' 'text/plain') do: [ :format | - self parts do: [ :part | - part body contentType = format ifTrue: [ ^ part bodyTextFormatted ] ] ]. - - "couldn't find a desirable part to display; just display the first part" - ^self parts first bodyTextFormatted ]. - - "not alternative parts. put something for each part" - ^Text streamContents: [ :str | - self parts do: [ :part | - ((#('text' 'multipart') includes: part body mainType) or: - [ part body contentType = 'message/rfc822']) - ifTrue: [ - "try to inline the message part" - str nextPutAll: part bodyTextFormatted. ] - ifFalse: [ - |descript | - str cr. - descript := part name ifNil: [ 'attachment' ]. - str nextPutAll: (Text string: '[', descript, ']' attribute: (TextMessageLink message: part)). ] ] ]. ]. - - - "check for HTML" - (self body contentType = 'text/html') ifTrue: [ - Smalltalk at: #HtmlParser ifPresent: [ :htmlParser | - ^(htmlParser parse: (ReadStream on: body content)) formattedText]. - Smalltalk at: #HtmlReadWriter ifPresent: [:html | - ^ body content asTextFromHtml] - ]. - - "check for an embedded message" - self body contentType = 'message/rfc822' ifTrue: [ - ^(MailMessage from: self body content) formattedText ]. - - "nothing special--just return the text" - ^body content. - ! Item was added: + ----- Method: MailMessage>>contentType (in category 'accessing') ----- + contentType + + ^ self body contentTypeHeaderValue! Item was changed: + ----- Method: MailMessage>>date (in category 'accessing') ----- - ----- Method: MailMessage>>date (in category 'access') ----- date + - ^ DateAndTime fromSeconds: self time + (Date newDay: 1 year: 1980) asSeconds! Item was changed: + ----- Method: MailMessage>>dateString (in category 'accessing') ----- - ----- Method: MailMessage>>dateString (in category 'access') ----- dateString "Answer a date string for this message." + ^(Date fromSeconds: self time + (Date newDay: 1 year: 1980) asSeconds) + printFormat: #(2 1 3 47 1 2)! - ^ self date asDate printFormat: #(2 1 3 47 1 2)! Item was changed: + ----- Method: MailMessage>>dateTime: (in category 'accessing') ----- - ----- Method: MailMessage>>dateTime: (in category 'access') ----- dateTime: aDateTime self setField: 'date' toString: aDateTime asMailMessageString! Item was changed: + ----- Method: MailMessage>>fields (in category 'accessing') ----- - ----- Method: MailMessage>>fields (in category 'access') ----- fields "return the internal fields structure. This is private and subject to change!!" ^ fields! Item was changed: + ----- Method: MailMessage>>from (in category 'accessing') ----- - ----- Method: MailMessage>>from (in category 'access') ----- from ^(self fieldNamed: 'from' ifAbsent: [ ^'' ]) mainValue! Item was changed: + ----- Method: MailMessage>>from: (in category 'accessing') ----- - ----- Method: MailMessage>>from: (in category 'access') ----- from: aString | sanitizedMailAddress | sanitizedMailAddress := (MailAddressParser addressesIn: aString) first. ^self setField: 'from' toString: sanitizedMailAddress! Item was changed: ----- Method: MailMessage>>initialize (in category 'initialize-release') ----- initialize "initialize as an empty message" text := String cr. fields := Dictionary new. + body := MIMEDocument contentType: 'text/plain' content: String cr. + self dateTime: TimeStamp now.! - body := MIMEDocument contentType: 'text/plain' content: String cr! Item was added: + ----- Method: MailMessage>>initializeFromString: (in category 'initialize-release') ----- + initializeFromString: aString + "Parse aString to initialize myself." + + | parseStream contentType bodyText contentTransferEncoding | + + text := aString withoutTrailingBlanks, String cr, String cr. + parseStream := ReadStream on: text. + contentType := 'text/plain'. + contentTransferEncoding := nil. + fields := Dictionary new. + + "Extract information out of the header fields" + self fieldsFrom: parseStream do: + [:fName :fValue | + "NB: fName is all lowercase" + + fName = 'content-type' ifTrue: [contentType := fValue asLowercase]. + fName = 'content-transfer-encoding' ifTrue: [contentTransferEncoding := fValue asLowercase]. + + (fields at: fName ifAbsentPut: [OrderedCollection new: 1]) + add: (MIMEHeaderValue forField: fName fromString: fValue)]. + + "Extract the body of the message" + bodyText := parseStream upToEnd. + bodyText := (MimeConverter forEncoding: contentTransferEncoding) + mimeDecode: (ReadStream on: bodyText) as: String. + + body := MIMEDocument contentType: contentType content: bodyText! Item was added: + ----- Method: MailMessage>>isMultipart (in category 'multipart') ----- + isMultipart + + ^ self body isMultipart! Item was changed: ----- Method: MailMessage>>makeMultipart (in category 'multipart') ----- makeMultipart "if I am not multipart already, then become a multipart message with one part" + | newBody | - | part multipartHeader | body isMultipart ifTrue: [ ^self ]. "set up the new message part" + newBody := MIMEDocument newMultipart. + newBody addPart: body. + - part := MailMessage empty. - part body: body. - (self hasFieldNamed: 'content-type') ifTrue: [ - part setField: 'content-type' to: (self fieldNamed: 'content-type' ifAbsent: ['']) ]. - parts := Array with: part. - - "fix up our header" - multipartHeader := MIMEHeaderValue fromMIMEHeader: 'multipart/mixed'. - multipartHeader parameterAt: 'boundary' put: self class generateSeparator . - self setField: 'content-type' to: multipartHeader. - self setField: 'mime-version' to: (MIMEHeaderValue fromMIMEHeader: '1.0'). - self removeFieldNamed: 'content-transfer-encoding'. + body := newBody.! - "regenerate everything" - self regenerateBodyFromParts. - text := nil.! Item was changed: + ----- Method: MailMessage>>messageId (in category 'accessing') ----- - ----- Method: MailMessage>>messageId (in category 'access') ----- messageId + ^ (self fieldNamed: 'message-id' ifAbsent: [ ^'' ]) mainValue! - ^ (self fieldNamed: 'message-id' ifAbsent: [ ^'' ]) mainValue - ! Item was changed: + ----- Method: MailMessage>>messageId: (in category 'accessing') ----- - ----- Method: MailMessage>>messageId: (in category 'access') ----- messageId: aString ^ self setField: 'message-id' toString: aString! Item was added: + ----- Method: MailMessage>>parseParts: (in category 'multipart') ----- + parseParts: bodyText + "private -- parse the parts of the message and store them into a collection" + + | parseStream msgStream messages separator | + + "If we can't find a valid separator, handle it as if the message is not multipart" + separator := self attachmentSeparator. + separator ifNil: [self error: 'Bad attachment separater']. + + separator := '--', separator withoutTrailingBlanks. + parseStream := ReadStream on: bodyText. + + msgStream := LimitingLineStreamWrapper on: parseStream delimiter: separator. + msgStream limitingBlock: [:aLine | + aLine withoutTrailingBlanks = separator or: "Match the separator" + [aLine withoutTrailingBlanks = (separator, '--')]]. "or the final separator with --" + + "Throw away everything up to and including the first separator" + msgStream upToEnd. + msgStream skipThisLine. + + "Extract each of the multi-parts as strings" + messages := OrderedCollection new. + [parseStream atEnd] + whileFalse: + [messages add: msgStream upToEnd. + msgStream skipThisLine]. + + ^ messages collect: [:e | MIMEDocument from: e]! Item was changed: ----- Method: MailMessage>>parts (in category 'multipart') ----- parts + + ^ self body parts! - parts ifNil: [self parseParts]. - ^ parts! Item was changed: ----- Method: MailMessage>>printOn: (in category 'printing/formatting') ----- printOn: aStream - "For text parts with no filename show: 'text/plain: first line of text...' - for attachments/filenamed parts show: 'attachment: filename.ext'" + aStream nextPutAll: 'Text: ' , self excerpt! - | name | - - aStream nextPutAll: ((name := self name) ifNil: ['Text: ' , self excerpt] - ifNotNil: ['File: ' , name])! Item was changed: ----- Method: MailMessage>>readDateFrom: (in category 'parsing') ----- readDateFrom: aStream "Parse a date from the given stream and answer nil if the date can't be parsed. The date may be in any of the following forms: <day> <monthName> <year> (5 April 1982; 5-APR-82) <monthName> <day> <year> (April 5, 1982) <monthNumber> <day> <year> (4/5/82) In addition, the date may be preceded by the day of the week and an optional comma, such as: Tue, November 14, 1989" | day month year | self skipWeekdayName: aStream. aStream peek isDigit ifTrue: [day := Integer readFrom: aStream]. [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. aStream peek isLetter ifTrue: "month name or weekday name" [month := WriteStream on: (String new: 10). [aStream peek isLetter] whileTrue: [month nextPut: aStream next]. month := month contents. day isNil ifTrue: "name/number..." [[aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. (aStream peek isDigit) ifFalse: [^nil]. day := Integer readFrom: aStream]] ifFalse: "number/number..." [month := Date nameOfMonth: day. day := Integer readFrom: aStream]. [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. (aStream peek isDigit) ifFalse: [^nil]. year := Integer readFrom: aStream. + ^ Date newDay: day month: month year: year! - ^Date newDay: day month: month year: year! Item was added: + ----- Method: MailMessage>>references (in category 'accessing') ----- + references + + ^ (self hasFieldNamed: 'references') + ifTrue: [(self fieldNamed: 'references' ifAbsent: [self error: 'Something changed the mail between the check and now']) + mainValue , ', ' , self messageId] + ifFalse: [self messageId].! Item was added: + ----- Method: MailMessage>>replyReceiver (in category 'accessing') ----- + replyReceiver + + ^ (self + fieldNamed: 'reply-to' + ifAbsent: [self + fieldNamed: 'from' + ifAbsent: [self error: 'there is a field missing in the original message']]) mainValue. + ! Item was added: + ----- Method: MailMessage>>replySubject (in category 'accessing') ----- + replySubject + + ^ (self subject asLowercase beginsWith: 're:') + ifTrue: [self subject] + ifFalse: ['Re: ' , self subject].! Item was changed: ----- Method: MailMessage>>selfTest (in category 'testing') ----- selfTest "For testing only: Check that this instance is well formed and makes sense" + - self formattedText. [MailAddressParser addressesIn: self from] ifError: [ :err :rcvr | Transcript show: 'Error parsing From: (', self from, ') ', err]. [MailAddressParser addressesIn: self to] ifError: [ :err :rcvr | Transcript show: 'Error parsing To: (', self to, ') ', err]. [MailAddressParser addressesIn: self cc] ifError: [ :err :rcvr | Transcript show: 'Error parsing CC: (', self cc, ') ', err]. ! Item was changed: + ----- Method: MailMessage>>setField:to: (in category 'fields') ----- - ----- Method: MailMessage>>setField:to: (in category 'initialize-release') ----- setField: fieldName to: aFieldValue "set a field. If any field of the specified name exists, it will be overwritten" fields at: fieldName asLowercase put: (OrderedCollection with: aFieldValue). text := nil.! Item was changed: + ----- Method: MailMessage>>setField:toString: (in category 'fields') ----- - ----- Method: MailMessage>>setField:toString: (in category 'initialize-release') ----- setField: fieldName toString: fieldValue ^self setField: fieldName to: (MIMEHeaderValue forField: fieldName fromString: fieldValue)! Item was changed: + ----- Method: MailMessage>>subject (in category 'accessing') ----- - ----- Method: MailMessage>>subject (in category 'access') ----- subject ^ (self fieldNamed: 'subject' ifAbsent: [ ^'' ]) mainValue! Item was changed: + ----- Method: MailMessage>>subject: (in category 'accessing') ----- - ----- Method: MailMessage>>subject: (in category 'access') ----- subject: aString + ^self setField: 'subject' toString: aString! - ^ self setField: 'subject' toString: aString! Item was changed: + ----- Method: MailMessage>>text (in category 'accessing') ----- - ----- Method: MailMessage>>text (in category 'access') ----- text + + ^ String streamContents: [ :str | | encodedBodyText | + "first put the header" + (fields associations , {'content-type' -> {self body contentTypeHeaderValue} }) + do: [ :assoc | | fieldName fieldValues | + fieldName := assoc key. + fieldValues := assoc value. + fieldValues do: [ :fieldValue | + str + nextPutAll: fieldName capitalized ; + nextPutAll: ': '; + nextPutAll: fieldValue asHeaderValue; + cr ]]. + + self body contentTransferEncodingHeaderValue + ifNotNil: [:headerValue | + str + nextPutAll: 'content-transfer-encoding' capitalized; + nextPutAll: ': '; + nextPutAll: headerValue asHeaderValue; + cr ]. + + "skip a line between header and body" + str cr. + + "put the body, being sure to encode it according to the header" + encodedBodyText := body asSendableBodyText. + str nextPutAll: encodedBodyText ].! - "the full, unprocessed text of the message" - text ifNil: [ self regenerateText ]. - ^text! Item was changed: + ----- Method: MailMessage>>time (in category 'accessing') ----- - ----- Method: MailMessage>>time (in category 'access') ----- time | dateField | dateField := (self fieldNamed: 'date' ifAbsent: [ ^0 ]) mainValue. ^ [self timeFrom: dateField] ifError: [:err :rcvr | Date today asSeconds]. ! Item was changed: + ----- Method: MailMessage>>to (in category 'accessing') ----- - ----- Method: MailMessage>>to (in category 'access') ----- to ^self fieldsNamed: 'to' separatedBy: ', '! Item was changed: + ----- Method: MailMessage>>to: (in category 'accessing') ----- - ----- Method: MailMessage>>to: (in category 'access') ----- to: aString + - "Set the to address(es). Make sure order is preserved when uniqueing the addresses." | sanitizedMailAddresses | + sanitizedMailAddresses := (MailAddressParser addressesIn: aString) asSet asArray. + ^self setField: 'to' toString: (sanitizedMailAddresses joinSeparatedBy: ', ')! - sanitizedMailAddresses := MailAddressParser addressesIn: aString. - ^self setField: 'to' toString: (sanitizedMailAddresses withoutDuplicates joinSeparatedBy: ', ')! Item was added: + ----- Method: MailMessage>>wrapLinesOf: (in category 'printing/formatting') ----- + wrapLinesOf: aString + + "break lines in the given string into shorter lines" + | result atAttachment width pastHeader | + width := 72. + result := WriteStream on: (String new: aString size * 50 // 49). + pastHeader := false. + atAttachment := false. + aString asString + linesDo: + [:line | | end start | + line isEmpty ifTrue: [pastHeader := true]. + pastHeader + ifTrue: + ["(line beginsWith: '--==') + ifTrue: [atAttachment := true]." + atAttachment + ifTrue: + ["at or after an attachment line; no more + wrapping for the rest of the message" + result nextPutAll: line. + result cr] + ifFalse: [(line beginsWith: '>') + ifTrue: + ["it's quoted text; don't wrap it" + result nextPutAll: line. + result cr] + ifFalse: + ["regular old line. Wrap it to multiple + lines " + start := 1. + "output one shorter line each time + through this loop" + [start + width <= line size] + whileTrue: + ["find the end of the line" + end := start + width - 1. + [end >= start and: [(line at: end + 1) isSeparator not]] + whileTrue: [end := end - 1]. + end < start ifTrue: ["a word spans the entire + width!! " + end := start + width - 1]. + "copy the line to the output" + result nextPutAll: (line copyFrom: start to: end). + result cr. + "get ready for next iteration" + start := end + 1. + (line at: start) isSeparator ifTrue: [start := start + 1]]. + "write out the final part of the line" + result nextPutAll: (line copyFrom: start to: line size). + result cr]]] + ifFalse: + [result nextPutAll: line. + result cr]]. + + ^ result contents!
More information about the Squeak-dev mailing list |