%begin {**********************************************************************} {* APMTEL Server - based on P_H2 by GDMR *} {* Andrew Ness 1988 CS4 project *} {* Original version - as demonstrated Jun 88 *} {* Do NOT edit this version of the source *} {**********************************************************************} %externalstring(47) copyright %alias "APMTEL_(C)" = %c "APMTEL (C) 1987, EUCSD Andie Ness" %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 "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' ! unused '_' %constinteger first FC = '@'; ! This one is reserved. %constinteger last FC = 'D' ! 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 %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 zprint symbol(%integer i) %if ' ' <= i <= '~' %start print symbol(i) %else print symbol('?') %finish %end %routine zprintstring(%string(255) s) %integer i, ch %return %if s = "" %for i = 1, 1, length(s) %cycle ch = charno(s, i) %if ' ' <= ch <= '~' %start print symbol(ch) %else print symbol('<') write(ch, 0) print symbol('>') %finish %repeat %end %routine pdate %string(31) d, t unpack date(get datestamp, d, t) printstring(d); space; printstring(t) spaces(2) %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 pdate printstring("APMTEL->?????? *** Starting receive on dud context "); write(context, 0) printstring(" ???"); newline %return %finish p == context info(context) %if p_remote address = 0 %start printstring("APMTEL-> starting receive on closed context ") write(context, 0); printstring(" ??"); newline %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 pdate printstring("APMTEL->sending to closed context ") write(context, 0); newline %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 pdate printstring("APMTEL->(send response): ") printstring(ether errors(reply_status)) newline %false %else %true %finish %finish %else pdate printstring("APMTEL->*** Sending to dud context "); write(context, 0) printstring(" ???"); newline %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 pdate 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 printstring("APMTEL->Drop dud context "); write(context, 0) printstring(" ???"); newline %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 pdate printstring("APMTEL (drop context): ") printstring(ether errors(reply_status)); newline %finish %end %routine copy string(%string(255) s, %bytename buffer, %integername pos) ! **Assume** that there's room! %integer i %return %if s = "" %for i = 1, 1, length(s) %cycle buffer [pos] = charno(s, i) pos = pos + 1 %repeat %end %routine copy bytes(%bytearray from(0:23,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 ! pdate ! printstring("APMTEL->Cleardown close: status ") ! write(status, 0); newline ! %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 %predicate acquire page(%string(255) p, %bytearrayname page(0:23,0:39), %string(*) channel) %integer i,j,c %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 qsart == record(dev add) semaphore wait(beeb semaphore) open input(qsart channel,":Q") select input(qsart channel) put(qsart,'*'); put(qsart,'C'); put(qsart,'H'); put(qsart,charno(channel,1)) put (qsart,13) c = read symbol %if c#'N' %start close input select input(tty channel) signal semaphore(beeb semaphore) %false %finish %for i=1,1,length(p) %cycle put(qsart,charno(p,i)) %repeat put(qsart,13) c = read symbol %if c='N' %start close input select input(tty channel) signal semaphore(beeb semaphore) %false %finish %for i=0,1,23 %cycle %for j=0,1,39 %cycle page(i,j) = read symbol %repeat %repeat close input select input(tty channel) signal semaphore(beeb semaphore) %true %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 %ownbytearray page(0:23,0:39)= 'X' (*) %string(255) p1 %ownstring(3) %array channel(0:max contexts) = "1" (*) %byte command %switch op(first FC : last FC) %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): pdate print string("APMTEL->CLIENT");write(context,1); printstring(" STARTING.") print string(" User = "); zprintstring(p1); newline channel(context)= "1" {BBC 1} textual response = "HI THERE" -> send with newline op(APMTEL PAGE): pdate print string("APMTEL->CLIENT"); write(context,1); print string(" ASKING FOR PAGE ") zprintstring(p1); newline %if acquire page(P1,page,channel(context)) %thenstart buffer pos = 0 copy bytes(page,0,480,buffer, buffer pos) %if send response(context, tag, buffer pos) %start buffer pos = 0 copy bytes(page ,480,480,buffer, buffer pos) %if send response(context, tag, buffer pos) %start %finish buffer pos = 0 %finish textual response= "PAGE ".p1." SENT OK" -> send with newline %finishelsestart print string(" fails . ".snl) textual response = "TIMEOUT EXPIRED"; status = -1 -> send with newline %finish op(APMTEL CHAN): pdate printstring("APMTEL->CHANNEL ".p1." SELECTED BY CLIENT");write(context,2); newline textual response = "OK" channel(context) = p1 -> send with newline op(APMTEL STOP): pdate print string("APMTEL->Client");write(context,1);printstring(" stopped ".snl) cleardown context(context, 0); textual response = "Bye" -> 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 %routine 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 %stop %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 %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") open input(qsart channel,":Q") select input(0) select output(0) setup semaphore(disaster) %if FS lookup(ether mailbox name, i) %start ether request mailbox == record(i) %else printstring("APMTEL->No ether mailbox??") newline %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 created == nil; ! Don't want junk diagnostics pdate printstring("APMTEL->Version 12/05/88".snl) pdate printstring("APMTEL->Started with "); write(free store, 0) printstring(" free store listening ."); newline pdate printstring("APMTEL->NOW WITH ADDED QSART DRIVER ."); newline ! 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 !printstring("Client already known at ") write(i, 0); newline 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: interpreter process %end %of %program