// FtpServer.bcpl - Subsystem version
// Copyright Xerox Corporation 1979, 1980, 1981, 1982
// Last modified May 13, 1982  4:45 PM by Boggs

get "Pup.decl"
get "FtpProt.decl"
get "AltoFileSys.d"
get "Disks.d"

external
[
// outgoing procedures
FtpServer; FtpServFinishProc
FtpSStore; FtpSStoreFile; FtpSStoreCleanup
FtpSRetrieve; FtpSRetrieveFile; FtpSRetrieveCleanup
FtpSDelete; FtpSDeleteFile; FtpSRename
FtpSDirectory; FtpSVersion

// incoming procedures
FtpServProt; FreePList; InitPList
Allocate; Zero; Block; MoveBlock; Password
ExtractSubstring; ConcatenateStrings; PutTemplate
DiskToNet; NetToDisk; FTPM; FileType
OtherPup; MakeNAMB; CloseLocalFile; PrintPort
OpenFile; DeleteFile; RenameFile; Closes; Wss
ReadLeaderPage; WriteLeaderPage; SetFilePos; ReadBlock
OpenLevel1Socket; OpenRTPSocket; CreateBSPStream
CloseLevel1Socket; CloseRTPSocket; CloseBSPSocket

// outgoing statics
protectedServer; overwriteServer; killServer

// incoming statics
ftpDisk; defaultPL; debugFlag; CtxRunning
serverDsp; serverCtx; serverSoc; serverUFP
sysZone; fpSysBoot; lvUserFinishProc
]

static
[
diskPsw = 0
protectedServer = false
overwriteServer = false
killServer = false
abortFlag = false
firstTime = true
]

//-----------------------------------------------------------------------------------------
let FtpServer() be
//-----------------------------------------------------------------------------------------
[
OpenLevel1Socket(serverSoc, table [ 0; 0; socketFTP ] )
OpenRTPSocket(serverSoc, 0, modeListenAndReturn, 0, OtherPup)
until serverSoc>>BSPSoc.state eq stateOpen do Block()
PutTemplate(serverDsp, "*NConnection Open with $P",
 PrintPort, lv serverSoc>>BSPSoc.frnPort)
CtxRunning>>FtpCtx.bspStream = CreateBSPStream(serverSoc)
CtxRunning>>FtpCtx.connFlag = true
FtpServProt(18000)  //3 minute top level command timeout
Wss(serverDsp, "*NServer Connection Closed")
if abortFlag then Block() repeat
if killServer then finish
] repeat

//-----------------------------------------------------------------------------------------
and FtpServFinishProc() be
//-----------------------------------------------------------------------------------------
[
abortFlag = true
if serverCtx>>FtpCtx.connFlag then
   [
   serverCtx>>FtpCtx.connFlag = false
   CloseBSPSocket(serverSoc, 0)
   ]
@lvUserFinishProc = serverUFP
]

//-----------------------------------------------------------------------------------------
and FtpSRetrieve(remotePL, localPL) = valof
//-----------------------------------------------------------------------------------------
[
localPL = FreePList(localPL)
unless firstTime do [ firstTime = true; resultis false ]
unless CheckAccess(remotePL) resultis false
MakeSFIL(remotePL)
CtxRunning>>FtpCtx.diskStream = OpenFile(remotePL>>PL.SFIL,
 ksTypeReadOnly, charItem, 0, 0, 0, 0, 0, ftpDisk)
if CtxRunning>>FtpCtx.diskStream eq 0 then
   [ FTPM(markNo, 100b, "No such file"); resultis false ]

// setup outgoing property list
let ok = true
localPL = FtpSFillPLFromLD(remotePL)
if remotePL>>PL.TYPE ne 0 & localPL>>PL.TYPE ne remotePL>>PL.TYPE then
   test localPL>>PL.TYPE eq Binary
      ifso
         [
         FTPM(markNo, 102b, "File is Binary, not Text")
         ok = false
         ]
      ifnot
         [
         FTPM(markComment, 0, "Warning: file may be text")
         localPL>>PL.TYPE = Binary
         ]

if ok then test localPL>>PL.TYPE eq Binary
   ifso test remotePL>>PL.BYTE eq 0
      ifnot localPL>>PL.BYTE = remotePL>>PL.BYTE
      ifso localPL>>PL.BYTE = 8
   ifnot test remotePL>>PL.EOLC eq CRLF
      ifnot localPL>>PL.EOLC = CR
      ifso
         [
         FTPM(markNo, 102b, "CRLF Conversion not supported")
         ok = false
         ]

firstTime = false
unless ok do
   [
   CloseLocalFile()
   localPL = FreePList(localPL)
   ]
resultis localPL
]

//-----------------------------------------------------------------------------------------
and FtpSRetrieveFile(localPL, remotePL) = valof
//-----------------------------------------------------------------------------------------
[
PutTemplate(serverDsp, "*NRetrieve $S: ", localPL>>PL.SFIL)
resultis DiskToNet(remotePL, localPL)
]

//-----------------------------------------------------------------------------------------
and FtpSRetrieveCleanup(localPL, ok, remotePL) be
//-----------------------------------------------------------------------------------------
   Closes(CtxRunning>>FtpCtx.diskStream)

//-----------------------------------------------------------------------------------------
and FtpSStore(remotePL) = valof
//-----------------------------------------------------------------------------------------
[
unless CheckAccess(remotePL) resultis false
if protectedServer then
   [
   FTPM(markNo, 101b, "Store is not permitted")
   resultis false
   ]
if remotePL>>PL.EOLC eq CRLF then
   [
   FTPM(markNo, 102b, "CRLF conversion not supported")
   resultis false
   ]
MakeSFIL(remotePL)
let hintFP = vec lFP; Zero(hintFP, lFP)
let diskStream = OpenFile(remotePL>>PL.SFIL, ksTypeReadOnly,
 charItem, 0, hintFP, 0, 0, 0, ftpDisk)
if diskStream ne 0 then
   [
   Closes(diskStream)
   unless overwriteServer do
      [
      FTPM(markNo, 101b, "File exists - can't overwrite")
      resultis false
      ]
   ]
CtxRunning>>FtpCtx.diskStream = OpenFile(remotePL>>PL.SFIL,
 ksTypeWriteOnly, charItem, 0, hintFP, 0, 0, 0, ftpDisk)
if CtxRunning>>FtpCtx.diskStream eq 0 then
   [
   FTPM(markNo, 100b, "Unable to open that file")
   resultis false
   ]
resultis FtpSFillPLFromLD(remotePL)
]

//-----------------------------------------------------------------------------------------
and FtpSStoreFile(remotePL, localPL) = valof
//-----------------------------------------------------------------------------------------
[
let buffer = CtxRunning>>FtpCtx.buffer
ReadLeaderPage(CtxRunning>>FtpCtx.diskStream, buffer)
if remotePL>>PL.CDAT.h ne 0 then
   MoveBlock(lv buffer>>LD.created, lv remotePL>>PL.CDAT, 2)
WriteLeaderPage(CtxRunning>>FtpCtx.diskStream, buffer)
PutTemplate(serverDsp, "*NStore $S: ", remotePL>>PL.SFIL)
resultis NetToDisk(remotePL, localPL)
]

//-----------------------------------------------------------------------------------------
and FtpSStoreCleanup(remotePL, ok, localPL) be
//-----------------------------------------------------------------------------------------
[
FreePList(localPL)
Closes(CtxRunning>>FtpCtx.diskStream)
unless ok do DeleteFile(remotePL>>PL.SFIL, 0, 0, 0, 0, ftpDisk)
]

//-----------------------------------------------------------------------------------------
and FtpSVersion(bspStream, nil) be
//-----------------------------------------------------------------------------------------
   Wss(bspStream, "BCPL Pup Ftp Server, 13 May 82 ")

//-----------------------------------------------------------------------------------------
and FtpSDirectory(remotePL, localPL) = valof
//-----------------------------------------------------------------------------------------
[
localPL = FreePList(localPL)
unless firstTime do [ firstTime = true; resultis false ]
unless CheckAccess(remotePL) resultis false
MakeSFIL(remotePL)
CtxRunning>>FtpCtx.diskStream = OpenFile(remotePL>>PL.SFIL,
 ksTypeReadOnly, charItem, 0, 0, 0, 0, 0, ftpDisk)
if CtxRunning>>FtpCtx.diskStream eq 0 then
   [ FTPM(markNo, 100b, "No such file"); resultis false ]
PutTemplate(serverDsp, "*NDirectory $S", remotePL>>PL.SFIL)

// setup property list
localPL = FtpSFillPLFromLD(remotePL)
Closes(CtxRunning>>FtpCtx.diskStream)
firstTime = false
resultis localPL
]

//-----------------------------------------------------------------------------------------
and FtpSRename(oldPL, newPL) = valof
//-----------------------------------------------------------------------------------------
[
unless CheckAccess(oldPL) resultis false
MakeSFIL(oldPL)
MakeSFIL(newPL)
if not overwriteServer % protectedServer then
   [
   FTPM(markNo, 101b, "Rename is not permitted")
   resultis false
   ]
PutTemplate(serverDsp, "*NRename $S to $S", oldPL>>PL.SFIL, newPL>>PL.SFIL)
if RenameFile(oldPL>>PL.SFIL, newPL>>PL.SFIL, 0, 0, 0, ftpDisk) resultis true
FTPM(markNo, 0, "Rename failed")
resultis false
]

//-----------------------------------------------------------------------------------------
and FtpSDelete(remotePL, localPL) = valof
//-----------------------------------------------------------------------------------------
[
FreePList(localPL)
unless firstTime do [ firstTime = true; resultis false ]
unless CheckAccess(remotePL) resultis false
MakeSFIL(remotePL)
if not overwriteServer % protectedServer then
   [
   FTPM(markNo, 101b, "Delete is not permitted")
   resultis false
   ]
CtxRunning>>FtpCtx.diskStream = OpenFile(remotePL>>PL.SFIL,
 ksTypeReadOnly, charItem, 0, 0, 0, 0, 0, ftpDisk)
if CtxRunning>>FtpCtx.diskStream eq 0 then
   [ FTPM(markNo, 100b, "No such file"); resultis false ]

// setup property list
localPL = FtpSFillPLFromLD(remotePL)
Closes(CtxRunning>>FtpCtx.diskStream)
firstTime = false
resultis localPL
]

//-----------------------------------------------------------------------------------------
and FtpSDeleteFile(localPL, remotePL) = valof
//-----------------------------------------------------------------------------------------
[
PutTemplate(serverDsp, "*NDelete $S", localPL>>PL.SFIL)
resultis DeleteFile(localPL>>PL.SFIL, 0, 0, 0, 0, ftpDisk)
]

//-----------------------------------------------------------------------------------------
and MakeSFIL(pl) be
//-----------------------------------------------------------------------------------------
// Construct (and default) a server filename
[
if pl>>PL.NAMB eq 0 then pl>>PL.NAMB = ExtractSubstring("")
if pl>>PL.SFIL eq 0 then pl>>PL.SFIL = ExtractSubstring(pl>>PL.NAMB)
if pl>>PL.DIRE ne 0 & pl>>PL.SFIL>>String.char^1 ne $< then
   [
   pl>>PL.SFIL = ConcatenateStrings(">", pl>>PL.SFIL, false, true)
   pl>>PL.SFIL = ConcatenateStrings(pl>>PL.DIRE, pl>>PL.SFIL, false, true)
   pl>>PL.SFIL = ConcatenateStrings("<", pl>>PL.SFIL, false, true)
   ]
if pl>>PL.DEVI ne 0 then
   [
   pl>>PL.SFIL = ConcatenateStrings(":", pl>>PL.SFIL, false, true)
   pl>>PL.SFIL = ConcatenateStrings(pl>>PL.DEVI, pl>>PL.SFIL, false, true)
   ]
]

//-----------------------------------------------------------------------------------------
and FtpSFillPLFromLD(remotePL) = valof
//-----------------------------------------------------------------------------------------
// setup property list
[
let dprp = remotePL>>PL.DPRP  //desired properties
if dprp eq 0 then dprp = -1  //if none specified, request all properties
let pl = InitPList()

if dprp<<DPRP.SFIL then pl>>PL.SFIL = ExtractSubstring(remotePL>>PL.SFIL)
if dprp<<DPRP.NAMB then pl>>PL.NAMB = MakeNAMB(remotePL>>PL.SFIL)
if dprp<<DPRP.TYPE then pl>>PL.TYPE = FileType()

manifest requiresLD = 1b15 rshift offset DPRP.SIZE % 1b15 rshift offset DPRP.CDAT %
 1b15 rshift offset DPRP.WDAT % 1b15 rshift offset DPRP.RDAT
if (dprp & requiresLD) ne 0 then
   [
   let ld = CtxRunning>>FtpCtx.buffer
   ReadLeaderPage(CtxRunning>>FtpCtx.diskStream, ld)

   if dprp<<DPRP.CDAT then MoveBlock(lv pl>>PL.CDAT, lv ld>>LD.created, 2)
   if dprp<<DPRP.RDAT then MoveBlock(lv pl>>PL.RDAT, lv ld>>LD.read, 2)
   if dprp<<DPRP.WDAT then MoveBlock(lv pl>>PL.WDAT, lv ld>>LD.written, 2)

   if dprp<<DPRP.SIZE then
      [
      let siz = lv pl>>PL.SIZE
      let fa = lv ld>>LD.hintLastPageFa
      let lnBytes = ftpDisk>>DSK.lnPageSize +1
      let numPages = fa>>FA.pageNumber -1
      if numPages ne -1 then
         [
         siz!0 = numPages rshift (16-lnBytes)
         siz!1 = numPages lshift lnBytes + fa>>FA.charPos
         ]
      ]
   ]

resultis pl
]

//-----------------------------------------------------------------------------------------
and CheckAccess(pl) = valof
//-----------------------------------------------------------------------------------------
// If the disk is password protected, then check the password,
//  otherwise don't (just return true).
// Checking the password means:
//  If there is a password in core, and it matches the password
//   on the disk, then success (regardless of the password in
//   the pl - it is assumed that the disk owner has booted
//   the disk and is controlling access via the server option
//   switches (noOverwrite, Protected, noServer etc)).
//  If there isn't a password in core, or it doesn't match the
//   password in pl, then the password in the pl must equal
//   the password on the disk.
[
if diskPsw eq 0 then
   [
   let sysBoot = OpenFile("Sys.boot", ksTypeReadOnly, wordItem, 0, fpSysBoot)
   SetFilePos(sysBoot, 0, 1400b)  //see Password.bcpl in OS
   diskPsw = Allocate(sysZone, 9)
   ReadBlock(sysBoot,diskPsw, 9)
   Closes(sysBoot)
   ]
if diskPsw!0 then
   [
   let uPsw = defaultPL>>PL.UPSW
   if uPsw & uPsw>>String.length ne 0 then
      if Password(uPsw, diskPsw, false) resultis true
   if pl>>PL.UPSW & pl>>PL.UPSW>>String.length ne 0 then
      if Password(pl>>PL.UPSW, diskPsw, false) resultis true
   FTPM(markNo, 21b, "Incorrect User-password")
   resultis false
   ]
resultis true
]