// 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
]