-- Copyright (C) 1981, 1982, 1983, 1984, 1985  by Xerox Corporation. All rights reserved. 
-- Grapevine:  FTP server using VMDefs
-- FTPServer.mesa, HGM, 16-Sep-85 22:07:59

-- Randy Gobbel		 9-Jul-82 13:48:05 --
-- Andrew Birrell	17-Mar-81 14:46:23 --
-- Mark Johnson		21-Jan-82 15:34:28 --
-- Brenda Hankins	23-Aug-84 11:03:21	change TimeExtraDefs to TimeExtra

DIRECTORY
  BodyDefs USING [maxRNameLength, RName],
  FTPDefs,
  Heap USING [systemZone],
  LogDefs USING [WriteLogEntry],
  MFile USING [
    Acquire, dontRelease, EnumerateDirectory, EnumerateProc, Error, Handle,
    maxNameLength, Release, Rename],
  NameInfoDefs USING [
    Authenticate, AuthenticateInfo, IsMemberClosure, Membership],
  PolicyDefs USING [CheckOperation, EndOperation],
  PupDefs USING [AppendMyName, ParsePupAddressConstant, PupAddress],
  String USING [AppendChar, AppendNumber, AppendString, EquivalentStrings],
  Time USING [Append, Packed, Unpack],
  TimeExtra USING [PackedTimeFromString],
  VMDefs USING [
    AbandonFile, CantOpen, CantReadBackingStore, CantWriteBackingStore, CloseFile,
    DestroyFile, Error, FileHandle, FileTime, GetFileLength, GetFileTimes,
    MarkStart, OpenFile, Page, pageSize, Position, ReadPage, Release,
    SetCreationTime, SetFileLength, UsePage, WaitFile];

FTPServer: PROGRAM
  IMPORTS
    FTPDefs, Heap, LogDefs, MFile, NameInfoDefs, PolicyDefs, PupDefs, String,
    Time, TimeExtra, VMDefs =

  BEGIN

  WhoIsHe: SIGNAL RETURNS [net, host: [0..256)] = CODE;
  --communication between LogAction and Backstop --

  LogAction: PROC [
    user: BodyDefs.RName, file: LONG STRING, action: {read, write, rename, delete}] =
    BEGIN
    log: LONG STRING ¬ Heap.systemZone.NEW[StringBody[128]];
    String.AppendString[log, "FTP server: "L];
    BEGIN
    net, host: [0..256);
    [net, host] ¬ SIGNAL WhoIsHe;
    String.AppendNumber[log, net, 8];
    String.AppendChar[log, '#];
    String.AppendNumber[log, host, 8];
    String.AppendChar[log, '#];
    END;
    String.AppendChar[log, ' ];
    String.AppendString[log, user];
    String.AppendString[
      log,
      SELECT action FROM
        read => " reading "L,
        write => " writing "L,
        rename => " renaming "L,
        delete => " deleting "L
        ENDCASE => ERROR];
    String.AppendString[log, file];
    LogDefs.WriteLogEntry[log];
    Heap.systemZone.FREE[@log];
    END;

  MyCreate: PROC [bufferSize: CARDINAL] RETURNS [fileSystem: FTPDefs.FileSystem] =
    BEGIN
    real: BodyDefs.RName = Heap.systemZone.NEW[StringBody[BodyDefs.maxRNameLength]];
    RETURN[LOOPHOLE[real]];
    END;

  MyDestroy: PROC [fileSystem: FTPDefs.FileSystem] = {Heap.systemZone.FREE[@fileSystem]};

  MyDecompose: PROC [
    fileSystem: FTPDefs.FileSystem, absoluteFilename: STRING,
    virtualFilename: FTPDefs.VirtualFilename] =
    BEGIN
    virtualFilename.device.length ¬ 0;
    virtualFilename.directory.length ¬ 0;
    virtualFilename.name.length ¬ 0;
    String.AppendString[virtualFilename.name, absoluteFilename];
    virtualFilename.version.length ¬ 0;
    END;

  MyCompose: PROC [
    fileSystem: FTPDefs.FileSystem, absoluteFilename: STRING,
    virtualFilename: FTPDefs.VirtualFilename] =
    BEGIN
    IF virtualFilename.device.length = 0 AND virtualFilename.directory.length = 0
      AND virtualFilename.name.length = 0 AND virtualFilename.version.length = 0
      THEN NULL  -- that's what the spec says! --
    ELSE
      BEGIN
      absoluteFilename.length ¬ 0;
      String.AppendString[absoluteFilename, virtualFilename.name];
      END;
    END;

  DefaultReg: PROC [name: BodyDefs.RName] =
    BEGIN
    default: STRING = ".pa"L;
    FOR i: CARDINAL DECREASING IN [0..name.length) DO
      IF name[i] = '. THEN EXIT;
      REPEAT
        FINISHED =>
          IF name.length + default.length <= name.maxlength THEN
            String.AppendString[name, default];
      ENDLOOP;
    END;

  MyInspectCredentials: PROC [
    fileSystem: FTPDefs.FileSystem, status: FTPDefs.Status,
    user, password: STRING] =
    BEGIN
    real: BodyDefs.RName = LOOPHOLE[fileSystem];
    IF status = primary THEN
      BEGIN
      outcome: NameInfoDefs.AuthenticateInfo;
      IF user = NIL OR user.length > BodyDefs.maxRNameLength THEN {
        real.length ¬ 0; outcome ¬ notFound}
      ELSE
        BEGIN
        IF password = NIL THEN outcome ¬ badPwd
        ELSE
          BEGIN
          real.length ¬ 0;
          String.AppendString[real, user];
          DefaultReg[real];
          outcome ¬ NameInfoDefs.Authenticate[real, password];
          END;
        END;
      IF outcome # individual THEN
        BEGIN
        error: FTPDefs.FtpError =
          SELECT outcome FROM
            notFound, group => noSuchPrimaryUser,
            badPwd => incorrectPrimaryPassword,
            allDown => unidentifiedTransientError,
            ENDCASE => ERROR;
        string: STRING =
          SELECT outcome FROM
            notFound => "Incorrect registry or user name"L,
            group => "Can't login as a group"L,
            badPwd => "Incorrect password"L,
            allDown => "Can't reach any authentication server",
            ENDCASE => ERROR;
        real.length ¬ 0;
        ERROR FTPDefs.FTPError[error, string];
        END;
      END;
    END;

  CheckAccess: PROC [
    user: BodyDefs.RName, why: {list, read, write}, file: STRING] =
    BEGIN
    info: NameInfoDefs.Membership ¬ no;
    IF user = NIL OR user.length = 0 THEN
      ERROR FTPDefs.FTPError[credentialsMissing, "No valid user/password given"L];
    IF why # list AND String.EquivalentStrings[file, "Heap.data"L] THEN
      FTPDefs.FTPError[requestedAccessDenied, "'Heap.data' is private!"L];
    IF (why = list OR why = read) AND String.EquivalentStrings[file, "GV.log"L] THEN
      info ¬ NameInfoDefs.IsMemberClosure["LogReaders^.ms"L, user];
    IF info # yes THEN
      info ¬ NameInfoDefs.IsMemberClosure["Transport^.ms"L, user];
    SELECT info FROM
      yes => NULL;
      no, notGroup =>
        ERROR FTPDefs.FTPError[
          requestedAccessDenied, "You're not allowed access to this server"L];
      allDown =>
        ERROR FTPDefs.FTPError[
          requestedAccessDenied, "Can't contact access control server"L];
      ENDCASE => ERROR;
    END;

  OpenVMFile: PROC [file: STRING, action: {read, write, delete, enumerate}]
    RETURNS [handle: VMDefs.FileHandle] =
    BEGIN
    ENABLE
      VMDefs.CantOpen =>
        SELECT reason FROM
          notFound => ERROR FTPDefs.FTPError[noSuchFile, "File does not exist"L];
          alreadyExists =>
            ERROR FTPDefs.FTPError[fileAlreadyExists, "File already exists"L];
          accessDenied =>
            ERROR FTPDefs.FTPError[
              requestedAccessDenied, "File not available at present"L];
          illegalFileName =>
            ERROR FTPDefs.FTPError[illegalFilename, "Illegal file title"L];
          ENDCASE =>
            ERROR FTPDefs.FTPError[
              unidentifiedPermanentError, "Unidentified ""CantOpen"" from VM"L];
    handle ¬ VMDefs.OpenFile[
      options:
      SELECT action FROM
        read, enumerate => oldReadOnly,
        write => oldOrNew,
        delete => old,
        ENDCASE => ERROR, name: file, cacheFraction: 2];
    END;

  GetInfo: PROC [handle: VMDefs.FileHandle, info: FTPDefs.FileInfo] =
    BEGIN
    IF info = NIL THEN RETURN;
    BEGIN
    length: VMDefs.Position = VMDefs.GetFileLength[handle];
    info.byteCount ¬ LONG[length.page] * 2 * VMDefs.pageSize + length.byte;
    END;
    info.fileType ¬ binary;
    info.byteSize ¬ 8;
    BEGIN
    Append: PROC [s: STRING, t: Time.Packed] =
      BEGIN
      IF s # NIL THEN {s.length ¬ 0; Time.Append[s, Time.Unpack[t], TRUE]};
      END;
    create, write, read: Time.Packed;
    [create: LOOPHOLE[create, VMDefs.FileTime],
      read: LOOPHOLE[read, VMDefs.FileTime],
      write: LOOPHOLE[write, VMDefs.FileTime]] ¬ VMDefs.GetFileTimes[handle];
    Append[info.creationDate, create];
    Append[info.writeDate, write];
    Append[info.readDate, read];
    END;
    END;


  MyEnumerateFiles: PROC [
    fileSystem: FTPDefs.FileSystem, files: STRING,
    intent: FTPDefs.EnumerateFilesIntent,
    processFile: PROC [UNSPECIFIED, STRING, FTPDefs.FileInfo],
    processFileData: UNSPECIFIED] =
    BEGIN
    real: BodyDefs.RName = LOOPHOLE[fileSystem];
    creation: STRING = [22];  -- 31-Oct-83 25:61:61 BST --
    write: STRING = [22];  -- 1234567890123456789012 --
    read: STRING = [22];
    fileInfoObject: FTPDefs.FileInfoObject ¬ [
      fileType: binary, byteSize: 8, byteCount: 0, creationDate: creation,
      writeDate: write, readDate: read, author: NIL];
    SingleFile: MFile.EnumerateProc =
      BEGIN
      shortName: STRING = [MFile.maxNameLength];
      handle: VMDefs.FileHandle;
      String.AppendString[shortName, name];
      handle ¬ VMDefs.OpenFile[name: shortName];
      GetInfo[handle, @fileInfoObject];
      VMDefs.AbandonFile[handle];
      processFile[processFileData, shortName, @fileInfoObject];
      RETURN[FALSE]
      END;
    CheckAccess[real, list, files];
    IF intent = enumeration AND files.length = 1 AND files[0] = '* THEN
      MFile.EnumerateDirectory["*"L, SingleFile, filesOnly]
    ELSE
      BEGIN
      IF intent = enumeration THEN
        BEGIN
        handle: VMDefs.FileHandle = OpenVMFile[files, enumerate];
        GetInfo[handle, @fileInfoObject];
        VMDefs.AbandonFile[handle];
        END;
      processFile[processFileData, files, @fileInfoObject];
      END;
    END;

  MyOpenFile: PROC [
    fileSystem: FTPDefs.FileSystem, file: STRING, mode: FTPDefs.Mode,
    fileTypePlease: BOOLEAN, info: FTPDefs.FileInfo]
    RETURNS [fileHandle: FTPDefs.FileHandle, fileType: FTPDefs.FileType] =
    BEGIN
    real: BodyDefs.RName = LOOPHOLE[fileSystem];
    SELECT mode FROM
      read =>
        BEGIN
        handle: VMDefs.FileHandle;
        CheckAccess[real, read, file];
        handle ¬ OpenVMFile[file, read];
        LogAction[real, file, read];
        GetInfo[handle, info];
        fileType ¬ binary;
        fileHandle ¬ LOOPHOLE[handle];
        END;
      write =>
        BEGIN
        CheckAccess[real, write, file];
        fileHandle ¬ LOOPHOLE[OpenVMFile[file, write]];
        LogAction[real, file, write];
        IF info # NIL AND info.creationDate # NIL AND info.creationDate.length > 0
          THEN
          VMDefs.SetCreationTime[
            file: LOOPHOLE[fileHandle],
            create: TimeExtra.PackedTimeFromString[info.creationDate]];
        END;
      ENDCASE =>
        ERROR FTPDefs.FTPError[requestedAccessDenied, "Unexpected access mode"L];
    END;

  MyReadFile: PROC [
    fileSystem: FTPDefs.FileSystem, fileHandle: FTPDefs.FileHandle,
    sendBlock: PROC [LONG UNSPECIFIED, LONG POINTER, CARDINAL],
    sendBlockData: LONG UNSPECIFIED] =
    BEGIN
    handle: VMDefs.FileHandle = LOOPHOLE[fileHandle];
    length: VMDefs.Position = VMDefs.GetFileLength[handle];
    FOR p: CARDINAL IN [0..length.page)  --complete pages--
      DO
      page: VMDefs.Page = VMDefs.ReadPage[[handle, p], 2];
      sendBlock[
        sendBlockData, page, 2 * VMDefs.pageSize !
        UNWIND => VMDefs.Release[page]];
      VMDefs.Release[page];
      ENDLOOP;
    IF length.byte > 0 THEN  --partial page--
      BEGIN
      page: VMDefs.Page = VMDefs.ReadPage[[handle, length.page], 0];
      sendBlock[
        sendBlockData, page, length.byte ! UNWIND => VMDefs.Release[page]];
      VMDefs.Release[page];
      END;
    END;

  MyWriteFile: PROC [
    fileSystem: FTPDefs.FileSystem, fileHandle: FTPDefs.FileHandle,
    receiveBlock: PROC [LONG UNSPECIFIED, LONG POINTER, CARDINAL] RETURNS [CARDINAL],
    receiveBlockData: LONG UNSPECIFIED] =
    BEGIN
    handle: VMDefs.FileHandle = LOOPHOLE[fileHandle];
    pos: VMDefs.Position ¬ [0, 0];
    page: VMDefs.Page ¬ VMDefs.UsePage[[handle, pos.page]];
    DO
      ENABLE UNWIND => IF page # NIL THEN VMDefs.Release[page];
      amount: CARDINAL = receiveBlock[
        receiveBlockData, page + (pos.byte / 2),
        VMDefs.pageSize - (pos.byte / 2)];
      IF amount = 0 THEN EXIT;
      pos.byte ¬ pos.byte + amount;
      IF amount MOD 2 # 0 THEN
        BEGIN
        temp: UNSPECIFIED;
        IF receiveBlock[receiveBlockData, @temp, SIZE[UNSPECIFIED]] = 0 THEN EXIT
        ELSE
          ERROR FTPDefs.FTPError[
            requestedAccessDenied, "Odd-byte block boundary not implemented"L];
        END;
      IF pos.byte >= 2 * VMDefs.pageSize THEN
        BEGIN
        IF pos.byte > 2 * VMDefs.pageSize THEN ERROR;
        VMDefs.MarkStart[page];
        VMDefs.Release[page];
        page ¬ NIL;
        pos.page ¬ pos.page + 1;
        pos.byte ¬ 0;
        page ¬ VMDefs.UsePage[[handle, pos.page]];
        END;
      ENDLOOP;
    IF pos.byte > 0 THEN VMDefs.MarkStart[page];
    VMDefs.Release[page];
    VMDefs.WaitFile[handle];
    VMDefs.SetFileLength[handle, pos];
    END;

  MyCloseFile: PROC [
    fileSystem: FTPDefs.FileSystem, fileHandle: FTPDefs.FileHandle,
    aborted: BOOLEAN] = BEGIN VMDefs.CloseFile[LOOPHOLE[fileHandle]]; END;

  MyDeleteFile: PROC [fileSystem: FTPDefs.FileSystem, file: STRING] =
    BEGIN
    real: BodyDefs.RName = LOOPHOLE[fileSystem];
    handle: VMDefs.FileHandle;
    CheckAccess[real, write, file];
    handle ¬ OpenVMFile[file, delete];
    LogAction[real, file, delete];
    VMDefs.DestroyFile[handle];
    END;

  MyRenameFile: PROC [
    fileSystem: FTPDefs.FileSystem, currentFile, newFile: STRING] =
    BEGIN
    real: BodyDefs.RName = LOOPHOLE[fileSystem];
    fh: MFile.Handle;
    CheckAccess[real, write, newFile];
    CheckAccess[real, read, currentFile];
    LogAction[real, currentFile, rename];
    fh ¬ MFile.Acquire[
      currentFile, rename, MFile.dontRelease ! MFile.Error =>
        ERROR FTPDefs.FTPError[
          requestedAccessDenied, "source of rename doesn't exist"L] ];
    MFile.Rename[fh, newFile ! MFile.Error => {
        MFile.Release[fh];
        ERROR FTPDefs.FTPError[
          requestedAccessDenied,
          "destination already exists"L]; } ];
    MFile.Release[fh];
    END;


  -- Backstop and Filter for listeners --

  Backstop: FTPDefs.BackstopServer ¬
    BEGIN
    addr: PupDefs.PupAddress;
    IF NOT PupDefs.ParsePupAddressConstant[@addr, originOfRequest] THEN
      BEGIN addr.net ¬ [0]; addr.host ¬ [0]; END;
    localInsignia.length ¬ 0;
    String.AppendString[localInsignia, "Grapevine FTP server on host "L];
    PupDefs.AppendMyName[localInsignia];
    server[
      !
      FTPDefs.FTPError =>
        SELECT ftpError FROM
          IN FTPDefs.CommunicationError, IN FTPDefs.ProtocolError => CONTINUE;
          IN FTPDefs.UnidentifiedError => CONTINUE;
          ENDCASE => RESUME ; WhoIsHe => RESUME [addr.net, addr.host];
      VMDefs.Error =>
        SELECT reason FROM
          io => ERROR FTPDefs.FTPError[fileDataError, "Unrecoverable i/o error"L];
          resources =>
            ERROR FTPDefs.FTPError[noRoomForFile, "Backing store full"L];
          ENDCASE =>
            ERROR FTPDefs.FTPError[
              unidentifiedPermanentError, "Unidentified ""VMDefs.Error"""L];
      VMDefs.CantWriteBackingStore =>
        ERROR FTPDefs.FTPError[
          fileDataError, "Can't write page to backing store"L];
      VMDefs.CantReadBackingStore =>
        ERROR FTPDefs.FTPError[
          fileDataError, "Can't read page from backing store"L]; ];
    PolicyDefs.EndOperation[FTP];
    END;

  Filter: PROC [from: STRING, purpose: FTPDefs.Purpose] =
    BEGIN
    IF NOT PolicyDefs.CheckOperation[FTP] THEN
      BEGIN
      LogDefs.WriteLogEntry["Rejected FTP connection"L];
      ERROR FTPDefs.RejectThisConnection["Server full"L];
      END;
    END;


  -- Initialization --

  myFilePrimitives: FTPDefs.FilePrimitivesObject ¬ [
    CreateFileSystem: MyCreate, DestroyFileSystem: MyDestroy,
    DecomposeFilename: MyDecompose, ComposeFilename: MyCompose,
    InspectCredentials: MyInspectCredentials, EnumerateFiles: MyEnumerateFiles,
    OpenFile: MyOpenFile, ReadFile: MyReadFile, WriteFile: MyWriteFile,
    CloseFile: MyCloseFile, DeleteFile: MyDeleteFile, RenameFile: MyRenameFile];

  FTPDefs.FTPInitialize[];
  FTPDefs.FTPCatchUnidentifiedErrors[FALSE];

  [] ¬ FTPDefs.FTPCreateListener[
    --purpose-- files,
    --file system-- @myFilePrimitives,
    --mail system-- NIL,
    --comm system-- FTPDefs.PupCommunicationPrimitives[],
    --backstop-- @Backstop,
    --backstopData-- 0,
    --filter-- Filter];

  END.