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
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"];
};
END.