
<<STPServerImpl.mesa>>
<<Copyright (C) 1984, Xerox Corporation.  All rights reserved.>>
<<Michael Plass, November 5, 1984 10:06:45 am PST>>
<<*** Remember to update the date in heraldMessage when you make changes.>>
<<Last Edited by: Gasbarro, March 8, 1985 11:39:14 am PST>>
<<>>
DIRECTORY
Ascii USING [Digit, Letter],
Atom USING [GetPropFromList, PutPropOnList],
Basics USING [bytesPerWord],
BasicTime USING [GMT, MonthOfYear, Now, nullGMT, Period, Unpack, Unpacked],
Commander USING [CommandProc, Register],
Convert USING [Error, IntFromRope, RopeFromInt],
File USING [GetVolumeName, SystemVolume],
FS USING [Close, ComponentPositions, Delete, EnumerateForInfo, EnumerateForNames, Error, ErrorGroup, ExpandName, GetInfo, GetName, 
OpenFile, OpenFileFromStream, SetByteCountAndCreatedTime, StreamOpen],
FSRemoteFile USING [FTPTimeToGMT],
Graphics USING [Context, SetPaintMode, DrawBox],
GVBasics USING [MakeKey, Password],
GVNames USING [AuthenticateKey, IsMemberClosure],
IconManager USING [selectedIcon],
Icons USING [DrawIcon, IconFileFormat, IconFlavor, IconRef, IconRep, iconH, iconW, NewIcon],
IO USING [Backup, Close, EndOf, EndOfStream, Error, GetBlock, GetChar, GetLength, int, PutBlock, PutChar, PutF, PutRope, refAny, 
RIS, rope, RopeFromROS, ROS, SetIndex, STREAM, UnsafeGetBlock],
List USING [Reverse],
Process USING [MsecToTicks, Pause],
PupDefs USING [GetHostName],
PupStream USING [CloseReason, ConsumeMark, CreatePupByteStreamListener, DestroyPupListener, PupListener, SecondsToTocks, SendMark, 
StreamClosing, TimeOut],
PupTypes USING [ftpSoc, PupAddress],
Real USING [RoundLI],
RefText USING [AppendChar, ObtainScratch, ReleaseScratch],
Rope USING [Cat, Concat, Equal, Fetch, Find, FromRefText, Length, Replace, ROPE, Substr],
RopeFile USING [Create],
RuntimeError USING [UNCAUGHT],
STP USING [ValidProperties],
STPOps USING [markComment, markDelete, markDirectory, markEOC, markHereIsFile, markHereIsPList, markIAmVersion, markNewDirectory, 
markNewStore, markNo, markRetrieve, markStore, markYes],
STPReplyCode USING [ReplyCode],
TypeScript USING [Create],
UserCredentials USING [Get],
ViewerClasses USING [PaintProc, Viewer, ViewerClass, ViewerClassRec],
ViewerIO USING [CreateViewerStreams, GetViewerFromStream],
ViewerOps USING [AddProp, DestroyViewer, FetchProp, FetchViewerClass, PaintViewer];

STPServerImpl: CEDAR MONITOR
IMPORTS Ascii, Atom, BasicTime, Commander, Convert, File, FS, FSRemoteFile, Graphics, GVBasics, GVNames, IconManager, Icons, IO, 
List, Process, PupDefs, PupStream, Real, RefText, Rope, RopeFile, RuntimeError, TypeScript, UserCredentials, ViewerIO, ViewerOps
~ BEGIN

heraldMessage: ROPE _ "Cedar STP Server of March 8, 1985 11:33:16 am PST";

ROPE: TYPE ~ Rope.ROPE;
debugging: BOOLEAN _ FALSE;

UserNameAndPassword: TYPE ~ RECORD [
userName: ROPE,
userPassword: GVBasics.Password
];

oldestAuthenticatedUser: BasicTime.GMT _ BasicTime.nullGMT;
authenticatedUsers: LIST OF UserNameAndPassword;

ValidUser: PROC [userName, password: ROPE, mark: NAT] RETURNS [valid: BOOLEAN _ TRUE] ~ {
ENABLE UNWIND => NULL;
codedPassword: GVBasics.Password _ GVBasics.MakeKey[password];
authenticated: BOOLEAN _ FALSE;
myName, myPassword: ROPE;
myLengthToDot, lengthToDot: INT;
[myName, myPassword] _ UserCredentials.Get[];
lengthToDot _ userName.Find["."];
myLengthToDot _ myName.Find["."];
IF lengthToDot < 0 AND myLengthToDot > 0 THEN {
userName _ userName.Concat[myName.Substr[myLengthToDot]];
<<supply default registry from the logged-in user.>>
};
IF userName.Equal[myName, FALSE] AND password.Equal[myPassword, FALSE] THEN RETURN [TRUE];
<<The currently logged-in user is welcome to do anything.>>
IF authenticatedUsers # NIL AND BasicTime.Period[from: oldestAuthenticatedUser, to: BasicTime.Now[]] > 1800
THEN authenticatedUsers _ NIL;
<<Flush the cache if it is too old.>>
FOR p: LIST OF UserNameAndPassword _ authenticatedUsers, p.rest UNTIL p=NIL DO
IF authenticatedUsers.first.userName.Equal[userName] AND authenticatedUsers.first.userPassword = codedPassword THEN {
authenticated _ TRUE;
<<We've seen this individual before.>>
EXIT;
};
ENDLOOP;
IF NOT authenticated THEN {
IF GVNames.AuthenticateKey[userName, codedPassword] = individual THEN {
<<Not monitored, but at worst we will have to authenticate someone multiple times or get multiple entries in the list.>>
IF authenticatedUsers = NIL THEN oldestAuthenticatedUser _ BasicTime.Now[];
authenticatedUsers _ CONS[[userName, codedPassword], authenticatedUsers];
authenticated _ TRUE;
};
};
IF NOT authenticated THEN RETURN [FALSE];
<<Do not let any unauthenticated users in.>>
IF mark = STPOps.markNewDirectory OR mark = STPOps.markDirectory THEN RETURN [TRUE];
<<Let any authenticated user do a list.>>
IF mark = STPOps.markRetrieve THEN {
friends: ROPE _ NIL;
offset: INT _ 0;
before, after: CHAR _ ' ;
friends _ RopeFile.Create["[]<>STPServer.readAccess" ! FS.Error => CONTINUE];
offset _ Rope.Find[friends, userName, 0, FALSE];
WHILE offset >= 0 DO
IF offset > 0 THEN before _ friends.Fetch[offset-1];
IF offset+userName.Length < friends.Length
THEN after _ friends.Fetch[offset+userName.Length];
IF Ascii.Letter[before] OR Ascii.Digit[before] OR Ascii.Letter[after] OR Ascii.Digit[after]
THEN NULL
ELSE RETURN [TRUE];
offset _ Rope.Find[friends, userName, offset+1, FALSE];
ENDLOOP;
offset _ Rope.Find[friends, "^"];
WHILE offset >= 0 DO
ropeSize: INT ~ Rope.Length[friends];
size: INT _ 0;
UNTIL offset = 0 OR IsDelimiter[Rope.Fetch[friends, offset-1]] DO
offset _ offset-1;
ENDLOOP;
UNTIL offset+size = ropeSize OR IsDelimiter[Rope.Fetch[friends, offset+size]] DO
size _ size + 1;
ENDLOOP;
IF GVNames.IsMemberClosure[Rope.Substr[friends, offset, size], userName] = yes THEN RETURN [TRUE];
offset _ Rope.Find[friends, "^", offset+size];
ENDLOOP;
};
RETURN [FALSE];
};

IsDelimiter: PROC [c: CHAR] RETURNS [BOOL] ~ {
RETURN [SELECT c FROM ' , '\t, ',, '; , '\n => TRUE, ENDCASE => FALSE]
};

HidePassword: PROC [rope: ROPE] RETURNS [ROPE] ~ {
i: INT _ rope.Find["Password ", 0, FALSE];
e: INT _ 0;
IF i >= 0 THEN i _ i + 9;
IF i >= 0 THEN e _ rope.Find[")", i];
IF e > 0 THEN rope _ rope.Replace[i, e-i, Rope.Substr["****************", 0, e-i]];
RETURN [rope]
};

monthName: ARRAY BasicTime.MonthOfYear OF ROPE ~ ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", 
"Dec", "???"];

PutFileDate: PROC [stream: IO.STREAM, date: BasicTime.GMT] ~ {
unpacked: BasicTime.Unpacked _ BasicTime.Unpack[date];
zone: CHAR _ ' ;
IO.PutF[stream, "%2g-%g-%02g ", IO.int[unpacked.day], IO.rope[monthName[unpacked.month]], IO.int[unpacked.year MOD 100]];
IO.PutF[stream, "%2g:%02g:%02g", IO.int[unpacked.hour], IO.int[unpacked.minute], IO.int[unpacked.second]];
zone _ SELECT unpacked.zone/60 FROM
0 => 'G,
5 => 'E,
6 => 'C,
7 => 'M,
8 => 'P,
ENDCASE => ' ;
IF zone # ' THEN {
IO.PutChar[stream, ' ];
IO.PutChar[stream, zone];
IO.PutChar[stream, IF unpacked.dst = yes THEN 'D ELSE 'S];
IO.PutChar[stream, 'T];
};
};

SendPropList: PROC [stream: IO.STREAM, userProps: UserProperties, fullFName: ROPE, created: BasicTime.GMT, bytes: INT] RETURNS 
[refused: BOOL _ FALSE] ~ {
cp: FS.ComponentPositions;
desiredProperty: ARRAY STP.ValidProperties OF BOOLEAN _ userProps.desiredProperty;
desiredProperty[serverName] _ desiredProperty[directory] _ desiredProperty[nameBody] _ desiredProperty[version] _ 
desiredProperty[byteSize] _ TRUE;
[fullFName, cp] _ FS.ExpandName[fullFName];
IO.PutChar[stream, '(];
IF desiredProperty[serverName] THEN {
IO.PutRope[stream, "(Server-Filename <"];
IF cp.dir.length = 0 THEN IO.PutRope[stream, File.GetVolumeName[File.SystemVolume[]]]
ELSE IO.PutRope[stream, fullFName.Substr[cp.dir.start, cp.dir.length]];
IO.PutChar[stream, '>];
IO.PutRope[stream, fullFName.Substr[cp.subDirs.start]];
IO.PutChar[stream, ')];
};
IF desiredProperty[directory] THEN {
IO.PutRope[stream, "(Directory "];
IF cp.dir.length = 0 THEN IO.PutRope[stream, File.GetVolumeName[File.SystemVolume[]]]
ELSE IO.PutRope[stream, fullFName.Substr[cp.dir.start, cp.dir.length]];
IF cp.subDirs.length > 0 THEN IO.PutChar[stream, '>];
IO.PutRope[stream, fullFName.Substr[cp.subDirs.start, cp.subDirs.length]];
IO.PutChar[stream, ')];
};
IF desiredProperty[nameBody] THEN {
IO.PutRope[stream, "(Name-Body "];
IO.PutRope[stream, fullFName.Substr[cp.base.start, cp.ext.start+cp.ext.length-cp.base.start]];
IO.PutChar[stream, ')];
};
IF desiredProperty[version] THEN {
IO.PutRope[stream, "(Version "];
IO.PutRope[stream, fullFName.Substr[cp.ver.start, cp.ver.length]];
IO.PutChar[stream, ')];
};
IF desiredProperty[createDate] THEN {
IO.PutRope[stream, "(Creation-Date "];
PutFileDate[stream, created];
IO.PutChar[stream, ')];
};
IF desiredProperty[byteSize] THEN {
IO.PutRope[stream, "(Byte-Size 8)"];
};
IF desiredProperty[type] THEN {
IO.PutRope[stream, "(Type Binary)"];
};
IF desiredProperty[size] THEN {
IO.PutF[stream, "(Size %g)", IO.int[bytes]];
};
IO.PutChar[stream, ')];
};

RetrieveFile: PROC [stream: IO.STREAM, userProps: UserProperties, fullFName: ROPE, created: BasicTime.GMT, bytes: INT] RETURNS 
[refused: BOOL _ FALSE] ~ {
cs: CommandString;
PupStream.SendMark[stream, STPOps.markHereIsPList];
[] _ SendPropList[stream, userProps, fullFName, created, bytes];
PupStream.SendMark[stream, STPOps.markEOC];
cs _ GetCommandString[stream];
IF cs.mark = STPOps.markYes THEN {
local: IO.STREAM;
expl: ROPE _ NIL;
group: FS.ErrorGroup;
local _ FS.StreamOpen[fullFName, $read, [tiogaRead: FALSE, commitAndReopenTransOnFlush: TRUE, truncatePagesOnClose: TRUE, 
finishTransOnClose: TRUE, closeFSOpenFileOnClose: TRUE] ! FS.Error => {group _ error.group; expl _ error.explanation; CONTINUE}];
IF expl = NIL THEN PupStream.SendMark[stream, STPOps.markHereIsFile];
IF expl = NIL THEN CopyStream[from: local, to: stream, fileByteSize: local.GetLength ! IO.Error => {expl _ "Error while reading 
file"; group _ environment}];
IF expl = NIL THEN local.Close;
IF expl = NIL THEN {
PupStream.SendMark[stream, STPOps.markYes];
IO.PutRope[stream, "\000Transfer complete"];
PupStream.SendMark[stream, STPOps.markEOC];
}
ELSE GenerateFileError[stream, group, expl];
}
ELSE IF cs.mark = STPOps.markNo THEN refused _ TRUE;
};

DeleteFile: PROC [stream: IO.STREAM, userProps: UserProperties, fullFName: ROPE, created: BasicTime.GMT, bytes: INT] RETURNS 
[refused: BOOL _ FALSE] ~ {
cs: CommandString;
PupStream.SendMark[stream, STPOps.markHereIsPList];
[] _ SendPropList[stream, userProps, fullFName, created, bytes];
PupStream.SendMark[stream, STPOps.markEOC];
cs _ GetCommandString[stream];
IF cs.mark = STPOps.markYes THEN {
expl: ROPE _ NIL;
group: FS.ErrorGroup;
FS.Delete[fullFName, created ! FS.Error => {group _ error.group; expl _ error.explanation; CONTINUE}];
IF expl = NIL THEN {
PupStream.SendMark[stream, STPOps.markYes];
IO.PutRope[stream, "\000Deleted"];
PupStream.SendMark[stream, STPOps.markEOC];
}
ELSE GenerateFileError[stream, group, expl];
}
ELSE IF cs.mark = STPOps.markNo THEN refused _ TRUE;
};

FullFNameFromUserProperties: PROC [userProps: UserProperties] RETURNS [fullFName: ROPE] ~ {
IF userProps.serverName # NIL THEN {
sName: ROPE _ userProps.serverName;
IF sName.Length > 0 AND sName.Fetch[0] = '< THEN sName _ Rope.Concat["[]", sName];
fullFName _ FS.ExpandName[sName, Rope.Cat["[]<", userProps.directory, ">"]].fullFName
}
ELSE {
s: IO.STREAM _ IO.ROS[];
dlen: INT _ userProps.directory.Length;
s.PutRope["[]"];
IF dlen = 0 OR userProps.directory.Fetch[0] # '< THEN s.PutChar['<];
s.PutRope[userProps.directory];
IF dlen = 0 OR userProps.directory.Fetch[dlen-1] # '> THEN s.PutChar['>];
s.PutRope[userProps.nameBody];
fullFName _ s.RopeFromROS;
};
};

StoreFile: PROC [stream: IO.STREAM, userProps: UserProperties, cs: CommandString, newStore: BOOLEAN _ TRUE] ~ {
openFile: FS.OpenFile;
local: IO.STREAM _ NIL;
expl: ROPE _ NIL;
group: FS.ErrorGroup;
createByteCount: INT _ 2560;
fullFName: ROPE _ NIL;
GetUserProperties[cs, userProps];
IF NOT ValidUser[userProps.userName, userProps.userPassword, cs.mark] THEN {
No[stream, accessDenied, "Access denied"];
RETURN;
};
fullFName _ FullFNameFromUserProperties[userProps ! FS.Error => {group _ error.group; expl _ error.explanation; CONTINUE}];
createByteCount _ Convert.IntFromRope[userProps.size ! Convert.Error => CONTINUE];
IF fullFName # NIL THEN {
local _ FS.StreamOpen[
fileName: fullFName,
accessOptions: $create,
streamOptions: [tiogaRead: FALSE, commitAndReopenTransOnFlush: TRUE, truncatePagesOnClose: TRUE, finishTransOnClose: TRUE, 
closeFSOpenFileOnClose: FALSE],
keep: 2,
createByteCount: createByteCount
! FS.Error => {group _ error.group; expl _ error.explanation; CONTINUE}
];
IF expl = NIL THEN openFile _ FS.OpenFileFromStream[local ! FS.Error => {group _ error.group; expl _ error.explanation; CONTINUE}];
};
IF expl # NIL THEN {GenerateFileError[stream, group, expl]; RETURN};
IF newStore THEN {
PupStream.SendMark[stream, STPOps.markHereIsPList];
[] _ SendPropList[stream, userProps, fullFName, FS.GetInfo[FS.OpenFileFromStream[local]].created, createByteCount];
PupStream.SendMark[stream, STPOps.markEOC];
}
ELSE {
PupStream.SendMark[stream, STPOps.markYes];
IO.PutRope[stream, "\000Isn't it time you implemented the new store protocol?"];
PupStream.SendMark[stream, STPOps.markEOC];
};
SELECT cs.mark _ PupStream.ConsumeMark[stream] FROM
STPOps.markNo => {cs _ GetCommandString[stream: stream, markConsumed: TRUE, mark: cs.mark]};
STPOps.markHereIsFile => {
created: BasicTime.GMT _ BasicTime.nullGMT;
IF userProps.createdTime # NIL THEN
created _ FSRemoteFile.FTPTimeToGMT[userProps.createdTime ! RuntimeError.UNCAUGHT => CONTINUE];
CopyStream[from: stream, to: local, fileByteSize: createByteCount ! IO.Error => {expl _ "Error while reading file"; group _ 
environment}];
cs _ GetCommandString[stream];
IF cs.mark = STPOps.markYes THEN {
local.Close[ ! IO.Error => {expl _ "Error while reading file"; group _ environment}];
IF created # BasicTime.nullGMT AND expl = NIL THEN {
FS.SetByteCountAndCreatedTime[file: openFile, created: created ! FS.Error => {group _ error.group; expl _ error.explanation; 
CONTINUE}];
};
IF expl = NIL THEN openFile.Close[ ! FS.Error => {group _ error.group; expl _ error.explanation; CONTINUE}];
IF expl # NIL THEN {GenerateFileError[stream, group, expl]; RETURN};
PupStream.SendMark[stream, STPOps.markYes];
IO.PutRope[stream, "\000Transfer Completed"];
PupStream.SendMark[stream, STPOps.markEOC];
}
ELSE IF cs.mark = STPOps.markNo THEN {
openFile: FS.OpenFile _ FS.OpenFileFromStream[local];
name: ROPE _ FS.GetName[openFile].fullFName;
created: BasicTime.GMT _ FS.GetInfo[openFile].created;
local.Close[abort: TRUE ! IO.Error => {expl _ "Error while reading file"; group _ environment}];
FS.Delete[name];
PupStream.SendMark[stream, STPOps.markNo];
IO.PutRope[stream, "\106Store not completed"];
PupStream.SendMark[stream, STPOps.markEOC];
}
ELSE SIGNAL ProtocolError;
};
ENDCASE => SIGNAL ProtocolError;
};

GenerateFileError: PROC [stream: IO.STREAM, group: FS.ErrorGroup, expl: ROPE] ~ {
No[stream, IF group = lock THEN fileBusy ELSE permanentError, expl];
};

No: PROC [stream: IO.STREAM, replyCode: STPReplyCode.ReplyCode, expl: ROPE] ~ {
viewerOut: IO.STREAM _ NARROW[Atom.GetPropFromList[stream.propList, $STPServerViewerStream]];
IF viewerOut # NIL THEN {
viewerOut.PutF["No (%g), %g\n", IO.int[ORD[replyCode]], IO.rope[expl]
! IO.Error => CONTINUE;
];
};
PupStream.SendMark[stream, STPOps.markNo];
IO.PutChar[stream, LOOPHOLE[replyCode]];
IO.PutRope[stream, expl];
PupStream.SendMark[stream, STPOps.markEOC];
};

DoFiles: PROC [stream: IO.STREAM, userProps: UserProperties, cs: CommandString, action: PROC [stream: IO.STREAM, userProps: 
UserProperties, fullFName: ROPE, created: BasicTime.GMT, bytes: INT] RETURNS [refused: BOOL _ FALSE]] ~ {
matches: BOOLEAN _ FALSE;
first: BOOLEAN _ TRUE;
Info: PROC [fullFName, attachedTo: ROPE, created: BasicTime.GMT, bytes: INT, keep: CARDINAL] RETURNS [continue: BOOLEAN _ TRUE] ~ {
refused: BOOLEAN;
IF (first AND cs.mark = STPOps.markNewDirectory) OR cs.mark = STPOps.markDirectory
THEN PupStream.SendMark[stream, STPOps.markHereIsPList];
refused _ action[stream: stream, userProps: userProps, fullFName: fullFName, created: created, bytes: bytes];
IF NOT refused THEN matches _ TRUE;
first _ FALSE;
};
Name: PROC [fullFName: ROPE] RETURNS [continue: BOOLEAN _ TRUE] ~ {
refused: BOOLEAN;
IF (first AND cs.mark = STPOps.markNewDirectory) OR cs.mark = STPOps.markDirectory
THEN PupStream.SendMark[stream, STPOps.markHereIsPList];
refused _ action[stream: stream, userProps: userProps, fullFName: fullFName, created: BasicTime.nullGMT, bytes: 0];
IF NOT refused THEN matches _ TRUE;
first _ FALSE;
};
expl: ROPE _ NIL;
group: FS.ErrorGroup;
pattern: ROPE _ NIL;
GetUserProperties[cs, userProps];
IF NOT ValidUser[userProps.userName, userProps.userPassword, cs.mark] THEN {
No[stream, accessDenied, "Access denied"];
RETURN;
};
IF userProps.version = NIL AND cs.mark = STPOps.markRetrieve THEN {
userProps.version _ "H";
};
pattern _ Rope.Cat[
FullFNameFromUserProperties[userProps !
FS.Error => {expl _ error.explanation; group _ error.group; CONTINUE}
],
IF userProps.version.Length > 0 THEN "!" ELSE NIL,
userProps.version
];
IF expl # NIL THEN {GenerateFileError[stream, group, expl]; RETURN};
IF userProps.desiredProperty[createDate] OR userProps.desiredProperty[size] THEN {
FS.EnumerateForInfo[pattern: pattern, proc: Info !
FS.Error => {expl _ error.explanation; group _ error.group; CONTINUE}
];
}
ELSE {
FS.EnumerateForNames[pattern: pattern, proc: Name !
FS.Error => {expl _ error.explanation; group _ error.group; CONTINUE}
];
};
IF expl # NIL THEN {GenerateFileError[stream, group, expl]; RETURN};
IF matches AND (cs.mark = STPOps.markNewDirectory OR cs.mark = STPOps.markDirectory)
THEN PupStream.SendMark[stream, STPOps.markEOC];
IF NOT matches THEN {
No[stream, fileNotFound, "File not found"];
};
};

RopeFromMark: PROCEDURE [mark: NAT] RETURNS [ROPE] ~ {
RETURN [SELECT mark FROM
STPOps.markRetrieve => "Retrieve",
STPOps.markNewStore => "New-Store",
STPOps.markComment => "Comment",
STPOps.markIAmVersion => "Version",
STPOps.markDirectory => "Enumerate",
STPOps.markNewDirectory => "New-Enumerate",
STPOps.markDelete => "Delete",
STPOps.markYes => "Yes",
STPOps.markNo => "No",
ENDCASE => Convert.RopeFromInt[mark, 8]
]
};

MakeNewServerViewer: PROCEDURE [stream: IO.STREAM, pupAddress: PupTypes.PupAddress] ~ {
otherGuy: Rope.ROPE _ PupDefs.GetHostName[pupAddress];
viewer: ViewerClasses.Viewer _ MakeMyKindOfTypescript[Rope.Concat["STPServer ", otherGuy]];
viewerOut: IO.STREAM _ ViewerIO.CreateViewerStreams[name: viewer.name, viewer: viewer, editedStream: FALSE].out;
userProps: UserProperties _ NEW[UserPropertiesRep];
cs: CommandString;
closing: BOOLEAN _ FALSE;
closeReason: PupStream.CloseReason _ localAbort;
stream.propList _ Atom.PutPropOnList[stream.propList, $STPServerViewerStream, viewerOut];
BEGIN
ENABLE {
PupStream.StreamClosing => {closeReason _ why; closing _ TRUE; GOTO Exit};
PupStream.TimeOut => {closeReason _ transmissionTimeout; closing _ TRUE; GOTO Exit};
RuntimeError.UNCAUGHT => IF NOT debugging THEN {closeReason _ localAbort; GOTO Exit};
ABORTED => {closeReason _ localAbort; GOTO Exit};
};
AwaitCallingMessage[stream];
IF NOT closing THEN SendHerald[stream];
UNTIL closing OR ViewerIO.GetViewerFromStream[viewerOut].destroyed DO
ok: BOOLEAN _ TRUE;
cs _ GetCommandString[stream];
SELECT cs.mark FROM
STPOps.markDirectory => DoFiles[stream, userProps, cs, SendPropList];
STPOps.markNewDirectory => DoFiles[stream, userProps, cs, SendPropList];
STPOps.markRetrieve => DoFiles[stream, userProps, cs, RetrieveFile];
STPOps.markStore => StoreFile[stream, userProps, cs, FALSE];
STPOps.markNewStore => StoreFile[stream, userProps, cs];
STPOps.markDelete => DoFiles[stream, userProps, cs, DeleteFile];
STPOps.markComment => NULL;
ENDCASE => No[stream, STPReplyCode.ReplyCode.badCommand, "Command undefined or unimplemented"];
ENDLOOP;
EXITS Exit => NULL;
END;
viewerOut.PutF["\nClosing %g\n", IO.refAny[NEW[PupStream.CloseReason _ closeReason]] ! IO.Error => CONTINUE];
stream.Close[ ! IO.Error => CONTINUE];
Process.Pause[Process.MsecToTicks[1500]];
IF viewer.iconic AND NOT debugging THEN ViewerOps.DestroyViewer[viewer];
};

CommandString: TYPE ~ RECORD [
mark: NAT _ 0,
string: ROPE _ NIL
];

UserProperties: TYPE ~ REF UserPropertiesRep;
UserPropertiesRep: TYPE ~ RECORD [
userName: ROPE _ NIL,
userPassword: ROPE _ NIL,
directory: ROPE _ NIL,
nameBody: ROPE _ NIL,
serverName: ROPE _ NIL,
version: ROPE _ NIL,
createdTime: ROPE _ NIL,
size: ROPE _ NIL,
desiredProperty: ARRAY STP.ValidProperties OF BOOLEAN _ ALL[FALSE]
];

GetCommandString: PROC [stream: IO.STREAM, markConsumed: BOOL _ FALSE, mark: NAT _ 0] RETURNS [cs: CommandString] ~ {
<<may raise PupStream.StreamClosing, PupStream.TimeOut>>
isMark: BOOLEAN _ FALSE;
char: CHAR _ '?;
closed: BOOLEAN _ FALSE;
text: REF TEXT _ RefText.ObtainScratch[100];
GetChar: PROC ~ {
ok: BOOLEAN _ TRUE;
char _ '?;
isMark _ FALSE;
char _ stream.GetChar[ !
IO.Error => {closed _ TRUE; CONTINUE};
IO.EndOfStream => {
isMark _ TRUE;
CONTINUE
};
];
};
GetTextToMark: PROC ~ {
text.length _ 0;
GetChar[];
UNTIL isMark OR closed DO
text _ RefText.AppendChar[text, char];
GetChar[];
ENDLOOP;
};
viewerOut: IO.STREAM _ NARROW[Atom.GetPropFromList[stream.propList, $STPServerViewerStream]];
cs.string _ NIL;
IF markConsumed THEN {
cs.mark _ mark;
}
ELSE {
cs.mark _ 0;
GetTextToMark[];
IF text.length # 0 THEN SIGNAL ProtocolError;
IF closed THEN RETURN;
cs.mark _ PupStream.ConsumeMark[stream];
};
GetTextToMark[];
cs.string _ Rope.FromRefText[text];
RefText.ReleaseScratch[text];
{t: NAT _ PupStream.ConsumeMark[stream];
IF t#STPOps.markEOC THEN SIGNAL ProtocolError
};
IF viewerOut # NIL THEN {
viewerOut.PutF["\n%g %g\n", IO.rope[RopeFromMark[cs.mark]], IO.rope[HidePassword[cs.string]] ! IO.Error => CONTINUE];
};
};

ProtocolError: SIGNAL ~ CODE;

AwaitCallingMessage: PROC [stream: IO.STREAM] ~ {
cs: CommandString _ GetCommandString[stream];
WHILE cs.mark # STPOps.markIAmVersion DO
SIGNAL ProtocolError;
cs _ GetCommandString[stream];
ENDLOOP;
};

SendHerald: PROC [stream: IO.STREAM] ~ {
PupStream.SendMark[stream, STPOps.markIAmVersion];
IO.PutChar[stream, VAL[1]];
IO.PutRope[stream, heraldMessage];
PupStream.SendMark[stream, STPOps.markEOC];
};

NarrowToList: PROC [lisp: REF] RETURNS [LIST OF REF _ NIL] ~ {
IF lisp = NIL THEN RETURN [NIL]
ELSE WITH lisp SELECT FROM
list: LIST OF REF => RETURN [list];
ENDCASE => SIGNAL ProtocolError;
};

NarrowToRope: PROC [lisp: REF] RETURNS [ROPE _ NIL] ~ {
IF lisp = NIL THEN RETURN [NIL]
ELSE WITH lisp SELECT FROM
rope: ROPE => RETURN [rope];
ENDCASE => SIGNAL ProtocolError;
};

propertyNames: ARRAY STP.ValidProperties OF ROPE ~ [
userName: "User-Name",
userPassword: "User-Password",
connectName: "Connect-Name",
connectPassword: "Connect-Password",
byteSize: "Byte-Size",
type: "Type",
size: "Size",
directory: "Directory",
nameBody: "Name-Body",
version: "Version",
createDate: "Creation-Date",
readDate: "Read-Date",
writeDate: "Write-Date",
author: "Author",
eolConversion: "End-of-Line-Convention",
account: "Account",
userAccount: "User-Account",
device: "Device",
serverName: "Server-Filename"
];

ValidPropertyFromRope: PROC [propName: ROPE] RETURNS [prop: STP.ValidProperties _ userName] ~ {
Match: PROC [rope: ROPE] RETURNS [BOOL] ~ {RETURN [propName.Equal[rope, FALSE]]};
FOR p: STP.ValidProperties IN STP.ValidProperties DO
IF propName.Equal[propertyNames[p], FALSE] THEN RETURN [p];
ENDLOOP;
SIGNAL ProtocolError;
};

GetUserProperties: PROC [cs: CommandString, userProperties: UserProperties] ~ {
stream: IO.STREAM _ IO.RIS[cs.string];
lisp: REF;
userProperties.directory _ NIL;
userProperties.nameBody _ NIL;
userProperties.serverName _ NIL;
userProperties.version _ NIL;
userProperties.size _ NIL;
userProperties.createdTime _ NIL;
lisp _ ParseLisp[stream ! IO.Error, IO.EndOfStream => {SIGNAL ProtocolError; CONTINUE}];
IF NOT stream.EndOf THEN SIGNAL ProtocolError;
FOR p: LIST OF REF _ NarrowToList[lisp], p.rest UNTIL p = NIL DO
q: LIST OF REF _ NarrowToList[p.first];
IF q = NIL OR q.rest = NIL THEN SIGNAL ProtocolError;
WITH q.first SELECT FROM
key: ROPE => {
arg: ROPE _ NarrowToRope[q.rest.first];
IF key.Equal["Desired-property", FALSE] THEN {
prop: STP.ValidProperties _ ValidPropertyFromRope[arg];
userProperties.desiredProperty[prop] _ TRUE;
}
ELSE {
prop: STP.ValidProperties _ ValidPropertyFromRope[key];
SELECT prop FROM
userName => userProperties.userName _ arg;
userPassword => userProperties.userPassword _ arg;
connectName => NULL;
connectPassword => NULL;
byteSize => NULL;
type => NULL;
size => userProperties.size _ arg;
directory => userProperties.directory _ arg;
nameBody => userProperties.nameBody _ arg;
version => userProperties.version _ arg;
createDate => {
userProperties.createdTime _ arg;
<<This hack required because the time may contain embedded spaces>>
FOR t: LIST OF REF _ q.rest.rest, t.rest UNTIL t = NIL DO
r: ROPE _ NarrowToRope[t.first];
userProperties.createdTime _ userProperties.createdTime.Cat[" ", r];
ENDLOOP;
};
readDate => NULL;
writeDate => NULL;
author => NULL;
eolConversion => NULL;
account => NULL;
userAccount => NULL;
device => NULL;
serverName => userProperties.serverName _ arg;
ENDCASE => NULL;
};
};
ENDCASE => SIGNAL ProtocolError;
ENDLOOP;
};

ParseLisp: PROC [stream: IO.STREAM] RETURNS [ref: REF ANY _ NIL] ~ {
char: CHAR _ IO.GetChar[stream];
WHILE char = '  DO char _ IO.GetChar[stream] ENDLOOP;
IF char # '( THEN {
text: REF TEXT _ RefText.ObtainScratch[100];
nextUpper: BOOLEAN _ TRUE;
text.length _ 0;
WHILE char # '  AND char # '( AND char # ') DO
IF char = '\' -- single quote -- THEN {
char _ IO.GetChar[stream];
};
text _ RefText.AppendChar[text, char];
char _ IO.GetChar[stream];
ENDLOOP;
ref _ Rope.FromRefText[text];
RefText.ReleaseScratch[text];
stream.Backup[char];
}
ELSE {
list: LIST OF REF ANY _ NIL;
char _ IO.GetChar[stream];
WHILE char = '  DO char _ IO.GetChar[stream] ENDLOOP;
WHILE char # ') DO
stream.Backup[char];
list _ CONS[ParseLisp[stream], list];
char _ IO.GetChar[stream];
ENDLOOP;
ref _ List.Reverse[list];
};
};

CopyStream: PROCEDURE [from, to: IO.STREAM, fileByteSize: INT] ~ {
text: REF TEXT _ RefText.ObtainScratch[512];
viewer: ViewerClasses.Viewer _ FindMyViewer[from, to];
toGo: INT _ fileByteSize;
WHILE IO.GetBlock[from, text, 0] > 0 DO
IF viewer # NIL THEN SetPieFraction[viewer, REAL[toGo]/MAX[fileByteSize, 1]];
IO.PutBlock[to, text];
toGo _ toGo - text.length;
ENDLOOP;
IF viewer # NIL THEN SetPieFraction[viewer, REAL[toGo]/MAX[fileByteSize, 1]];
RefText.ReleaseScratch[text];
};

ftpListener: PupStream.PupListener _ NIL;

STPServerCommand: Commander.CommandProc ~ {
op: {start, stop};
IF Rope.Find[cmd.commandLine, "start", 0, FALSE] >= 0 THEN op _ start
ELSE IF Rope.Find[cmd.commandLine, "stop", 0, FALSE] >= 0 THEN op _ stop
ELSE IF ftpListener = NIL THEN op _ start
ELSE op _ stop;
IF op = start THEN {
ftpListener _ PupStream.CreatePupByteStreamListener[
local: PupTypes.ftpSoc,
proc: MakeNewServerViewer,
ticks: PupStream.SecondsToTocks[60]
];
cmd.out.PutRope["STP Server Started\n"];
}
ELSE {
IF ftpListener # NIL THEN {
PupStream.DestroyPupListener[ftpListener];
ftpListener _ NIL;
};
cmd.out.PutRope["STP Server Stopped\n"];
};
};

MakeMyKindOfTypescript: PROC [name: ROPE] RETURNS [viewer: ViewerClasses.Viewer] ~ {
viewer _ TypeScript.Create[info: [name: name, iconic: TRUE], paint: FALSE];
ViewerOps.AddProp[viewer, $PieData, NEW[PieDataRep _ [iconNumber: maxIcon]]];
viewer.icon _ private;
viewer.class _ fakeTypescriptClass;
ViewerOps.PaintViewer[viewer, all, TRUE];
};

FindMyViewer: PROCEDURE [from, to: IO.STREAM] RETURNS [viewer: ViewerClasses.Viewer _ NIL] ~ {
viewerStream: IO.STREAM _ NARROW[Atom.GetPropFromList[from.propList, $STPServerViewerStream]];
IF viewerStream = NIL THEN viewerStream _ NARROW[Atom.GetPropFromList[to.propList, $STPServerViewerStream]];
IF viewerStream # NIL THEN viewer _ ViewerIO.GetViewerFromStream[viewerStream];
};

PieData: TYPE ~ REF PieDataRep;
PieDataRep: TYPE ~ RECORD [
iconNumber: INT
];

maxIcon: NAT _ 19;

SetPieFraction: PROC [self: ViewerClasses.Viewer, fraction: REAL] ~ {
iconNumber: INT _ Real.RoundLI[MAX[MIN[fraction, 1.0], 0.0]*maxIcon];
old: INT _ -1;
IF iconNumber = 0 AND fraction>0 THEN iconNumber _ 1;
WITH ViewerOps.FetchProp[self, $PieData] SELECT FROM
pieData: PieData => {
old _ pieData.iconNumber;
pieData.iconNumber _ iconNumber;
};
ENDCASE => NULL;
IF iconNumber # old AND self.iconic THEN {
ViewerOps.PaintViewer[self, all, FALSE];
};
};

MyPaint: ViewerClasses.PaintProc ~ {
IF self.iconic THEN {
iconNumber: INT _ maxIcon;
WITH ViewerOps.FetchProp[self, $PieData] SELECT FROM
pieData: PieData => {
iconNumber _ pieData.iconNumber;
};
ENDCASE => NULL;
MyPaintIcon[context, iconNumber, self.name];
IF IconManager.selectedIcon = self THEN {
[] _ Graphics.SetPaintMode[context, invert];
Graphics.DrawBox[context, [0, 0, Icons.iconW, Icons.iconH]];
};
}
ELSE typescriptPaint[self, context, whatChanged, clear];
};

iconStream: IO.STREAM _ NIL;

myIconRef: Icons.IconRef _ NEW[Icons.IconRep];
myIconFlavor: Icons.IconFlavor _ Icons.NewIcon[myIconRef];

MyPaintIcon: ENTRY PROC [context: Graphics.Context, iconNumber: INT, name: ROPE] ~ TRUSTED {
ENABLE {UNWIND => NULL; RuntimeError.UNCAUGHT => CONTINUE};
bytes: INT _ SIZE[Icons.IconFileFormat]*Basics.bytesPerWord;
block: Icons.IconFileFormat;
base: LONG POINTER _ @block;
iconStream.SetIndex[iconNumber*bytes];
[] _ iconStream.UnsafeGetBlock[[base: base, startIndex: 0, count: bytes]];
myIconRef.bits _ block.bits;
myIconRef.label _ block.label;
myIconRef.invertLabel _ block.invertLabel;
myIconRef.lx _ block.lx;
myIconRef.ly _ block.ly;
myIconRef.lw _ block.lw;
myIconRef.lh _ block.lh;
Icons.DrawIcon[myIconFlavor, context, 0, 0, name];
};

fakeTypescriptClass: ViewerClasses.ViewerClass _ NIL;
<<This bletch is because ViewerIO insists that viewer.class.flavor = $Typescript>>
typescriptPaint: ViewerClasses.PaintProc _ NIL;

iconFileName: ROPE _ "STPServer.icons";

Init: PROC ~ {
fakeTypescriptClass _ NEW[ViewerClasses.ViewerClassRec _ ViewerOps.FetchViewerClass[$Typescript]^];
typescriptPaint _ fakeTypescriptClass.paint;
fakeTypescriptClass.paint _ MyPaint;
iconStream _ FS.StreamOpen[
fileName: iconFileName,
accessOptions: $read,
streamOptions: [
tiogaRead: FALSE,
commitAndReopenTransOnFlush: TRUE,
truncatePagesOnClose: FALSE,
finishTransOnClose: TRUE,
closeFSOpenFileOnClose: TRUE
],
streamBufferParms: [vmPagesPerBuffer: 2, nBuffers: 1]
];
Commander.Register["STPServer", STPServerCommand, "STPServer [ start | stop ]\n[]<>STPServer.readAccess should have list of 
permissible readers"];
};

Init[];

END.