MTMain.mesa
Hal Murray May 27, 1985 8:06:02 pm PDT
Last Edited by: HGM, April 20, 1985 10:12:40 pm PST
Last Edited by: Nichols, July 19, 1983 1:54 pm
Last Edited by: Taft, February 5, 1984 1:13:05 pm PST
Sharon Johnson, July 27, 1987 2:19:31 pm PDT
John Larson, July 27, 1987 6:29:59 pm PDT
DIRECTORY
Ascii USING [CR, LF, SP, TAB],
IO USING [EndOf, EndOfStream, GetBlock, GetChar, GetIndex, PeekChar, Put, PutBlock, PutChar, PutF, PutFR, PutRope, RIS, rope, SetIndex, STREAM],
List USING [Nconc1],
RefText USING [ObtainScratch, ReleaseScratch],
Rope USING [Cat, Equal, Fetch, Find, IsEmpty, Length, ROPE],
PrincOpsUtils USING [Codebase],
Lex822 USING [CharProc, GetSequence, LexFieldName, LexText, LexToken],
MT USING[Direction],
MTMiscOps USING [Lookup, Table],
MTP1 USING [GetEvalResult, InstallParseTable, Parse, ScannerProc, ScanDate, ScanName],
MTParseData,
MTTreeOps: TYPE USING [DefaultDomain, discretionaryBlank, DomainType, TreeToRope, TreeToSimpleRope, ToArpa, ToGrapevine, XeroxDomain];
MTMain: CEDAR MONITOR -- Parser has lots of global data
IMPORTS
IO, List, MTMiscOps, PrincOpsUtils, RefText, Rope, Lex822,
MTP1, MTParseData, MTTreeOps
EXPORTS MT =
BEGIN OPEN P1: MTP1;
ROPE: TYPE = Rope.ROPE;
This table holds the names of headers in a message that should be parsed as name fields.
nameFields: MTMiscOps.Table ~ LIST["from", "sender", "to", "cc", "bcc", "reply-to", "resent-from", "resent-sender", "resent-to", "resent-cc", "resent-bcc", "resent-reply-to", "remailed-from", "remailed-sender", "remailed-to", "remailed-cc", "remailed-bcc"];
Other interesting header filed names.
msgID: ROPE = "Message-ID";
lineFold: ROPE = "Line-Fold";
The variable that holds the parsed header and its type.
HeaderRec: TYPE = RECORD[
name: Rope.ROPE,
fieldType: {textField, dateField, nameField},
body: REF ANY]; -- Rope for text and whatever MTP1.GetEvalResult returns for others
Info: TYPE = REF InfoRec;
InfoRec: PUBLIC TYPE = RECORD [
id: ROPE ← NIL,
foldLines: BOOL, -- TRUE if we should fold lines for this message.
defaultDomainType: MTTreeOps.DomainType, -- defaults for translate routines
defaultDomain: REF ANY,
headers: LIST OF REF ANY ]; -- really LIST OF REF HeaderRec, but I need the List ops
Line folding stuff.
foldLength: INT ← 72; -- How long to make folded lines.
alreadyFoldedLength: INT ← 90; -- Max a line can be and still appear to be folded.
alreadyFoldedLookahead: INT ← 5000; -- Look at this many chars to decide if folded.
InitParser: PROC = TRUSTED {
Initializes the parser for parsing name fields.
P1.InstallParseTable[LOOPHOLE[PrincOpsUtils.Codebase[LOOPHOLE[MTParseData]]]]; };
IsNameFieldHeader: PROC [fieldName: Rope.ROPE] RETURNS [BOOL] = {
Returns TRUE if fieldName is in nameFields, the list of headers that contain names.
RETURN [MTMiscOps.Lookup[fieldName, nameFields]];
};
AlreadyFolded: PROC [in: IO.STREAM] RETURNS [isFolded: BOOL] = {
Look at the first part of in and decide if it's already folded.
pos: INT ← in.GetIndex[];
curLength, maxLength: INT ← 0;
count: INT ← 0;
WHILE count < alreadyFoldedLookahead AND ~in.EndOf[] DO
IF in.GetChar[] = Ascii.CR THEN {
IF curLength > maxLength THEN maxLength ← curLength;
curLength ← 0; }
ELSE curLength ← curLength+1;
count ← count+1;
ENDLOOP;
IF curLength > maxLength THEN maxLength ← curLength;
in.SetIndex[pos];
RETURN [maxLength <= alreadyFoldedLength]; };
CopyFolded: PROC [in, out: IO.STREAM, breakRope: Rope.ROPE ← NIL, lineLength: INT ← foldLength, initialLength: INT ← 0] = {
Fold the the text from in appending the breakRope to the newline that is used to break. lineLength controls how long the lines are, and initialLength tells how much text is on the current line when CopyFolded is first called.
currentLength: INT ← initialLength;
breakLength: INT ← breakRope.Length[];
whiteSpace, blackSpace: Rope.ROPE;
WhiteSpaceProc: Lex822.CharProc = {
SELECT char FROM
Ascii.SP, Ascii.TAB, Ascii.LF => RETURN [FALSE, TRUE];
MTTreeOps.discretionaryBlank => RETURN [FALSE, FALSE]
ENDCASE => RETURN [TRUE, FALSE]; };
BlackSpaceProc: Lex822.CharProc = {
SELECT char FROM
Ascii.SP, Ascii.TAB, Ascii.LF, Ascii.CR, MTTreeOps.discretionaryBlank =>
RETURN [TRUE, FALSE];
ENDCASE => RETURN [FALSE, TRUE]; };
DO
ENABLE IO.EndOfStream => EXIT;
IF in.PeekChar[] = Ascii.CR THEN {
out.PutChar[in.GetChar[]];
[] ← in.PeekChar[]; -- Careful! Don't output the breakRope if we're out of input.
IF breakLength > 0 THEN
out.PutRope[breakRope];
currentLength ← breakLength;
};
whiteSpace ← Lex822.GetSequence[in, WhiteSpaceProc];
blackSpace ← Lex822.GetSequence[in, BlackSpaceProc];
IF currentLength+whiteSpace.Length[]+blackSpace.Length[] > lineLength THEN {
IF blackSpace.Length[] > 0 THEN {
out.PutChar['\n];
IF breakLength > 0 THEN
out.PutRope[breakRope];
out.PutRope[blackSpace];
currentLength ← breakLength+blackSpace.Length[];
};
else we must be at EOF or a newline and we might as well just discard the whiteSpace.
}
ELSE {
out.PutRope[whiteSpace];
out.PutRope[blackSpace];
currentLength ← currentLength+whiteSpace.Length[]+blackSpace.Length[];
};
ENDLOOP;
};
CopyNormal: PROC [in, out: IO.STREAM] ~ {
Copy in to out.
buffer: REF TEXT = RefText.ObtainScratch[512];
DO
IF in.GetBlock[buffer]=0 THEN EXIT;
out.PutBlock[buffer];
ENDLOOP;
RefText.ReleaseScratch[buffer]; };
SetDefaultDomain: PROC [info: Info] = {
hl: LIST OF REF ANY ← info.headers;
fromDomainType, senderDomainType: MTTreeOps.DomainType ← unknown;
fromDomain, senderDomain: REF ANY ← NIL;
WHILE hl # NIL DO
hr: REF HeaderRec ← NARROW[hl.first];
IF hr.fieldType = nameField THEN {
IF Rope.Equal[hr.name, "sender", FALSE] THEN
[senderDomainType, senderDomain] ← MTTreeOps.DefaultDomain[hr.body]
ELSE IF Rope.Equal[hr.name, "from", FALSE] THEN
[fromDomainType, fromDomain] ← MTTreeOps.DefaultDomain[hr.body] };
hl ← hl.rest;
ENDLOOP;
SELECT TRUE FROM
senderDomainType # unknown => {
info.defaultDomainType ← senderDomainType;
info.defaultDomain ← senderDomain; };
fromDomainType # unknown => {
info.defaultDomainType ← fromDomainType;
info.defaultDomain ← fromDomain;}
ENDCASE => {
info.defaultDomainType ← unknown;
info.defaultDomain ← NIL; }; };
ParseHeaders: PUBLIC ENTRY PROC [file, errStream: IO.STREAM] RETURNS [info: Info] = {
headerName, token, whiteSpace, token2: Rope.ROPE;
headerNameOk: BOOL;
Error: PROC [errorMsg: Rope.ROPE] = {
errStream.PutF["Error in parse of %g: %g.\n", IO.rope[headerName], IO.rope[errorMsg]]; };
ParseField: PROC [hr: REF HeaderRec, Input: P1.ScannerProc, what: Rope.ROPE] RETURNS[error: BOOL ← FALSE]~ {
streamIndex: INT ← file.GetIndex[];
badSemantics: BOOL ← FALSE;
nTokens, nErrors: INT;
[nErrors: nErrors, nTokens: nTokens] ← P1.Parse[file, Input];
IF nErrors = 0 THEN
[hr.body, badSemantics] ← P1.GetEvalResult[];
IF nErrors > 0 OR badSemantics THEN {
Error[Rope.Cat["incorrect ", what]];
error ← TRUE;
hr.fieldType ← textField;
file.SetIndex[streamIndex];
hr.body ← Lex822.LexText[file]; }; };
info ← NEW[InfoRec];
info.headers ← NIL;
info.foldLines ← TRUE;
DO
hr: REF HeaderRec;
[headerName, headerNameOk] ← Lex822.LexFieldName[file];
IF headerNameOk AND headerName.IsEmpty[] THEN EXIT;
IF headerNameOk THEN [token, whiteSpace, ] ← Lex822.LexToken[file]
ELSE { token ← whiteSpace ← NIL; Error["Illegal field name"]; };
IF ~headerNameOk OR ~token.Equal[":"] THEN {
IF headerNameOk THEN Error["Field name not followed by colon"];
token2 ← Lex822.LexText[file];
hr ← NEW[HeaderRec ← [
name: NIL, -- Empty name field means don't use colon to print it.
fieldType: textField,
body: Rope.Cat[headerName, whiteSpace, token, token2]]]; }
ELSE {
Everything's wonderful, handle this header.
hr ← NEW[HeaderRec ← [name~headerName, fieldType~TRASH]];
SELECT TRUE FROM
headerName.Equal["date", FALSE] => {
hr.fieldType ← dateField;
[] ← ParseField[hr, P1.ScanDate, "date field"] };
headerName.Equal["cc", FALSE] => {
ccRope: Rope.ROPE;
error: BOOL ← FALSE;
hr.fieldType ← nameField;
error ← ParseField[hr, P1.ScanName, "name list"];
IF hr = NIL THEN LOOP;
IF hr.body = NIL THEN LOOP;
IF ~error THEN {
ccRope ← MTTreeOps.TreeToSimpleRope[hr.body];
IF ccRope = NIL THEN LOOP;
IF Rope.Equal[ccRope, "\n"] THEN LOOP; -- cc fields are not allowed to be empty
};
};
IsNameFieldHeader[headerName] => {
hr.fieldType ← nameField;
[] ← ParseField[hr, P1.ScanName, "name list"] };
ENDCASE => {
r: Rope.ROPE ← Lex822.LexText[file];
hr.fieldType ← textField;
hr.body ← r;
Is this test too slow?
IF hr.name.Equal[lineFold, FALSE] AND r.Find[s2: "no", case: FALSE]>=0 THEN
info.foldLines ← FALSE; }; };
IF hr # NIL THEN info.headers ← List.Nconc1[info.headers, hr];
ENDLOOP;
SetDefaultDomain[info]; };
PrintHeaders: PUBLIC PROC [info: Info, out: IO.STREAM, fold: BOOL ← FALSE] = {
Print the list of headers that ParseHeaders produced. This can also be called after calling TranslateToArpa or TranslateToGrapevine.
hl: LIST OF REF ANY ← info.headers;
WHILE hl # NIL DO
hr: REF HeaderRec ← NARROW[hl.first];
body: Rope.ROPE;
spareStream: IO.STREAM;
IF ~hr.name.IsEmpty[] THEN
out.Put[IO.rope[hr.name], IO.rope[":"]];
IF hr.fieldType = nameField OR hr.fieldType = dateField THEN
body ← MTTreeOps.TreeToRope[tree: hr.body, insertDiscretionaryBlanks: fold]
ELSE body ← NARROW[hr.body];
IF fold THEN {
spareStream ← IO.RIS[body, spareStream];
CopyFolded[in: spareStream, out: out, breakRope: " ", initialLength: hr.name.Length+1]; }
ELSE out.PutRope[body];
hl ← hl.rest;
ENDLOOP; };
xeroxDomain: REF ANY = MTTreeOps.XeroxDomain[];
TranslateToArpa: PUBLIC PROC [info: Info] = {
hl: LIST OF REF ANY ← info.headers;
msgId: BOOL ← FALSE;
FOR hl: LIST OF REF ANY ← info.headers, hl.rest UNTIL hl = NIL DO
hr: REF HeaderRec ← NARROW[hl.first];
IF Rope.Equal[hr.name, msgID, FALSE] THEN msgId ← TRUE;
IF hr.fieldType = nameField THEN
IF info.defaultDomainType = registry THEN
hr.body ← MTTreeOps.ToArpa[hr.body, info.defaultDomainType, info.defaultDomain]
ELSE
Msg from ARPA land gets redistributed to ARPA via a GV DL.
Info extracted from From/Sender field is bogus.
hr.body ← MTTreeOps.ToArpa[hr.body, arpaDomain, xeroxDomain];
ENDLOOP;
IF ~msgId AND info.id # NIL THEN {
hr: REF HeaderRec ← NEW[HeaderRec];
hr^ ← [
name: msgID,
fieldType: textField,
body: IO.PutFR[" <%G@%G>\n", [rope[info.id]], [rope["Xerox"]]] ];
info.headers ← List.Nconc1[info.headers, hr]; }; };
TranslateToGrapevine: PUBLIC PROC [info: Info] = {
hl: LIST OF REF ANY ← info.headers;
WHILE hl # NIL DO
hr: REF HeaderRec ← NARROW[hl.first];
IF hr.fieldType = nameField THEN
hr.body ← MTTreeOps.ToGrapevine[hr.body, info.defaultDomainType, info.defaultDomain];
hl ← hl.rest;
ENDLOOP; };
TranslateMessage: PUBLIC PROC [in, out, error: IO.STREAM, direction: MT.Direction, id: ROPE] = {
Translate a message present on in to out printing error messages on error.
info: Info ← ParseHeaders[in, error];
fold: BOOL;
info.id ← id;
IF direction = toArpa THEN TranslateToArpa[info] ELSE TranslateToGrapevine[info];
PrintHeaders[info, out, direction = toArpa];
fold ← direction = toArpa AND info.foldLines AND ~AlreadyFolded[in];
IF fold THEN CopyFolded[in, out] ELSE CopyNormal[in, out]; };
CheckFromField: PUBLIC PROC [info: Info] RETURNS [ok: BOOL ← TRUE] = {
fromFound: BOOL ← FALSE;
FOR hl: LIST OF REF ANY ← info.headers, hl.rest UNTIL hl = NIL DO
hr: REF HeaderRec ← NARROW[hl.first];
IF hr.fieldType = nameField AND (Rope.Equal[hr.name, "From", FALSE] OR Rope.Equal[hr.name, "Sender", FALSE]) THEN {
rope: Rope.ROPE ← MTTreeOps.TreeToSimpleRope[hr.body];
IF FunnyCharacters[rope] THEN ok ← FALSE;
IF Rope.Equal[hr.name, "From", FALSE] THEN fromFound ← TRUE; }
ENDLOOP;
IF ~fromFound THEN ok ← FALSE; };
FunnyCharacters: PROC [rope: Rope.ROPE] RETURNS [funny: BOOL] =
BEGIN
See MaybeAddQuotes in SMTPSyntaxImpl
length: INT ← Rope.Length[rope];
IF length = 0 THEN RETURN[TRUE];
FOR i: INT IN [0..length) DO
SELECT Rope.Fetch[rope, i] FROM
> 177C => EXIT; -- Funny characters. What should happen to these??
'@, ', => NULL; -- @, and comma
'(, '), '<, '>, '< => NULL;
';, '\\, '", '[, '] => NULL; -- Rest of Specials EXCEPT PERIOD!
': => EXIT; -- Stop NS names from going through
' => NULL; -- Space
'\n => IF i # length-1 THEN EXIT; -- Trailing CR is OK
< 040C => EXIT; -- CTL
ENDCASE => NULL; -- Includes underbar
REPEAT FINISHED => RETURN[FALSE]; -- Nothing fancy inside the string
ENDLOOP;
RETURN[TRUE];
END;
InitParser[];
END.