// FtpUserUtil.bcpl -- routines common to FtpKbd* and FtpCli*
// Copyright Xerox Corporation 1979, 1980, 1981, 1982
// Last modifed October 11, 1982  1:01 AM by Boggs

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

external
[
// outgoing procedures
FtpUserFinishProc; LogPuts
ProcessNoCode; GetNamePassword
OpenUserConn; UserKey
ListPrint; ListPuts
FillPLFromLD

// incoming procedures
FalsePredicate; MoveBlock
Resets; Closes; Puts
OtherPup; FreePointer
SetTimer; TimerHasExpired; Block
OpenLevel1Socket; CloseLevel1Socket
OpenRTPSocket; CloseRTPSocket
CreateBSPStream; CloseBSPSocket; UserOpen
InitCmd; DefaultPhrase; TerminatingChar; GetString; GetPhrase
ExtractSubstring; StringCompare
PutTemplate; Wss; CliError
UNPACKDT; CONVUDT
InitPList; FileType
ReadLeaderPage; LnPageSize

// outgoing statics
listST

// incoming statics
CtxRunning; defaultPL; cliFlag; lvUserFinishProc
userSoc; userCtx; userDsp; userKeys; userUFP; userDspLen; logStream
]

manifest
[
fcOK = 0
kbdAd = 177034b
]

static listST

//-----------------------------------------------------------------------------------------
let FtpUserFinishProc(fc) be
//-----------------------------------------------------------------------------------------
[
if userCtx>>FtpCtx.connFlag then
   [
   Wss(userDsp, "*NClosing connections...*N")
   CtxRunning>>FtpCtx.connFlag = false
   CloseBSPSocket(userSoc, (fc eq fcOK? 3000, 0))
   ]
@lvUserFinishProc = userUFP
]

//-----------------------------------------------------------------------------------------
and LogPuts(st, char) be
//-----------------------------------------------------------------------------------------
[
Puts(userDspLen, char)
if logStream ne 0 then Puts(logStream, char)
]

//-----------------------------------------------------------------------------------------
and ProcessNoCode(noCode, pList) = valof
//-----------------------------------------------------------------------------------------
[
Resets(userKeys)
switchon noCode into
   [
   case 20b: case 21b: case 2:  // user params
      [
      unless GetNamePassword("*NLogin user ",
       lv defaultPL>>PL.UNAM, lv defaultPL>>PL.UPSW) resultis false
      ResetProp(lv pList>>PL.UNAM, defaultPL>>PL.UNAM)
      ResetProp(lv pList>>PL.UPSW, defaultPL>>PL.UPSW)
      endcase
      ]
   case 23b: case 24b:  // connect params
      [
      unless GetNamePassword("*NConnect to directory ",
       lv defaultPL>>PL.CNAM, lv defaultPL>>PL.CPSW) resultis false
      ResetProp(lv pList>>PL.CNAM, defaultPL>>PL.CNAM)
      ResetProp(lv pList>>PL.CPSW, defaultPL>>PL.CPSW)
      endcase
      ]
   default: [ if cliFlag then CliError(); resultis false ]
   ]
Wss(userDsp, " Retrying...")
resultis true
]

//-----------------------------------------------------------------------------------------
and ResetProp(lvFPL, def) be
//-----------------------------------------------------------------------------------------
[
if def ne 0 then
   if StringCompare(def, @lvFPL) ne 0 then
      [
      FreePointer(lvFPL)
      @lvFPL = ExtractSubstring(def)
      ]
]

//-----------------------------------------------------------------------------------------
and GetNamePassword(prompt, lvName, lvPassword) = valof
//-----------------------------------------------------------------------------------------
[
let cs = InitCmd(256, 3, 0, 0, 0, userKeys, userDsp)
if cs eq 0 resultis false
if lvName ne 0 then
   [
   if prompt ne 0 then Wss(cs, prompt)
   if @lvName ne 0 then DefaultPhrase(cs, @lvName)
   let name = GetString(cs)
   FreePointer(lvName); @lvName = name
   if TerminatingChar(cs) eq $*N then lvPassword = 0
   ]
if lvPassword ne 0 then
   [
   FreePointer(lvPassword)
   Wss(cs, " Password ")
   GetPhrase(cs, 0, 0, FalsePredicate)
   Resets(cs)
   @lvPassword = GetString(cs)
   ]
Closes(cs)
resultis true
]

//-----------------------------------------------------------------------------------------
and OpenUserConn(port) = valof
//-----------------------------------------------------------------------------------------
[
if (port>>Port.socket^1 eq 0 & port>>Port.socket^2 eq 0) %
 port>>Port.host eq 0 then resultis false
OpenLevel1Socket(userSoc, 0, port)
OpenRTPSocket(userSoc, 0, modeInitAndReturn, 0, OtherPup)
let timer = nil; SetTimer(lv timer, 6000)
Block() repeatwhile userSoc>>RTPSoc.state eq stateRFCOut &
 not UserKey() & not TimerHasExpired(lv timer)
unless userSoc>>RTPSoc.state eq stateOpen do
   [
   Wss(userDsp, "*NConnection attempt failed")
   CloseRTPSocket(userSoc, 0)
   CloseLevel1Socket(userSoc)
   resultis false
   ]
CtxRunning>>FtpCtx.bspStream = CreateBSPStream(userSoc)
let Version(stream) be Wss(stream, "BCPL Pup FTP User, 14 May 82")
resultis UserOpen(Version)
]

//-----------------------------------------------------------------------------------------
and UserKey() = (kbdAd!1 & 2) eq 0
//-----------------------------------------------------------------------------------------

//-----------------------------------------------------------------------------------------
and ListPrint(remotePL, localPL) be
//-----------------------------------------------------------------------------------------
[
let options = listST>>ST.par1
if listST>>ST.par3 then  //print a title
   [
   listST>>ST.par3 = false
   unless options eq 1b15 rshift offset DPRP.SFIL do Puts(userDsp, $*N)
   listST>>ST.par2 = 0; NextField(wName)
   if (options & lbType) ne 0 then
      [ NextField(wType); Wss(listST, "Type") ]
   if (options & lbLength) ne 0 then
      [ NextField(wLength); Wss(listST, "Length") ]
   if (options & lbCreate) ne 0 then
      [ NextField(wDate); Wss(listST, "Create") ]
   if (options & lbWrite) ne 0 then
      [ NextField(wDate); Wss(listST, "Write") ]
   if (options & lbRead) ne 0 then
      [ NextField(wDate); Wss(listST, "Read") ]
   if (options & lbAuthor) ne 0 then
      [ NextField(wAuthor); Wss(listST, "Author") ]
   ]

listST>>ST.par2 = 0; Puts(userDsp, $*N); NextField(wName)
Wss(listST, (remotePL>>PL.SFIL? remotePL>>PL.SFIL, remotePL>>PL.NAMB))

if (options & lbType) ne 0 then
   [
   NextField(wType)
   switchon remotePL>>PL.TYPE into
      [
      case Text:
         [ Wss(listST, "Text"); endcase ]
      case Binary:
         [ PutTemplate(listST, "B($UD)", remotePL>>PL.BYTE); endcase ]
      default:
         [ Wss(listST, "  ?"); endcase ]
      ]
   ]

if (options & lbLength) ne 0 then
   [
   NextField(wLength)
   PutTemplate(listST, "$EUD", lv remotePL>>PL.SIZE)
   ]

if (options & lbCreate) ne 0 then
   [ NextField(wDate); PrintDate(lv remotePL>>PL.CDAT) ]
if (options & lbWrite) ne 0 then
   [ NextField(wDate); PrintDate(lv remotePL>>PL.WDAT) ]
if (options & lbRead) ne 0 then
   [ NextField(wDate); PrintDate(lv remotePL>>PL.RDAT) ]
if (options & lbAuthor) ne 0 then
   [
   NextField(wAuthor)
   test remotePL>>PL.AUTH ne 0
      ifso Wss(listST, remotePL>>PL.AUTH)
      ifnot Wss(listST, "  ---")
   ]
]

//-----------------------------------------------------------------------------------------
and ListPuts(st, char) be
//-----------------------------------------------------------------------------------------
[
Puts(userDsp, char)
st>>ST.par2 = st>>ST.par2 -1
]

//-----------------------------------------------------------------------------------------
and NextField(width) be
//-----------------------------------------------------------------------------------------
[
test listST>>ST.par2 gr 0
   ifso until listST>>ST.par2 eq 0 do Puts(listST, $*S)
   ifnot if listST>>ST.par2 le 0 then
      [
      width = width + listST>>ST.par2  // par2 is negative
      Wss(listST, "  ")
      ]
listST>>ST.par2 = width
]

//-----------------------------------------------------------------------------------------
and PrintDate(dt) be
//-----------------------------------------------------------------------------------------
[
if dt!0 eq 0 then [ Wss(listST, "   ---"); return ]
let uv = vec 7; UNPACKDT(dt, uv)
let date = vec 12; CONVUDT(date, uv)
Wss(listST, date)
]

//-----------------------------------------------------------------------------------------
and FillPLFromLD() = valof
//-----------------------------------------------------------------------------------------
[
let pl = InitPList(defaultPL)

let fileType = FileType()
if defaultPL>>PL.TYPE eq Text & fileType eq Binary then
   [
   Wss(userDsp, "*NFile is Binary, but you have made the default Text")
   Wss(userDsp, "*NThis operation will lose information")
   ]
if pl>>PL.TYPE eq 0 then pl>>PL.TYPE = fileType
test pl>>PL.TYPE eq Binary
   ifso if pl>>PL.BYTE eq 0 then pl>>PL.BYTE = 8
   ifnot if pl>>PL.EOLC eq 0 then pl>>PL.EOLC = CR

let ld = CtxRunning>>FtpCtx.buffer
ReadLeaderPage(CtxRunning>>FtpCtx.diskStream, ld)

MoveBlock(lv pl>>PL.CDAT, lv ld>>LD.created, 2)
MoveBlock(lv pl>>PL.RDAT, lv ld>>LD.read, 2)
MoveBlock(lv pl>>PL.WDAT, lv ld>>LD.written, 2)

let siz = lv pl>>PL.SIZE
let fa = lv ld>>LD.hintLastPageFa
let lnBytes = LnPageSize(CtxRunning>>FtpCtx.diskStream) +1
let numPages = fa>>FA.pageNumber -1  //don't count leader page
unless numPages eq -1 do
   [
   siz!0 = numPages rshift (16-lnBytes)
   siz!1 = numPages lshift lnBytes + fa>>FA.charPos
   ]

resultis pl
]