%begin {**********************************************************************} {* APMTEL Server - based on P_H2 by GDMR *} {* Andrew Ness 1988 CS4 project *} {* Modded version - see mod list below *} {* *} {* Version 4.1 6 Sep 1988 *} {**********************************************************************} ! Version 4.x - server writes to file directly. %conststring (255) version = "Version 4.1 6 Sep 1988" %option "-nonstandard-nocheck-nodiag-noline-nostack" %constinteger processes = 4 {Number of listeners %constinteger internal copy limit = 3 {System var %constinteger max contexts = 4 {Number of listeners %constinteger max Uno = 6 {Hook for authorisation %constinteger max Xno = 100 {Hook for database %constinteger ether max = 536 {Maximum packet size %constinteger process size = 10240 {The memory each process is given %constinteger tty channel = 0 {I/O channel to terminal %constinteger qsart channel = 1 {I/O channel to RS-232/423 %conststring(31) facility name = "PORT_0_FACILITY_16" {MAGIC NUMBER %include "inc:util.imp" %include "Moose:Mouse.Inc" %include "GDMR_E:2Meg.Inc" %include "GDMR_H:FSysAcc.Inc" %include "GDMR_H:IO_F.oInc" %include "GDMR_H:FSys.Inc"; ! For protection bits %include "GDMR_H:DateTime.Inc" %conststring(31) context table name = "APMTEL_PORT_TABLE" ! ! The context record is the store for all the information about the clients ! %recordformat context fm(%integer remote address, remote port, local port, %integer tag, %integer open datestamp, transmit datestamp, %record(ether request fm) ether request, %bytename buffer) %ownrecord(context fm)%array context info(1 : max contexts) = 0(*) ! ! The mutex to stop multiple access to the BBC ! (actually the QSART board) ! %ownrecord(semaphore fm) beeb semaphore = 0 ! ! And other system semaphores ! %ownrecord(semaphore fm) our request semaphore = 0 %ownrecord(mailbox fm) our request mailbox = 0 %ownrecord(mailbox fm)%name ether request mailbox == nil ! Protocol interpreter. Take a request (context, bytes, buffer), interpret it, ! and return a response in the same buffer. Special request (bytes < 0) asks ! for the context to be cleared down (reconnect, probably). These are ! sorted alphabetically so we can see easily what hasn't been used. ! reserved '@' { Can't be used for some reason! %constinteger APMTEL START = 'A' %constinteger APMTEL PAGE = 'B' %constinteger APMTEL CHAN = 'C' %constinteger APMTEL STOP = 'D' %constinteger APMTEL CANCEL= 'E' ! unused '_' %constinteger first FC = '@'; ! This one is reserved. %constinteger last FC = 'E' ! Uno and Xno table formats. Note that access to these tables is implicitly ! synchronised by the protocol: Uno 0 is read-only, while all other Unos and ! Xnos are context-specific. We only have a read outstanding on a context while ! we are not processing a request, hence each Uno or Xno can only be active ! once. ! ! HOOK FOR AUTHORISATION FEATURE ! %conststring(31) Uno table name = "APMTEL_UNO_TABLE" %recordformat Uno info fm(%integer context, tag, %integer opened datestamp, used datestamp, %string(31) username, %integer channel) %conststring(31) Xno table name = "APMTEL_XNO_TABLE" %recordformat Xno info fm(%record(access fm)%name access, %string(31) filename, %integer opened datestamp, used datestamp, %integer Uno, context, tag, mode, file token, flags, %integer size, blocks, next block) %constinteger Xno read access = 1 %constinteger Xno modify access = 2 %ownrecord(Uno info fm)%array Uno info(0 : max Uno) = 0(*) %ownrecord(Xno info fm)%array Xno info(1 : max Xno) = 0(*) %ownrecord(semaphore fm) UXno allocation semaphore = 0 %ownrecord(semaphore fm) internal copy semaphore = 0 %owninteger internal copy count = internal copy limit %recordformat p0 buffer fm(%record(message fm) system part, %byte ra, rp, (%bytearray x(0 : 532) %c %or %byte facility %c %or %string(127) reply text)) %systemintegerfnspec global heap get(%integer amount) !!%systemroutinespec phex(%integer i) !!%systemroutinespec phex2(%integer i) !!%systemintegerfnspec stoi(%string(255) s) !!%systemintegerfnspec free store %externalintegerfnspec q testsymbol %externalroutinespec FS insert(%string(31) what, %integer where) %externalpredicatespec FS lookup(%string(15) what, %integername result) %conststring(31) fsys state name = "FSYS_STATE" %ownintegername fsys state == nil ! ! QSART board declarations ! %recordformat DEVICE FM (%byte bstatus,data,intvec,dstatus,x,mode,y,command) %ownrecord (device fm) %name qsart %constinteger dev add = 16_7FFC0, mode1=16_4e, mode2=16_30, comm=16_37, errormask=16_38, txie=1, rxie=2, reset=8 %routine ptime %string(31) d, t unpack date(get datestamp, d, t) printstring(t); spaces(2) %end %routine oplog(%integer context, %string (255) text) !Put TEXT out to server console in standard timestamped format ptime printstring("APMTEL->") %if context>=0 %then write(context, 2) %and space printstring(text); newline %end !!%integerfn zsymbol(%integer i) !! %result=i %if ' ' <= i <= '~' !! %result='?' !!%end %string (255) %fn zstring(%string(255) s) %string (255) t %integer i, ch %result="" %if s = "" t="" %for i = 1, 1, length(s) %cycle ch = charno(s, i) %if ' ' <= ch <= '~' %start t=t.tostring(ch) %else t=t."<".itos(ch,0).">" %finish %repeat %result=t %end ! Communications stuff follows... %integerfn new context tag %owninteger tag = 0 tag = tag + 1 %result = tag %end %routine print context info(%integer context) %record(context fm)%name context data context data == context info(context) write(context, 0); print symbol('(') phex2(context data_local port); printstring(").") phex(context data_tag); printstring(" -> ") phex2(context data_remote address) print symbol('.'); phex2(context data_remote port) %end %routine receive next request(%integername context, tag, bytes, status) %record(ether request fm)%name r !printstring("Receive next request"); newline r == receive message(our request mailbox) context = r_context tag = r_tag bytes = r_bytes status = r_status %end %routine start receive(%integer context, tag) %record(context fm)%name p %unless 0 < context <= max contexts %start oplog(context, "?????? *** Starting receive on dud context ") %return %finish p == context info(context) %if p_remote address = 0 %start oplog(context, "Starting receive on closed context ") %else p_ether request_code = ether old read p_ether request_context = context p_ether request_tag = tag p_ether request_timeout = -1; ! None p_ether request_buffer == p_buffer send message(p_ether request, ether request mailbox, our request mailbox) %finish %end %predicate send response(%integer context, tag, bytes) %record(semaphore fm) semaphore = 0 %record(mailbox fm) mailbox = 0 %record(ether request fm) request = 0 %record(ether request fm)%name reply %record(context fm)%name p %if 0 <= context <= max contexts %start p == context info(context) %if p_remote address = 0 %start oplog(context, "Sending to closed context ") %false %else p_transmit datestamp = get datestamp setup semaphore(semaphore) setup mailbox(mailbox, semaphore) setup message(request, size of(request)) request_code = ether old write request_context = context request_tag = tag request_buffer == p_buffer request_bytes = bytes send message(request, ether request mailbox, mailbox) reply == receive message(mailbox) %if reply_status < 0 %start oplog(context, " (send response): ".ether errors(reply_status)) %false %else %true %finish %finish %else oplog(context, "*** Sending to dud context ???") %false %finish %end %integerfn initialise client comms(%integer ra, rp) %record(semaphore fm) semaphore = 0 %record(mailbox fm) mailbox = 0 %record(ether request fm) request = 0 %record(ether request fm)%name reply == nil %record(context fm)%name p setup semaphore(semaphore) setup mailbox(mailbox, semaphore) setup message(request, size of(request)) request_code = ether old define request_ra = ra request_rp = rp send message(request, ether request mailbox, mailbox) reply == receive message(mailbox) %result = reply_status %if reply_status < 0 ptime printstring("APMTEL->"); write(reply_context, 0) printstring(" Local port "); phex2(reply_lp); printstring(" connected to ") phex2(ra); print symbol('.'); phex2(rp); newline p == context info(reply_context) p_remote address = ra p_remote port = rp p_local port = reply_lp p_open datestamp = get datestamp p_tag = new context tag setup message(p_ether request, size of(p_ether request)) start receive(reply_context, p_tag) %result = reply_lp %end %routine drop context(%integer context, tag) %record(semaphore fm) semaphore = 0 %record(mailbox fm) mailbox = 0 %record(ether request fm) request = 0 %record(ether request fm)%name reply == nil %record(context fm)%name p %unless 0 < context <= max contexts %start oplog(context, "Drop dud context ???") %return %finish p == context info(context); p_remote address = 0 setup semaphore(semaphore) setup mailbox(mailbox, semaphore) setup message(request, size of(request)) request_code = ether old undefine request_context = context request_tag = tag send message(request, ether request mailbox, mailbox) reply == receive message(mailbox) %if reply_status < 0 %start oplog(context, " (drop context): ".ether errors(reply_status)) %finish %end %routine move(%integer bytes, %bytename from, to) !Move BYTES bytes from FROM to TO. Pinched from IE. !If addr(FROM) < addr(TO) do the move from the top down to allow overlap %return %if Bytes = 0 %or From == To %if Addr (To) < Addr (From) %start *Subq.l #1, d0 f loop: *move.b (a0)+, (a1)+ *dbra d0, f loop %else *add.l d0, a0 *add.l d0, a1 *subq.l #1, d0 b loop: *move.b -(a0), -(a1) *dbra d0, b loop %finish %end %routine copy string(%string(255) s, %bytename buffer, %integername pos) ! **Assume** that there's room! %integer i %return %if s = "" !! move(length(s), charno(s, 1), buffer[pos]); pos=pos+length(s) %for i = 1, 1, length(s) %cycle buffer [pos] = charno(s, i) pos = pos + 1 %repeat %end %routine copy bytes(%bytearray from(0:24,0:39) , %integer start,bytes, %bytename buffer, %integername pos) %while bytes > 0 %cycle buffer [pos] = from((pos+start)//40, rem(pos+start,40)); pos = pos + 1 bytes = bytes - 1 %repeat %end %predicate split request(%bytename buf, %bytename comm, %string(255) %name rest, %integer len) %integer i comm= buf[0]; rest="" %for i=1,1,len-1 %cycle rest = rest.tostring(buf[i]) %unless buf[i]=0 %or buf[i]=NL %repeat %true %end %routine cleardown context(%integer tag, Uno) %ownrecord(access fm) full authority = 0; ! Hence nil local authority %record(Xno info fm)%name X %record(Uno info fm)%name U %string(255) textual response %integer i, status %for i = 1, 1, max Xno %cycle X == Xno info(i) %if X_tag = tag %start %if (Uno = 0 %and X_Uno >= 0) %or 0 # Uno = X_Uno %start ! status = F close file(full authority, X_file token, ! auto truncate flag ! improper close flag, ! textual response) ! %if status # 0 %start ! oplog(-1, "Cleardown close: status ".itos(status, 0)) ! %finish X_context = 0; X_tag = 0; X_uno = -1 %finish %finish %repeat %return %if Uno # 0 %for i = 1, 1, max Uno %cycle U == Uno info(i) %if U_tag = tag %start U_context = 0; U_tag = 0 %finish %repeat %end %constinteger BBCack='O', BBCnak='N' %routine put(%record (device fm) %name dev, %Integer sym) %integer state = 1, msec %on 0 %start %stop %if event_sub = 1 -> s1 %if state = 1 -> s2 %if state = 2 %finish msec = cputime + 10 s1: %While dev_dstatus&1=0 %cycle; %return %if cputime >= msec; %repeat state = 2 s2: dev_data =sym %End %routine put q0 line(%string (255) s) %integer i %return %if s="" %for i=1,1,length(s) %cycle put(qsart, charno(s, i)) %repeat put(qsart, 13) %end %integerfn handshake(%integer context, expected, timeout) !Loop till we get either the expected ack/nak or the unexpected nak/ack !or get bored or see a cancel request. !We check the mailbox every 2 seconds to see if a cancel came in. %integer unexpected, c, timer, ctimer unexpected=BBCack+BBCnak-expected timer = cputime+timeout; ctimer = cputime + 2000 %integerfn cancel queued for(%integer context) %integer rc %bytename buff %record(ether request fm)%name r r == dequeue(our request mailbox_queue) %result=0 %if r == nil %if r_context=context %start buff == context info(context)_buffer %if buff = APMTEL CANCEL %start requeue(r, our request mailbox_queue) %result=1 %finish %finish rc=cancel queued for(context) requeue(r, our request mailbox_queue) %result=rc %end %cycle c = q test symbol %if c>=0 %start %result=0 %if c=expected %result=c %if c=unexpected %else %result=-1 %if cputime>=timer %finish %if cputime>=ctimer %start ctimer = ctimer + 2000 %result = -2 %if cancel queued for(context)#0 %finish %repeat %end %routine interpret request(%integer context, tag, request bytes, %bytename buffer, %integername response bytes) %bytearray data(0 : ethermax) %bytename data buffer == data(0) %string(255) textual response %integer buffer pos = 0, data bytes = -1, status, rc %ownbytearray page(0:24,0:39)= 'X' (*) %string(255) p1 %ownstring(3) %array channel(0:max contexts) = "1" (*) %byte command %switch op(first FC : last FC) %integerfn aquire page(%string(255) p, %c %bytearrayname page(0:24,0:39), %integer context) %integer i,j,c,t,rc semaphore wait(beeb semaphore) open input(qsart channel,":Q:0") select input(qsart channel) put q0 line(channel(context).".".p) rc = handshake(context, BBCack, 1000) ;!Expect an instantaneous ack... %if rc#0 %start ;! (Try once more if that failed...) put q0 line(channel(context).".".p) rc = handshake(context, BBCack, 1000) %finish !... followed later by either a nak or the ack followed by the page %if rc=0 %start rc = handshake(context, BBCack, 60 * 1000) ;!This is longer than the BBC's timer %if rc=0 %start t=cputime+5000 !Page should not take > 5 seconds to transmit from receipt of ack. %for i=0,1,24 %cycle ;!Full 25 lines %for j=0,1,39 %cycle rc=3 %and ->return %if cputime>t c = read symbol c = c & 16_7F %if 16_A0<= c <=16_FA page(i,j) = c %repeat %repeat rc=0 %finish %finish return: close input select input(tty channel) signal semaphore(beeb semaphore) %result=rc %end %if request bytes < 0 %or buffer = 4 %or buffer = 12 %start ! Cleardown request cleardown context(tag, 0) drop context(context, tag) %if request bytes > 0 response bytes = -1 %return %finish %unless split request(buffer,command,P1,request bytes) %start -> not implemented %finish -> op(command) op(APMTEL START): oplog(context, " STARTING. User = ".zstring(p1)) channel(context)= "1" {BBC 1} textual response = "HI THERE" -> send with newline op(APMTEL PAGE): oplog(context, " ASKING FOR PAGE ".zstring(p1)) rc = aquire page(P1,page,context) %if rc=0 %start ;!Got it OK move(500, page(0,0), buffer); buffer pos=500 %if send response(context, tag, buffer pos) %start move(500, page(12,20), buffer); buffer pos=500 %if send response(context, tag, buffer pos) %start %finish buffer pos = 0 %finish textual response= "PAGE ".p1." SENT OK" -> send with newline %else ;!Some failure oplog(context, "Page request fails . ".itos(rc,-1)) textual response = "PAGE AQUISITION FAILS ".itos(rc,-1); status = -1 -> send with newline %finish op(APMTEL CHAN): oplog(context, "CHANNEL ".p1." SELECTED") textual response = "OK" channel(context) = p1 -> send with newline op(APMTEL CANCEL): oplog(context, " cancelled request") textual response = "OK" -> send with newline op(APMTEL STOP): oplog(context, " stopped ") cleardown context(context, 0); textual response = "Bye" %if p1="!" %start ;!Diagnostic halt %signal 15,1 %elseif p1="*" ;!Diagnostic restart %signal 15,2 %finish -> send with newline op(*): not implemented: textual response = "Pardon ?" send with newline: copy string(textual response,buffer, buffer pos) buffer [buffer pos] = NL; response bytes = buffer pos + 1 %return send textual error: %if status < 0 %start copy string("-? ", buffer, buffer pos) %else copy string("-> ", buffer, buffer pos) %finish -> send with newline %end %integerfn interpreter process %record(context fm)%name p %integer bytes, context, tag, status %bytearray x(0 : 3) %ownrecord(semaphore fm) disaster = 0 %record(poa fm)%name process %integer i %on 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 %start ! Last-chance disaster-trap process == POA printstring("APMTEL->unexpected event "); write(process_event, 0) space; write(process_event sub, 0); space; phex(process_event extra) space; printstring(process_event message) printstring(" at or about PC "); phex(process_event PC) newline %for i = 0, 1, 15 %cycle phex(process_event r(i)); space newline %if i & 7 = 7 %repeat %result=-1 %if process_event#15 %or process_event sub=1 ;!Stop %result=0 ;!Reset %finish select input(0) select output(0) setup semaphore(disaster) mark %if POA_heap_level = 1 %cycle receive next request(context, tag, bytes, status) %if 0 < context <= max contexts %and status = ether success %start p == context info(context) %if p_buffer = 4 %or p_buffer = 12 %start interpret request(context, tag, bytes, p_buffer, bytes) ! Don't start another receive operation. %else interpret request(context, tag, bytes, p_buffer, bytes) %if bytes >= 0 %and send response(context, tag, bytes) %start; %finish start receive(context, tag) %finish %else interpret request(context, tag, -1, x(0), bytes) %c %if 0 < context <= max contexts ! Don't start another receive operation. It'll be done for ! us when the (re)connection is completed. %finish %repeat %end %record(p0 buffer fm)%name p0 buffer %record(mailbox fm) our p0 mailbox = 0 %record(semaphore fm) our p0 semaphore = 0 %record(process fm)%name created %record(context fm)%name p %ownrecord(semaphore fm) disaster = 0 %record(poa fm)%name process %integer i, rc %label x %on 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 %start ! Last-chance disaster-trap process == POA printstring("APMTEL (Port 0): unexpected event "); write(process_event, 0) space; write(process_event sub, 0); space; phex(process_event extra) space; printstring(process_event message) printstring(" at or about PC "); phex(process_event PC) newline %for i = 0, 1, 15 %cycle phex(process_event r(i)); space newline %if i & 7 = 7 %repeat %stop %finish ! !Initialise the QSART input channel. ! open output(qsart channel,":Q:0") open input(qsart channel,":Q:0") select input(qsart channel) select output(0) qsart == record(dev add) i=0 %cycle put q0 line("+") rc=handshake(-1, BBCnak, 2000) oplog(-1, "Polling Teletext receiver") i=i+1 %repeatuntil rc=0 %or i=5 %if rc=0 %then oplog(-1, "OK.") %else %c oplog(-1, "*** Warning: Teletext receiver not responding") select input(0) setup semaphore(disaster) %if FS lookup(ether mailbox name, i) %start ether request mailbox == record(i) %else oplog(-1, "No ether mailbox??") %stop %finish setup semaphore(our p0 semaphore) setup semaphore(beeb semaphore) signal semaphore(beeb semaphore); ! Prevent wait setup mailbox(our p0 mailbox, our p0 semaphore) FS insert(facility name, addr(our p0 mailbox)) setup semaphore(our request semaphore) setup mailbox(our request mailbox, our request semaphore) mark %if POA_heap_level = 1 context info(i)_buffer == byteinteger(global heap get(ether max + 16)) %c %for i = 1, 1, max contexts FS insert(context table name, addr(context info(1))) F external redirect off = 1 F old style handling = 1 F no explicit device = 1 F enable dot dot = 1 ! ! Start the interpreter processes here.... ! created == create process(process size, addr(x), 6, nil) %c %for i = 1, 1, processes total restart: created == nil; ! Don't want junk diagnostics oplog(-1, version) oplog(-1, "Started with ".itos(free store, 0)." free store listening .") ! Now wait for port 0 messages and act on them %cycle p0 buffer == receive message(our p0 mailbox) %if fsys state == nil %start %if FS lookup(fsys state name, i) %start fsys state == integer(i) %if fsys state & 1 = 0 %start ! Local file system isn't running yet p0 buffer_reply text = "-? Local filesystem not initialised" . SNL -> reply %finish %else p0 buffer_reply text = "-? No local filesystem??" -> reply %finish %else %if fsys state & 1 = 0 ! Local file system isn't running yet p0 buffer_reply text = "-? Local filesystem not initialised" . SNL -> reply %finish !First have a look to see if we already know about this ! client -- we'll have to clear it down if we find one. %for i = 1, 1, max contexts %cycle p == context info(i) %if p_remote address = p0 buffer_ra %c %and p_remote port = p0 buffer_rp %start oplog(i, "Client already known ") drop context(i, p_tag) %exit %finish %repeat ! Now get a new port for the client and make the initial read. i = initialise client comms(p0 buffer_ra, p0 buffer_rp) %if i > 0 %then p0 buffer_reply text = to string(i + '0') . SNL %c %else p0 buffer_reply text = "-? No free contexts" . SNL reply: send message(p0 buffer, p0 buffer_system part_reply, nil) %repeat x: i=interpreter process %if i=0 %start selectinput(0); selectoutput(0) -> total restart %finish %end %of %program