         TITLE 'MAGTAPE TCP SERVER'
*++
*
* -*-ASMH-*-
*
* PROGRAM TO ACCEPT CONNECTIONS FROM REMOTE CLIENTS AND WRITE THEIR
* DATA ON AN MTS MAGTAPE DRIVE.  THE PROBLEM WITH DOING THIS USING $FTP
* (ASIDE FROM BLOCKING PROBLEMS, $FTP ALWAYS WRITES LITTLE 256-BYTE
* RECORDS IN "TYPE I" MODE) IS THAT FTP OPENS A SEPARATE CONNECTION FOR
* TRANSFERRING EACH INDIVIDUAL FILE.  MTS'S TCP INTERFACE STICKS THE
* USER WITH WAITING FOR OUR "FIN" TO BE ACKNOWLEDGED BY THE REMOTE
* SYSTEM BEFORE IT WILL UNBLOCK THE USER JOB, AND THERE SEEMS TO BE
* ADD'L DELAY BEYOND THAT TOO.  SO THE SYSTEM SPENDS MOST OF ITS TIME
* WAITING FOR CLOSES, AND IT TAKES HOURS TO TRANSFER A FEW HUNDRED
* FILES, EVEN IF THEY ALL FIT ON ONE TAPE.
*
* SO THE IDEA WITH THIS SIMPLE PROGRAM IS, ALL MAGTAPE I/O IS DONE
* THROUGH A SINGLE TCP CONNECTION FROM THE REMOTE SYSTEM.  EACH COMMAND
* FROM THE REMOTE SYSTEM STARTS WITH A 16-BIT HALFWORD (IBM 370 BYTE
* ORDER, MSB FIRST) AS FOLLOWS:
*
*  0     WRITE TAPE MARK
*  1     READ A RECORD
*  2     CLOSE CONNECTION
*  3     REWIND
*  4     BACKWARD SPACE FILE
*  5     BACKWARD SPACE RECORD
*  6     SPACE TO LEOT (BETWEEN THE TWO TAPE MARKS)
*  7     FORWARD SPACE FILE
*  8     FORWARD SPACE RECORD
*  9-17  UNDEFINED
*  >=18  WRITE A RECORD, COMMAND CODE IS LENGTH
*
* (RECORD LENGTHS .LT.18 ARE PROHIBITED BY INDUSTRY STANDARD HARDWARE.)
*
* ALL COMMANDS RETURN A ONE-BYTE STATUS CODE, WHICH IS X'00' FOR
* SUCCESS AND X'FF' FOR FAILURE.  IN THE CASE OF COMMAND 2 (READ A
*
* RECORD), THIS CODE (IF ZERO) IS FOLLOWED BY A 16-BIT LENGTH (MSB
* FIRST) AND A DATA RECORD.  IF THE LENGTH IS X'0000' THEN A TAPE MARK
* WAS READ AND NO DATA FOLLOW.
*
* NOTE THAT THE FORWARD/BACKWARD SPACE COMMANDS DON'T TAKE AN ARGUMENT,
* IF YOU WANT TO MOVE BY MORE THAN ONE RECORD OR FILE YOU'LL HAVE TO
* SEND MULTIPLE COMMANDS.  ALSO LIMITING READ RECORD SIZE IS THE
* CLIENT'S PROBLEM, YOU'LL HAVE TO READ THE LENGTH FIRST AND DECIDE HOW
* MUCH DATA TO KEEP AND HOW MUCH TO DISCARD, IF YOU CAN'T HANDLE
* ALLOCATING A 32767-BYTE BUFFER (WHICH IS THE MOST THAT MTS WILL EVER
* READ IN A RECORD).
*
* TAPE SHOULD BE ATTACHED TO UNIT 1.
*
* AUG 14/93    JMBW    CREATED (WRITE ONLY).
* MAR 12/95    JMBW    READ, $CONTROL, RETURN CODE.
*
*--
         SPACE
*
TT       EQU   0                  ;DEFINE REGISTERS
A        EQU   1
B        EQU   2
C        EQU   3
D        EQU   4
E        EQU   5
F        EQU   6
*
         MACRO
&LAB     JSYS  &DEST,&ARGS,&ERR   ;JUMP TO SYSTEM
&LAB     L     15,=V(&DEST)
         AIF   ('&ARGS' EQ '').NOARGS
         LA    1,&ARGS
.NOARGS  BASR  14,15
         AIF   ('&ERR' EQ '').NOPUNT
         LTR   15,15
         BNZ   &ERR
.NOPUNT  MEND
*
* $MOUNT STRING/ARG LIST
* IF FOO IS "MOUNT" ARG LIST,
* RFOO IS "RELEASE" ARG LIST,
* AND PFOO IS PSEUDO DEVICE NAME (FOR "GETFD")
         MACRO
&LAB     MOU   &STR
         LCLC  &S
&S       SETC  '&STR'(2,K'&STR-2)
&LAB     DC    A(ONE,C&LAB,L&LAB),X'80',AL3(MOPT)
C&LAB    DC    C'&S '             ;blank for GETFD
L&LAB    DC    Y(L'C&LAB-1)       ;not included in count
R&LAB    DC    A(P&LAB,M&LAB,RELFLG) ;RELEASE arg list
P&LAB    EQU   C&LAB+4            ;PDN
M&LAB    DC    A(L'C&LAB-5)       ;PDN length
         MEND
*
* $CONTROL STRING/ARG LIST
         MACRO
&LAB     CONT  &STR,&FDUB
         LCLA  &LEN
&LEN     SETA  K'&STR-2
&LAB     DC    A(*+18,*+12,&FDUB,CTAREA),Y(&LEN),C&STR
         MEND
*
* ENTRY POINT
*
TAPESRV  CSECT
         ENTER 12,SA=REGS
* ALLOCATE A TCP PORT
         JSYS  MOUNT,NET,PUNT     ;MOUNT NET CONNECTION
         JSYS  GETFD,PNET         ;GET FDUB PTR
         ST    TT,NETFD           ;SAVE IT
         JSYS  CONTROL,ACCEPT,PUNT ;LISTEN
         MVC   BUF(14),=C'SENSE "SOCKET"' ;COPY SENSE CMD
* DISPLAY PORT # SO THEY CAN %FLIP AND CONNECT FROM UNIX SIDE
         JSYS  CONTROL,=A(BUF,LENSKT,NETFD,0),PUNT ;GET SOCK PARMS
         XR    A,A                ;INIT TO 0
         ICM   A,3,BUF            ;GET LOCAL PORT #
         LA    B,BUF+100          ;PT OFF INTO BUFFER
         LR    D,B                ;SAVE
         BAL   10,DECOUT          ;CONVERT #
         S     B,=F'11'           ;BACK UP FOR TEXT
         MVC   0(11,B),=C' TCP PORT #' ;INSERT IT
         ST    B,SPLIST           ;SET ADDR
         SR    D,B                ;FIND LENGTH
         STH   D,LEN
         JSYS  SPRINT,SPLIST
* LISTEN ON TCP PORT
         JSYS  CONTROL,WAIT,PUNT  ;WAIT FOR CALL
*
* GET NEXT CMD
*
LOOP     LA    C,2                ;GET 2 BYTES
         BAL   10,RDATA
          B    PUNT
         XR    C,C                ;CLEAR OUT LH OF C
         ICM   C,3,BUF            ;GET HALFWORD COMMAND OR RECLEN
         LR    A,C                ;MAKE A COPY
         SLL   A,2                ;*4
         CL    C,=F'18'           ;CMD.LT.18?
         BLT   DISPAT(A)          ;DISPATCH IF SO
*+
*
* WRITE RECORD
*
*-
         STH   C,RECL             ;SAVE
         BAL   10,RDATA           ;AND READ THE RECORD
          B    PUNT
         JSYS  WRITE,TIO,LOSE     ;WRITE TO UNIT 1
         B     WIN
*
DISPAT   B     TMARK              ;0 WRITE TAPE MARK
         B     RDREC              ;1 READ A RECORD
         B     CLSCX              ;2 CLOSE CONNECTION
         B     REWND              ;3 REWIND TO BOT
         B     BKSPF              ;4 BACKSPACE FILE
         B     BKSPR              ;5 BACKSPACE RECORD
         B     SPEOT              ;6 SPACE TO LEOT
         B     FWSPF              ;7 FORWARD SPACE FILE
         B     FWSPR              ;8 FORWARD SPACE RECORD
         B     LOSE               ;9 UNDEFINED
         B     LOSE               ;10  .
         B     LOSE               ;11  .
         B     LOSE               ;12  .
         B     LOSE               ;13  .
         B     LOSE               ;14  .
         B     LOSE               ;15  .
         B     LOSE               ;16  .
         B     LOSE               ;17  .
*
         EJECT
*+
*
* WRITE TAPE MARK
*
*-
TMARK    JSYS  CONTROL,WTM,LOSE   ;WRITE TAPE MARK
         B     WIN
*+
*
* READ A RECORD.
*
*-
RDREC    JSYS  READ,TIO,RDREC1    ;READ FROM TAPE
         BAL   10,SENDRC          ;SEND SUCCESSFUL RC
         JSYS  WRITE,=A(RECL,H2,ZERO,DUMMY,NETFD),PUNT ;WRITE LEN
         JSYS  WRITE,=A(BUF,RECL,ZERO,DUMMY,NETFD),PUNT ;WRITE REC
         B     LOOP
RDREC1   C     15,EOF             ;EOF?
         BNE   LOSE               ;NO, PUNT
         BAL   10,SENDRC          ;SEND SUCCESSFUL RC
         JSYS  WRITE,=A(ZERO,H2,ZERO,DUMMY,NETFD),PUNT ;WRITE LEN=0
         B     LOOP
*+
*
* CLOSE CONNECTION.
*
*-
CLSCX    BAL   10,SENDRC          ;SEND HAPPY RC
         L     TT,NETFD           ;GET NET FDUB PTR
         JSYS  FREEFD
         JSYS  RELEASE,RNET       ;$RELEASE *NET*
         EXIT
*+
*
* REWIND TAPE TO BOT.
*
*-
REWND    JSYS  CONTROL,REW,LOSE   ;REWIND
         B     WIN
*+
*
* BACKSPACE FILE.
*
*-
BKSPF    JSYS  CONTROL,BSF,LOSE   ;BACKSPACE ONE FILE
         B     WIN
*+
*
* BACKSPACE RECORD.
*
*-
BKSPR    JSYS  CONTROL,BSR,LOSE   ;BACKSPACE ONE RECORD
         B     WIN
*+
*
* SPACE TO LOGICAL END OF TAPE (BETWEEN THE TWO TAPE MARKS).
*
* $CONTROL *MT* POSN=*EOT* WORKS ONLY FOR LABELED TAPES, SO WE'LL HAVE
* TO TOOL IT OUT.
*
*-
SPEOT    JSYS  CONTROL,BSR        ;BACK UP ONE IN CASE ALREADY THERE
SPEOT1   JSYS  READ,TIO,SPEOT2    ;READ A RECORD (AND DROP IT)
         B     SPEOT1             ;LOOP
SPEOT2   C     15,EOF             ;EOF RIGHT?
         BNE   LOSE               ;ERROR IF NOT
         JSYS  READ,TIO           ;TRY TO READ ANOTHER REC
         LTR   15,15              ;DOUBLE EOF?
         BZ    SPEOT1             ;NO, KEEP GOING
         C     15,EOF             ;MAKE SURE IT'S REALLY EOF
         BNE   LOSE               ;ERROR IF NOT
         JSYS  CONTROL,BSR,LOSE   ;YES, BACK UP IN BETWEEN TAPE MARKS
         B     WIN                ;AND WIN
*+
*
* FORWARD SPACE FILE.
*
*-
FWSPF    JSYS  CONTROL,FSF,LOSE   ;SPACE
         B     WIN
*+
*
* FORWARD SPACE RECORD.
*
*-
FWSPR    JSYS  CONTROL,FSR,LOSE   ;SPACE
         B     WIN
*
PUNT     JSYS  SERCOM,=A(NIOERR,NIOLEN,ZERO,DUMMY)
         EXIT
*
WIN      BAL   10,SENDRC          ;SEND SUCCESSFUL RC
         B     LOOP
*
LOSE     MVI   BUF,X'FF'          ;FAILURE
         BAL   10,SENDRC1         ;SEND IT
         B     LOOP
*+
*
* SEND (SUCCESSFUL) RETURN CODE TO CLIENT.
*
*-
SENDRC   MVI   RCODE,X'00'        ;RC=0 (SUCCESS)
SENDRC1  JSYS  WRITE,=A(RCODE,H1,ZERO,DUMMY,NETFD),PUNT ;SEND
         BR    10
*+
*
* READ A BLOCK OF DATA FROM THE SOCKET.
*
* THE SOCKET IS A STREAM SO THE MTS RECORD-ORIENTED FILE HANDLING MAY
* HACK IT UP AT STRANGE BOUNDARIES, WE JUST READ REPEATEDLY UNTIL WE
* GET ENOUGH TO BUILD THE WHOLE BLOCK.  EXCESS IS SAVED FOR NEXT TIME.
*
* C      COUNT OF CHARS TO READ
*
*-
RDATA    LA    B,BUF              ;POINT AT OUTPUT BUF
RDATA1   LH    E,INCTR            ;GET # BYTES IN INPUT BUF
         LTR   E,E                ;ANYTHING?
         BZ    RDATA5             ;NO, GET SOMETHING
         L     D,INPTR            ;YES, GET ADDR
         LR    F,C                ;GET # BYTES WE WANT
         CLR   F,E                ;ARE THAT MANY AVAILABLE?
         BLE   RDATA2
          LR   F,E                ;NO, ONLY ASK FOR WHAT'S THERE
RDATA2   SR    C,F                ;UPDATE COUNTS
         SR    E,F
         LA    TT,0(D,F)          ;GET NEW PTR
         ST    TT,INPTR
         STH   E,INCTR            ;UPDATE CTR TOO
* COPY F BYTES FROM (D) TO (B)
RDATA3   CL    F,=F'256'          ;.LE.256?
         BLE   RDATA4             ;NO
         MVC   0(256,B),0(D)      ;YES, COPY IT
         LA    B,256(B)           ;UPDATE PTRS
         LA    D,256(D)
         S     F,=F'256'          ;AND COUNT
         B     RDATA3             ;TRY AGAIN
RDATA4   BCTR  F,0                ;F-1 FOR MVC
         EX    F,RDMVC            ;COPY WHAT'S LEFT
         LA    B,1(B,F)           ;UPDATE OUTPUT PTR
         LTR   C,C                ;DONE?
         BNZ   RDATA1             ;KEEP TRYING IF NOT
         B     4(10)              ;SKIP RETURN
RDATA5   JSYS  READ,=A(HBUF,LEN,ZERO,DUMMY,NETFD) ;READ MORE
         LTR   15,15              ;ERROR?
         BNZR  10                 ;RETURN W/O SKIPPING IF SO
         L     TT,=A(HBUF)        ;REINIT PTR
         ST    TT,INPTR           ;UPDATE CTR
         LH    TT,LEN             ;AND CTR
         STH   TT,INCTR
         B     RDATA1             ;KEEP GOING
RDMVC    MVC   0(0,B),0(D)        ;COPY LAST CHUNK
*+
*
* CONVERT A NUMBER TO DECIMAL.
*
* A/ NUMBER
* B/ BUF (PREDECREMENT)
* 10/ LINK
*
*-
DECOUT   LA    C,10               ;RADIX
DOUT1    XR    TT,TT              ;ZERO-EXTEND
         DR    TT,C               ;/10
         BCTR  B,0                ;B-1
         STC   TT,0(B)            ;SAVE DIGIT VALUE
         OI    0(B),C'0'          ;CONVERT TO EBC-DICK
         LTR   A,A                ;ANYTHING LEFT?
         BNZ   DOUT1
         BR    10
*
         EJECT
         LTORG
*
ZERO     DC    F'0'
TAPE     DS    0F                 ;TAPE UNIT #
ONE      DS    0F                 ;FULLWORD 1
         DC    H'0'               ;(HIGH HALFWORD=0)
H1       DC    H'1'               ;HALFWORD "1"
H2       DC    H'2'               ;HALFWORD "2"
EOF      DC    F'4'               ;RC FROM "READ" ON EOF
@MAXLEN  DC    XL4'08000000'
MOPT     DC    XL4'E800'          ;NO MSGS OR PROMPTS
RELFLG   DC    XL4'10'            ;NO MSGS
NET      MOU   'TCP *NET*'
LENSKT   DC    H'14'              ;LENGTH OF 'SENSE "SOCKET"' CMD
NIOERR   DC    C' ?TCP I/O ERROR'
NIOLEN   DC    Y(L'NIOERR)
ACCEPT   CONT  'ACCEPT',NETFD     ;$CONTROL *NET* ACCEPT
WAIT     CONT  'WAIT_FOR_CALL',NETFD ;$CONTROL *NET* WAIT_FOR_CALL
*
TIO      DC    A(BUF,RECL,ZERO,DUMMY,TAPE) ;TAPE I/O ARG LIST
*
WTM      CONT  'WTM',TAPE         ;$CONTROL *MT* WTM [1]
REW      CONT  'REW',TAPE         ;$CONTROL *MT* REW
FSR      CONT  'FSR',TAPE         ;$CONTROL *MT* FSR [1]
BSR      CONT  'BSR',TAPE         ;$CONTROL *MT* BSR [1]
FSF      CONT  'FSF',TAPE         ;$CONTROL *MT* FSF [1]
BSF      CONT  'BSF',TAPE         ;$CONTROL *MT* BSF [1]
*
SPLIST   DC    A(0,LEN,ZERO,DUMMY)
INCTR    DC    H'0'               ;COUNT OF BYTES IN HBUF
*
DUMMY    DS    F
NETFD    DS    F                  ;NET FDUB PTR
REGS     DS    18F                ;R13 SAVE AREA
LEN      DS    H                  ;LENGTH FROM I/O CALLS
RECL     DS    H                  ;LENGTH OF CURR REC
INPTR    DS    F                  ;PTR INTO HBUF
CTAREA   DS    27F                ;AREA FOR CONTROL CALLS
RCODE    DS    X                  ;RETURN CODE TO CLIENT
*
         DS    0H                 ;HALFWORD ALIGNED
BUF      DS    32767X             ;GENERAL-PURPOSE BUFFER
*
         DS    0H                 ;HALFWORD ALIGNED
HBUF     DS    32767X             ;HOLDING BUF FOR TCP INPUT
         END   TAPESRV
