
<<File: PeanutRetrieveParseImpl.mesa>>

DIRECTORY
GVMailParse,
List USING [Append, Reverse],
Rope,
PeanutParse,
PeanutRetrieve,
PeanutSendMail;

PeanutRetrieveParseImpl: CEDAR PROGRAM
IMPORTS
GVMailParse, List, Rope, PeanutParse, PeanutSendMail
EXPORTS
PeanutRetrieve =

BEGIN OPEN GVMailParse, PeanutParse;

<<Global variables>>

ROPE: TYPE = Rope.ROPE;

<<turn the fullText into records>>

ParseMsgIntoFields: PUBLIC PROC[msg: PeanutRetrieve.MsgRec]
RETURNS[s: PeanutParse.ParseStatus, sPos, mPos: INT] =
BEGIN
mLF: MessageInfo;
msgText: ROPE_ msg.fullText;
msgLen: INT;
lastCharPos: INT_ msgText.Length[] - 1;
originName: Name = NEW[NameRecord];
originQual: Qualification;
originIndex:  MessageFieldIndex_ replyToF; -- anything except sender or from
whichRegistry: ROPE_ PeanutSendMail.defaultRegistry;
localRegistry: ROPE_ PeanutSendMail.defaultRegistry;

DetermineQualification: PROCEDURE [name: Name] RETURNS [Qualification] =
BEGIN
RETURN[
SELECT TRUE FROM
name.arpaHost.Length[] > 0 => arpaQualified,
name.registry.Length[] > 0 => dotQualified,
ENDCASE => unqualified]
END; -- of DetermineQualification --

AnalyzeOrigin: PROCEDURE [index: MessageFieldIndex] =
BEGIN
ProcessName: PROCEDURE [
simpleName, registry, arpaHost: ROPE, ignored: GVMailParse.NameInfo]
RETURNS [accept: BOOLEAN] =
BEGIN
IF ~(originIndex = senderF OR index = originIndex OR index = replyToF) THEN
BEGIN
originIndex _ index;
originName.simpleName_ simpleName;
originName.registry_ registry;
originName.arpaHost_ arpaHost;
SELECT originQual_ DetermineQualification[originName] FROM
unqualified => {originName.registry_ whichRegistry; originQual_ dotQualified};
dotQualified => whichRegistry_ originName.registry;
arpaQualified => IF LocalArpaSite[arpaHost] THEN
IF registry.Length[] = 0 THEN
{ originName.registry_ localRegistry; originName.arpaHost_ NIL;
originQual_ dotQualified};
ENDCASE;
END;
RETURN[FALSE]
END; -- of ProcessName --

GVMailParse.ParseNameList[pH, ProcessName ! ParseError => CONTINUE];
END; -- of AnalyzeOrigin --

GetOrigin: PROCEDURE [index: MessageFieldIndex] =
BEGIN
SELECT index FROM
senderF => AnalyzeOrigin[index];
fromF => IF originIndex # senderF THEN AnalyzeOrigin[index]
ELSE []_ GVMailParse.GetFieldBody[pH];
ENDCASE => []_ GVMailParse.GetFieldBody[pH];
RETURN
END; -- of GetOrigin --

AdjustToSenderContext: PROC[name: Name] RETURNS [qual: Qualification] =
BEGIN
SELECT qual _ DetermineQualification[name] FROM
unqualified =>
SELECT originQual FROM
dotQualified => {name.registry_ originName.registry; qual_ dotQualified};
arpaQualified =>
{name.arpaHost_ originName.arpaHost; qual_ arpaQualified};
ENDCASE;
<<dotQualified => EXIT;>>
arpaQualified =>
IF LocalArpaSite[name.arpaHost] AND name.registry.Length[] = 0 THEN
{name.registry_ localRegistry; qual_ dotQualified};

ENDCASE;
END; -- of AdjustToSenderContext --

tHeaders: LIST OF ROPE_ NIL;
GetNextMsgChar: PROC[] RETURNS [ch: CHAR] =
{ IF mPos > lastCharPos THEN ch_ endOfInput ELSE ch_  Rope.Fetch[msgText, mPos];
mPos_ mPos + 1;
};
BackupMsgChar: PROC[] = {mPos_ mPos - 1};

SimpleField: PROC[index: MessageFieldIndex, fieldBody: ROPE] =
BEGIN
SELECT index FROM
senderF => 
BEGIN
SELECT originQual FROM
dotQualified => msg.inMsgSender_
Rope.Cat[originName.simpleName, ".", originName.registry];
arpaQualified =>
{ IF originName.registry.Length[] # 0
THEN fieldBody_ Rope.Cat[originName.simpleName, ".", originName.registry];
msg.inMsgSender_ Rope.Cat[fieldBody, "@", originName.arpaHost];
};
ENDCASE;
END;
replyToF => msg.replyTo_ fieldBody;
fromF => msg.from_ fieldBody;
dateF => msg.date_ fieldBody;
subjectF => msg.subject_ fieldBody;
inReplyToF => msg.inReplyTo_ fieldBody;
ENDCASE => ERROR;
END;

RNameListField: PROC[index: MessageFieldIndex] =
BEGIN
fieldBody: LIST OF ROPE_ NIL;
whereWeStarted: INT_ mPos;
sawBadNameList: BOOL_ FALSE;
AnotherRName: PROC[r1, r2, r3: ROPE, n: NameInfo] RETURNS [BOOLEAN] =
BEGIN
name: Name_ NEW[NameRecord_ [r1, r2, r3]];
qual: Qualification;
SELECT n.type FROM
normal, publicDL =>
{ IF index = originIndex THEN {qual_ originQual; name_ originName}
ELSE qual_ AdjustToSenderContext[name];
IF qual = arpaQualified THEN
{ IF name.registry.Length[] # 0 THEN r1_ Rope.Cat[r1, ".", name.registry];
r1_ Rope.Cat[r1, "@", name.arpaHost]}
ELSE r1_ Rope.Cat[r1, ".", name.registry]};
ENDCASE;
fieldBody_ CONS[r1, fieldBody];
RETURN[FALSE]; 
END;

ParseNameList[pH, AnotherRName, NIL, TRUE ! ParseError =>
{sawBadNameList_ TRUE; CONTINUE}];
IF sawBadNameList THEN
{ mPos_ whereWeStarted; fieldBody_ CONS[GetFieldBody[pH], NIL]}
ELSE TRUSTED {fieldBody_ LOOPHOLE[List.Reverse[LOOPHOLE[fieldBody]]]};
SELECT index  FROM
toF => IF msg.to = NIL THEN msg.to_ fieldBody
ELSE IF fieldBody#NIL THEN
TRUSTED
{msg.to_ LOOPHOLE[List.Append[LOOPHOLE[msg.to], LOOPHOLE[fieldBody]]]};
ccF, cF, bccF => IF msg.cc = NIL THEN msg.cc_ fieldBody
ELSE IF fieldBody#NIL THEN
TRUSTED
{msg.cc_ LOOPHOLE[List.Append[LOOPHOLE[msg.cc], LOOPHOLE[fieldBody]]]};
ENDCASE => ERROR;
END;

pH: ParseHandle_ InitializeParse[next: GetNextMsgChar, backup: BackupMsgChar];
field: ROPE_ NIL;
fieldNotRecognized: BOOL_ FALSE;
s_ ok;        -- good status
mPos_ 0;        -- where we are in the text

DO            -- analyze from or sender field
sPos_ mPos;
[fieldNotRecognized, field]_ GetFieldName[pH ! ParseError =>
{ FinalizeParse[pH]; GOTO parseErrorExit}];
IF ~fieldNotRecognized THEN EXIT;
FOR i: MessageFieldIndex IN MessageFieldIndex DO
IF Rope.Equal[field, messageParseArray[i].name, FALSE] THEN {GetOrigin[i]; EXIT};
REPEAT FINISHED => []_ GetFieldBody[pH];
ENDLOOP;
ENDLOOP;

mPos_ 0;
DO
sPos_ mPos;
[fieldNotRecognized, field]_ GetFieldName[pH];        -- can't get ParseError this time
IF ~fieldNotRecognized THEN EXIT;
FOR i: MessageFieldIndex IN MessageFieldIndex DO
{ mLF_ messageParseArray[i];
IF Rope.Equal[mLF.name, field, FALSE] THEN    -- ignore case
{ fieldNotRecognized_ FALSE;
SELECT mLF.fType FROM
simpleRope => SimpleField[i, GetFieldBody[pH]];
rCatList => msg.categories_ CategoriesField[GetFieldBody[pH]];
rNameList => RNameListField[i];
ENDCASE =>    ERROR;
EXIT
};
};
ENDLOOP;
IF fieldNotRecognized THEN
{ []_ GetFieldBody[pH];    -- anything not recognized
tHeaders _ CONS[Rope.Substr[msgText, sPos, mPos-sPos-1], tHeaders]
};
ENDLOOP;

<<now we are positioned at the beginning of the body of the message>>
FinalizeParse[pH];
IF tHeaders # NIL THEN
TRUSTED {msg.unrecognized_ LOOPHOLE[List.Reverse[LOOPHOLE[tHeaders]]]};
IF ((msgLen_ msgText.Length[])-mPos) < 0 THEN
msg.bodyText_ ""
ELSE msg.bodyText_ Rope.Substr[msgText, mPos, msgLen];
EXITS
parseErrorExit => RETURN[syntaxError, sPos, mPos];
END;

CategoriesField: PROC[fB: ROPE] RETURNS [LIST OF ROPE] =
BEGIN
end: INT_ fB.Length[];
p: INT_ Rope.SkipOver[fB, 0, " \n"];
r: ROPE;
IF p # end THEN r_ Rope.Substr[fB, p, end-p+1] ELSE {r_ fB; p_ 0};

IF (p_ Rope.Find[fB, "',", p]) < 0 THEN RETURN[CONS[r, NIL]]
ELSE RETURN[CONS[r, CategoriesField[Rope.Substr[r, p+1, end-p]]]];
END;

END.