 /* REXX */
 /*********************************************************************/
 /* Licensed Material - Property of IBM                               */
 /* 5639-B92 , 5648-A25 , 5688-197 , 5639-D65 , 5688-235              */
 /* (C) Copyright IBM Corp., 1997, 1998                               */
 /* All rights reserved.                                              */
 /* US Government Users Restricted Rights - Use, duplication or       */
 /* disclosure restricted by GSA ADP Schedule Contract with IBM Corp. */
 /*********************************************************************/
 trace off;
 signal on novalue;
/*---------------------------------------------------------------
 *
 *  Name:  IGYFSERV
 *
 *  Description:
 *
 *    MVS based TSO command server for workstation based VA COBOL.
 *    This is executed under the APPC ASCH scheduler.
 *
 *  Function:
 *
 *    - Accepts APPC convseration from IGYFINIT.
 *    - Receives workstation IP address.
 *    - Creates unique identification token.
 *    - Initializes TCP/IP.
 *    - Sends Host IP address, port and ID token back to IGYFINIT.
 *    - Accepts multiple TCP/IP socket connections from workstation.
 *      - Verifies the identity of workstation.
 *      - Receives and issues TSO command.
 *      - Sends output back to workstation.
 *    - Shuts down when the :SHUTDOWN: command is received.
 *
 *  Operation:
 *
 *    - Parameters:
 *        Keyword:
 *          Timeout=n   - Timeout value in minutes. Default is 1 hour.
 *          Example:  IGYFSERV Timeout=120
 *
 *
 *  Security:
 *
 *    - Runs under the TSO ID that has been propagated
 *      from IGYFINIT via APPC SEC=SAME.
 *
 *  Installation:
 *
 *    - Define this as a TP to APPC.
 *    - Put the EXEC in a library that is included in the
 *      SYSPROC or SYSEXEC in the JCL of
 *      the TP defintion (TPADD command).
 *
 *  Changes:
 *    JCH 970325 Added #INTER as mode name w/o trailing blanks.
 *    JCH 970325 Added workstation token validation.
 *    JCH 970325 Added TIMEOUT= parameter to IGYFSERV call.
 *    BCH 970324 Added translation of < x'40' to blanks.
 *    BCH 970324 Added sockets SELECT to allow for timeout.
 *    BCH 970324 Added verification of workstation IP address.
 *    BCH 970324 Fixed EMAXSOCKETSREACHED problem.
 *
 *
 *  What it doesn't do yet:
 *
 *    - Needs more granularity for logging and tracing messages.
 *    - Doesn't automatically acquire an IP port number.
 *    - Haven't lowered this guys dispatching priority.
 *    - Fix logmsg prefix problem.
 *    - Handle multiple DSNs for SYSTSPRT in TP defintion.
 *
 *---------------------------------------------------------------
 *  IGYFINIT - IGYFSERV APPC Conversation Flow
 *---------------------------------------------------------------
 *
 *     IGYFINIT                       IGYFSERV
 *
 *   Get WS IP
 *   Init conversation
 *   Allocate
 *   Confirm      --------------->
 *     .                            Accept Conversation
 *     .                            Receive (Looking for Confirm)
 *     .          <---------------  Confirmed
 *   Send data                        .
 *     (WS IP address)                .
 *   Prepare to Rec                   .
 *     .            ------------->    .
 *     .                            Receive (WS IP address)
 *     .                            Receive (Send state)
 *     .                          --- Initialize TCP/IP server ---
 *     .                            Send data (Host IP, port, token)
 *     .                            Deallocate conversation
 *     .          <---------------    .
 *   Receive (Host IP, port)          .
 *   Receive (confirm)                .
 *   Confirmed    --------------->    .
 *
 *                                --- Receive commands from
 *                                    workstation and return results
 *                                    via TCP/IP
 *
 *
 *---------------------------------------------------------------*/
 
trc=1                   /* 1=enable trace, 0=disable trace           */
 
/*---------------------------------------------------------------
 * Set standard CPIC pseudonyms
 *---------------------------------------------------------------*/
 call CPIC_Const
 
 CALL LOGMSG 'OUTPUT from IGYFSERV'
 
/*---------------------------------------------------------------
 * parse input arguments
 *---------------------------------------------------------------*/
parse upper arg args
 
default_timemin=60              /* default timeout in minutes  */
if pos('TIMEOUT',args)<>0 then
  do
    parse var args . 'TIMEOUT' rest
    rest = strip(rest,'l')
    if substr(rest,1,1) = '=' then
      do
        parse var rest '=' timemin .
      end
    if substr(rest,1,1)<>'=' | datatype(timemin,'w')<>1 then
      do
        say  'TIMEOUT argument is invalid:' args
        say  'Default timeout of' default_timemin 'minutes is used'
        timeout = default_timemin*60
      end
    else
      timeout = timemin*60      /* Timeout value in seconds    */
  end
else
  do
    timeout=default_timemin*60  /* Timeout value in seconds    */
  end
 
/*---------------------------------------------------------------
 *
 *  Initialization
 *
 *---------------------------------------------------------------*/
 
      Conv_ID                = '00000000'
      Request_To_Send_Received_Value  = cm_req_to_send_not_received
 
 
      requested_length       = 255
      Conversation_Type      = cm_mapped_conversation
 
      mode_name              = '#INTER'
      Mode_Name_Length       = length(mode_name)
 
      Partner_LU_Name        = '        '
      Partner_LU_Name_Length = length(partner_lu_name)
      /* When Partner_LU_Name is left blank, the partner TP
         runs on the LU specified in side information. */
 
      Sync_Level             = cm_confirm
      Return_Code            = 99999
 
     Prepare_To_Receive_Type  = CM_prep_to_receive_sync_level;
     Receive_Type             = CM_receive_and_wait;
     Deallocate_Type          = CM_DEALLOCATE_CONFIRM
 
     EOT='00'x
     CR='0D'x
     LF='25'x
     OK=1
     MsgPfx = ''
     VAC_Init_Result=-1
     Max_Read_Errors=5
     Max_Write_Errors=5
     Max_Accept_Errors=3
 
/*---------------------------------------------------------------
 *
 *   Mainline
 *
 *---------------------------------------------------------------*/
    call Accept_Conv;               /*  Accept conversation      */
 
/*---------------------------------------------------------------
 * Get conversation type
 *---------------------------------------------------------------*/
    if OK then
      call Ext_Conv_Type;
 
/*---------------------------------------------------------------
 * Get conversation mode
 *---------------------------------------------------------------*/
    if OK then
      call Ext_Mode_Name;
 
/*---------------------------------------------------------------
 * Get partner LU name
 *---------------------------------------------------------------*/
    if OK then
      call Ext_Part_LU_Name;
 
/*---------------------------------------------------------------
 * Get sync level
 *---------------------------------------------------------------*/
    if OK then
      call Ext_Sync_Level;
 
/*---------------------------------------------------------------
 * Set receive type
 *---------------------------------------------------------------*/
    if OK then
      call Set_Rec_Type;
 
/*---------------------------------------------------------------
 * Look for a CONFIRM request
 *---------------------------------------------------------------*/
    if OK then
      call Receive_Confirm
 
/*---------------------------------------------------------------
 * Return a positive confirmation
 *---------------------------------------------------------------*/
    if OK then
      call Confirmed
 
/*---------------------------------------------------------------
 * Receive workstation IP address from client
 *---------------------------------------------------------------*/
    if OK then
      call Receive
 
/*---------------------------------------------------------------
 * Verify IP syntax
 *---------------------------------------------------------------*/
    if OK then
      call Chk_IP_syntax buffer
 
/*---------------------------------------------------------------
 * Look for a SEND state status
 * This indicates that the partner has gone to a RECEIVE state
 *
 * Note: This explicit receive of the send state is only required
 *   if no status was received on the previous receive. Data and
 *   the status may or may not come in on the same receive.
 *---------------------------------------------------------------*/
    if OK & status_received=CM_NO_STATUS_RECEIVED then
      call Receive_Send_State
 
/*---------------------------------------------------------------
 *   Create unique token
 *---------------------------------------------------------------*/
    if OK then
      call Create_Token
 
/*---------------------------------------------------------------
 * Initiate TCP/IP Server Functions
 *---------------------------------------------------------------*/
    if OK then
      do
        MsgPfx = 'TCP: '
        call VAC_Init
        VAC_Init_Result = result
 
        if VAC_Init_Result=0 then
          Buffer = ":IP: 0" IPAddress port token
        else
          Buffer = ":IP: 8" VAC_Err_Msg
 
        msgPfx = ''
      end
 
 
/*---------------------------------------------------------------
 * Send Host IP info or error info
 *---------------------------------------------------------------*/
    if VAC_Init_Result >= 0 then
      call Send_data
 
/*---------------------------------------------------------------
 * Set deallocation type to confirm
 *---------------------------------------------------------------*/
    if VAC_Init_Result >= 0 then
      call Set_Dealloc_Type
 
/*---------------------------------------------------------------
 * Deallocate conversation
 *---------------------------------------------------------------*/
    if VAC_Init_Result >= 0 then
      call Deallocate
 
/*---------------------------------------------------------------
 * Handle TSO commands via TCP/IP
 *---------------------------------------------------------------*/
    if OK & VAC_Init_Result = 0 then
      do
        MsgPfx = 'TCP: '
        call VAC_Serv
      end
 
exit 0
 
/*---------------------------------------------------------------
 *
 * Accept Conversation
 *
 *---------------------------------------------------------------*/
 Accept_Conv: PROCEDURE,
 EXPOSE conv_id return_code cm_ok ok trc
 ADDRESS CPICOMM
    'CMACCP CONV_ID RETURN_CODE'    /*  Accept Conversation          */
 
    CALL LOGMSG 'APPC: CMACCP return_code is 'return_code
 
    if Return_Code <> CM_OK then    /*  if Accept was unsuccesful    */
      do                            /*  Log message and return code */
        CALL LOGMSG ' Accept Conversation failed'
        call CheckRC return_code
        ok=0
      end
    ELSE                            /*  operation was Successful     */
     do
       CALL LOGMSG ' Accept Conversation succeeded'
       CALL LOGMSG ' Conversation ID is 'C2X(conv_id)
     end
 
 return
 
/*---------------------------------------------------------------
 *
 *   Extract Conversation Type
 *
 *---------------------------------------------------------------*/
 Ext_Conv_Type: PROCEDURE,
 EXPOSE conv_id conversation_type return_code cm_mapped_conversation,
        cm_ok error ok trc
 ADDRESS CPICOMM
     'CMECT CONV_ID CONVERSATION_TYPE RETURN_CODE'
                                    /*  Extract Conversation Type    */
 
    CALL LOGMSG 'APPC: EXTRACT_CONV return code is 'return_code
 
    if Conversation_Type <> CM_mapped_conversation then
      do;
        CALL LOGMSG ' Invalid Conversation Type extracted'
        ok=0
      end;
 
    if Return_Code <> CM_OK then    /*  if Extract was bad           */
      do;                           /*  Send message and return code */
        CALL LOGMSG ' Extract Conversation Type failed'
        call CheckRC return_code
        ok=0
      end;
    ELSE                            /*  operation was Successful     */
     CALL LOGMSG ' Extract Conversation Type Succeeded'
 
 return;
 
/*---------------------------------------------------------------
 *
 *   Extract Mode Name
 *
 *---------------------------------------------------------------*/
 Ext_Mode_Name: PROCEDURE,
 EXPOSE conv_id mode_name mode_name_length return_code,
        error cm_ok ok trc
 ADDRESS CPICOMM
    'CMEMN CONV_ID MODE_NAME MODE_NAME_LENGTH RETURN_CODE'
                                    /*  Extract Mode Name            */
    CALL LOGMSG 'APPC: EXTRACT MODE return code is 'return_code
    CALL LOGMSG ' MODE is' Mode_Name
 
    if Return_Code <> CM_OK then    /*  if Extract was bad           */
      do;                           /*  Send message and return code */
        CALL LOGMSG ' Extract Mode Name failed'
        call CheckRC return_code
        ok=0
      end;
    ELSE                            /*  operation was Successful     */
      CALL LOGMSG ' Extract Mode Name Succeeded'
 
 return;
 
/*---------------------------------------------------------------
 *
 *   Extract Partner LU Name
 *
 *---------------------------------------------------------------*/
 Ext_Part_LU_Name: PROCEDURE,
 EXPOSE conv_id partner_lu_name partner_lu_length return_code,
        error cm_ok ok trc
 ADDRESS CPICOMM
    'CMEPLN CONV_ID PARTNER_LU_NAME PARTNER_LU_LENGTH RETURN_CODE'
                                    /*  Extract Partner LU Name      */
 
 
    if Return_Code <> CM_OK then    /*  if Extract was
                                        unsuccessful                 */
      do;                           /*  Send message and return code */
        CALL LOGMSG 'APPC: Extract Partner LU Name failed'
        call CheckRC return_code
        ok=0
      end;
    ELSE                            /*  operation was Successful     */
      do
        CALL LOGMSG 'APPC: Extract Partner LU Name Succeeded'
        CALL LOGMSG ' Partner LU is 'partner_LU_name
        CALL LOGMSG ' Partner LU length is 'partner_LU_length
      end
 
 return;
 
/*---------------------------------------------------------------
 *
 *   Extract Sync Level
 *
 *---------------------------------------------------------------*/
 Ext_Sync_Level: PROCEDURE,
 EXPOSE conv_id sync_level return_code cm_confirm error cm_ok ok,
   trc
 ADDRESS CPICOMM
    'CMESL CONV_ID SYNC_LEVEL RETURN_CODE'
                                    /*  Extract Sync Level           */
 
    if Sync_Level <> CM_confirm then
      do;                           /*  Send message                 */
        CALL LOGMSG 'APPC: Invalid Sync Level extracted'
        ok=0
      end;
 
    if Return_Code <> CM_OK then    /*  if Extract was
                                        unsuccessful                 */
      do;                           /*  Send message and return code */
        CALL LOGMSG 'APPC: Extract Sync Level failed'
        call CheckRC return_code
        ok=0
      end;
    ELSE                            /*  operation was Successful     */
      CALL LOGMSG 'APPC: Extract Sync Level Succeeded'
 
 return;
 
/*---------------------------------------------------------------
 *
 *   Set Receive Type
 *
 *---------------------------------------------------------------*/
 Set_Rec_Type: PROCEDURE,
 EXPOSE conv_id receive_type return_code cm_ok ok trc
 ADDRESS CPICOMM
 
    'CMSRT CONV_ID RECEIVE_TYPE RETURN_CODE'
                                    /*  Set Receive Type             */
 
    if Return_Code <> CM_OK then    /*  if set receive type was
                                        unsuccessful                 */
      do;                           /*  Send message and return code */
        CALL LOGMSG 'APPC: Set Receive type failed'
        call CheckRC return_code
        ok=0
      end;
    ELSE                            /*  operation was Successful     */
     CALL LOGMSG 'APPC: Set Receive Type succeeded'
 
 return;
 
/*---------------------------------------------------------------
 *
 *   Receive Data
 *
 *---------------------------------------------------------------*/
 Receive: PROCEDURE,
 EXPOSE conv_id buffer requested_length data_received received_length,
        status_received request_to_send_received_value,
        return_code cm_ok ok trc
 
 ADDRESS CPICOMM
    'CMRCV  CONV_ID BUFFER REQUESTED_LENGTH DATA_RECEIVED',
            'RECEIVED_LENGTH STATUS_RECEIVED',
            'REQUEST_TO_SEND_RECEIVED_VALUE RETURN_CODE'
                                    /*  Receive                      */
 
     call logmsg 'APPC: Receive data'
     call logmsg ' RCV return_code = 'return_code
     call logmsg ' RCV data_received= 'data_received
     call logmsg ' RCV received_length=' received_length
     call logmsg ' RCV status_received= 'status_received
     call logmsg ' RCV req_to_send=',
       request_to_send_received_value
 
    if Return_Code <> CM_OK then    /*  if Receive was unsuccessful  */
      do;                           /*  Send message and return code */
        CALL LOGMSG ' Receive failed'
        call CheckRC return_code
        ok=0
      end;
    ELSE                            /*  operation was successful     */
      do
        buffer = substr(buffer,1,received_length)
        CALL LOGMSG ' Receive succeeded'
      end
 
 return;
 
/*---------------------------------------------------------------
 *
 *   Receive expected confirmation request
 *
 *---------------------------------------------------------------*/
 
 Receive_Confirm: PROCEDURE,
 EXPOSE conv_id buffer requested_length data_received received_length,
        status_received request_to_send_received_value return_code,
        cm_ok cm_deallocated_normal cm_request_to_send_not_received,
        cm_no_status_received cm_complete_data_received,
        cm_send_received ok cm_confirm_received,
        cm_confirm_dealloc_received trc
 ADDRESS CPICOMM
    'CMRCV CONV_ID BUFFER REQUESTED_LENGTH DATA_RECEIVED',
          'RECEIVED_LENGTH STATUS_RECEIVED',
          'REQUEST_TO_SEND_RECEIVED_VALUE RETURN_CODE'
 
    call logmsg 'APPC: Receive Confirm procedure'
    call logmsg ' RCV return_code = 'return_code
    call logmsg ' RCV data_received= 'data_received
    call logmsg ' RCV status_received= 'status_received
    call logmsg ' RCV req_to_send=',
      request_to_send_received_value
 
    SELECT
      WHEN (Return_Code = CM_OK) then
        call logmsg ' RCV Inbound Receive confirm succeeded'
      WHEN (Return_Code = CM_deallocated_normal) then
        do
          call logmsg ' RCV Inbound Receive succeeded'
          ok=0
        end
      OTHERWISE
        do
          call logmsg ' RCV Inbound Receive failed'
          call CheckRC return_code
          ok=0
        end
    end
 
    if Return_code <> cm_deallocated_normal & ok=1 then
     /*  if the TP is deallocated don't do the following checks    */
       do;
         /*  Make sure a CONFIRM was received      */
          if Status_Received <> CM_CONFIRM_RECEIVED &,
             Status_Received <> CM_CONFIRM_DEALLOC_RECEIVED then
            do
              call logmsg ' Expected CONFIRM request not received'
              ok=0
            end
       end;
 
 return;
 
/*---------------------------------------------------------------
 *
 *   Receive expected SEND state.
 *   This indicates that the partner has entered the receive state.
 *
 *---------------------------------------------------------------*/
 
 Receive_Send_State: PROCEDURE,
 EXPOSE conv_id buffer requested_length data_received received_length,
        status_received request_to_send_received_value return_code,
        cm_ok cm_deallocated_normal cm_request_to_send_not_received,
        cm_no_status_received cm_complete_data_received,
        cm_send_received ok trc
 ADDRESS CPICOMM
    'CMRCV CONV_ID BUFFER REQUESTED_LENGTH DATA_RECEIVED',
          'RECEIVED_LENGTH STATUS_RECEIVED',
          'REQUEST_TO_SEND_RECEIVED_VALUE RETURN_CODE'
 
    call logmsg 'APPC: Receive Send State procedure'
    call logmsg ' RCV return_code = 'return_code
    call logmsg ' RCV data_received= 'data_received
    call logmsg ' RCV status_received= 'status_received
    call logmsg ' RCV req_to_send=',
      request_to_send_received_value
 
    SELECT
      WHEN (Return_Code = CM_OK) then
        call logmsg ' RCV Inbound Receive succeeded'
      WHEN (Return_Code = CM_deallocated_normal) then
        do
          call logmsg ' RCV Inbound Receive succeeded'
          ok=0
        end
      OTHERWISE
        do
          call logmsg ' RCV Inbound Receive failed'
          ok=0
        end
    end
 
    if Return_code <> cm_deallocated_normal & ok=1 then
     /*  if the TP is deallocated don't do the following checks    */
       do;
         /*  Make sure a Send State was received      */
          if Status_Received <> CM_SEND_RECEIVED  then
            do
              call logmsg ' Expected SEND state not received'
              ok=0
            end
       end;
 
 return;
/* *******************************************************************/
/*                                                                   */
/*   Request to Send                                                 */
/*                                                                   */
/* *******************************************************************/
 
 Req_To_Send: PROCEDURE,
 EXPOSE conv_id return_code cm_ok ok trc
 ADDRESS CPICOMM
 
    'CMRTS CONV_ID RETURN_CODE'
                                    /*  Request to Send              */
 
    if Return_Code <> CM_OK then    /*  if Request to Send was
                                        unsuccessful                 */
      do;                           /*  Send message and return code */
        SAY ' Request to Send failed'
        call CheckRC return_code
      end;
    ELSE                            /*  operation was Successful     */
     SAY ' Request to Send succeeded'
 
 return;
 
/*---------------------------------------------------------------
 *
 *   Confirm - request confirmation from partner
 *
 *---------------------------------------------------------------*/
 Confirm: PROCEDURE,
 EXPOSE conv_id request_to_send_received_value return_code cm_ok ok,
   trc
 ADDRESS CPICOMM
 
    'CMCFM CONV_ID REQUEST_TO_SEND_RECEIVED_VALUE RETURN_CODE'
                                    /*  Confirm                      */
 
    if Return_Code <> CM_OK then    /*  if confirmation was bad      */
      do;                           /*  Send message and return code */
        CALL LOGMSG 'APPC: Confirmation failed'
        call CheckRC return_code
        ok=0
      end;
    ELSE                            /*  operation was Successful     */
      do
        CALL LOGMSG 'APPC: Confirm succeeded'
        CALL LOGMSG ' Req to send recd value is ',
          request_to_send_received_value
      end
 
 return;
 
/*---------------------------------------------------------------
 *
 *   Confirmation - positively respond to CONFIRM request
 *
 *---------------------------------------------------------------*/
 Confirmed: PROCEDURE,
 EXPOSE conv_id return_code cm_ok ok trc
 
 ADDRESS CPICOMM
    'CMCFMD CONV_ID RETURN_CODE'    /*  Confirm                      */
 
    if Return_Code <> CM_OK then    /*  if confirmation was
                                        unsuccessful                 */
      do;                           /*  Send message and return code */
        CALL LOGMSG 'APPC: CONFIRMED failed'
        call CheckRC return_code
        ok=0
      end;
    ELSE                            /*  operation was successful     */
     CALL LOGMSG 'APPC: CONFIRMED succeeded'
 
 return;
 
/*---------------------------------------------------------------
 *
 *   Send Data
 *
 *---------------------------------------------------------------*/
 Send_Data: procedure,
 EXPOSE conv_id buffer send_length request_to_send_received_value,
        return_code cm_ok ok trc
 
 send_length = length(buffer)
 ADDRESS CPICOMM
    'CMSEND CONV_ID BUFFER SEND_LENGTH',
            'REQUEST_TO_SEND_RECEIVED_VALUE RETURN_CODE'
                                    /*  Send Data                    */
 
    CALL LOGMSG 'APPC: SEND_DATA return_code = 'return_code;
    CALL LOGMSG ' request_to_send_received = ',
        request_to_send_received_value;
 
    if Return_Code <> CM_OK then    /*  if Send Data was bad         */
      do;                           /*  Send message and return code */
        CALL LOGMSG ' Send Data failed';
        CALL CheckRC return_code
        ok=0
      end;
    ELSE                            /*  operation was successful     */
      do;
        CALL LOGMSG ' Send Data succeeded';
      end;
 
 return;
 
/*---------------------------------------------------------------
 *
 *   Extract Conversation State
 *
 *---------------------------------------------------------------*/
 Ext_Conv_State: procedure,
 EXPOSE conv_id conv_state return_code OK CM_OK ok trc
 
 ADDRESS CPICOMM
    'CMECS CONV_ID CONV_STATE RETURN_CODE'
 
    CALL LOGMSG 'APPC: SEND_DATA return_code = 'return_code;
    CALL LOGMSG ' request_to_send_received = ',
        request_to_send_received_value;
 
    if Return_Code <> CM_OK then    /*  if ext conv  was bad         */
      do;                           /*  Send message and return code */
        CALL LOGMSG 'APPC: Conversation state extract failed'
        CALL CheckRC return_code
        ok=0
      end;
    ELSE                            /*  operation was successful     */
      do;
        CALL LOGMSG 'APPC: Conversation state is' conv_state
      end;
 
 return
 
/*---------------------------------------------------------------
 *
 *   Set Deallocation type
 *
 *---------------------------------------------------------------*/
 Set_Dealloc_Type: PROCEDURE,
 EXPOSE conv_id deallocate_type return_code cm_ok ok trc
 
 ADDRESS CPICOMM
    'CMSDT CONV_ID DEALLOCATE_TYPE RETURN_CODE'
                                    /*  Set Deallocate type          */
 
    if Return_Code <> CM_OK then    /*  if Set Deallocate type was
                                        unsuccessful                 */
      do;                           /*  Send message and return code */
        CALL LOGMSG 'APPC: Set Deallocate type failed'
        call CheckRC return_code
        ok=0
      end;
    ELSE                            /*  operation was successful     */
      CALL LOGMSG 'APPC: Set Deallocate type was successful'
 
 return;
 
/*---------------------------------------------------------------
 *
 *   Deallocate conversation
 *
 *---------------------------------------------------------------*/
 Deallocate: PROCEDURE,
 EXPOSE conv_id return_code cm_ok ok trc
 
 ADDRESS CPICOMM
    'CMDEAL CONV_ID RETURN_CODE'    /*  Deallocate                   */
 
    if Return_Code <> CM_OK then    /*  if Deallocate was
                                        unsuccessful                 */
      do;                           /*  Send message and return code */
        CALL LOGMSG 'APPC: Deallocate failed'
        call CheckRC return_code
        ok=0
      end;
    ELSE                            /*  operation was successful     */
      CALL LOGMSG 'APPC: Deallocate succeeded'
 
 return;
 
/*---------------------------------------------------------------
 *
 *   Initialize IP connection
 *
 *---------------------------------------------------------------*/
VAC_Init:
  X=PROMPT('OFF')
 
  SINIT=SOCKET('INITIALIZE','VACSERV')
  PARSE VAR SINIT SRC REST
  if SRC<>0 then
    do
      call LOGMSG "INITIALIZATION FAILED:" SINIT
      return 8
    end
  call LOGMSG "INITIALIZATION Successful:" REST
 
  DNA=SOCKET('GETDOMAINNAME')
  PARSE VAR DNA SRC REST
  if SRC<>0 then
    do
      call LOGMSG "ERROR RETRIEVING DOMAIN NAME:" DNA
      return 8
    end
  call LOGMSG "DOMAIN NAME:" REST
 
  HID=SOCKET('GETHOSTID')
  PARSE VAR HID SRC IPADDRESS .
  if SRC<>0 then
    do
      call LOGMSG "ERROR RETRIEVING HOST ID:" HID
      return 8
    end
  call LOGMSG "HOST ID:" IPADDRESS
 
  HNA=SOCKET('GETHOSTNAME')
  PARSE VAR HNA SRC REST
  if SRC<>0 then
    do
      call LOGMSG "ERROR RETRIEVING HOST NAME:" DNA
      return 8
    end
  call LOGMSG "HOST NAME:" REST
 
 
/*
  SRC=SOCKET('Getservbyport','INPORT_ANY')
  PARSE VAR SRC RC service port protocol .
  if RC<>0 then
    do
      call LOGMSG "GetServByPort failed:" src
      return 8
    end
  call LOGMSG "GetServByPort Successful:" src
  say src /* remove */
*/
 
port=random(3000,5000) /* remove */
 
  SSS=SOCKET('SOCKET')
  PARSE VAR SSS SRC SID
  if SRC<>0 then
    do
      call LOGMSG "ERROR DURING SOCKET(SOCKET):" SSS
      X=SOCKET('TERMINATE','VACSERV')
      return 8
    end
  call LOGMSG "SOCKET ID:" SID
 
  rc=Socket('SetSockOpt',SID,'Sol_Socket','So_ASCII','On')
  if rc<>0 then
    do
      call LOGMSG "Error during SetSockOpt:" rc
      X=SOCKET('TERMINATE','VACSERV')
      return 8
    end
  call LOGMSG "SetSockOpt Successful"
 
  BRC=SOCKET('BIND',SID,'AF_INET' PORT IPADDRESS )
  if BRC<>0 then
    do
      call LOGMSG "ERROR DURING SOCKET(BIND):" BRC
      X=SOCKET('TERMINATE','VACSERV')
      return 8
    end
  call LOGMSG "BIND Successful"
 
  LRC=SOCKET('LISTEN',SID)
  if LRC<>0 then
    do
      call LOGMSG "ERROR DURING SOCKET(LISTEN):" LRC
      X=SOCKET('TERMINATE','VACSERV')
      return 8
    end
  call LOGMSG "LISTEN Successful"
 
return 0
 
/*---------------------------------------------------------------
 *
 *   Accept commands, issue them and send back the output
 *
 *---------------------------------------------------------------*/
VAC_Serv:
  Read_Errors=0
  Write_Errors=0
  Accept_Errors=0
  NSID=''
 
  Low_Hex=         '00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F'x
  Low_Hex=Low_Hex||'10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F'x
  Low_Hex=Low_Hex||'20 21 22 23 24 25 26 27 28 29 2A 2B 2C 2D 2E 2F'x
  Low_Hex=Low_Hex||'30 31 32 33 34 35 36 37 38 39 3A 3B 3C 3D 3E 3F'x
 
  do FOREVER
 
    if (NSID <> '') then
      do
        SRC=SOCKET('CLOSE',NSID)
        call LOGMSG "CLOSE:" SRC
        NSID = ''
      end
 
    SELR=SOCKET('SELECT', 'Read' sid 'Write Exception', timeout)
      PARSE VAR SELR SELRC SELCNT SELREST
    if SELRC <> 0 then
      do
        call LOGMSG "ERROR DURING SELECT:" SELRC
        return 8
      end
    if SELCNT < 1 then
      do
        call LOGMSG "** SELECT TIMED OUT -- SHUTTING DOWN **"
        LEAVE
      end
    if TRC then call LOGMSG "SELECT returned:" SELR
 
    ARC=SOCKET('ACCEPT',SID)
    PARSE VAR ARC SRC NSID . NPORT NHOSTID .
    if (SRC<>0) | (NHOSTID<>wsip) then
      do
        Accept_Errors = Accept_Errors + 1
        if SRC<>0 then call LOGMSG "ERROR DURING ACCEPT:" ARC
        else call LOGMSG "** Client IP address doesn't match **"
        call LOGMSG 'wsip :'wsip':  nhostid :'NHOSTID':'
        if Accept_Errors > Max_Accept_Errors then
          do
            X=SOCKET('TERMINATE','VACSERV')
            return 8
          end
        iterate
      end
    if TRC then call LOGMSG "ACCEPT:" ARC
 
    RRR=SOCKET('READ',NSID)
    PARSE VAR RRR RRC RLEN RToken RSTR
    if RRC<>0 then
      do
        Read_Errors = Read_Errors + 1
        call LOGMSG "ERROR DURING READ:" RRR
        if Read_Errors > Max_Read_Errors then
          do
            X=SOCKET('TERMINATE','VACSERV')
            return 8
          end
        iterate
      end
    if TRC then call LOGMSG "READ:" RRR
 
    if TRANSLATE(RSTR)=':SHUTDOWN:' then
      do
        WWW=SOCKET('WRITE',NSID,EOT)
        PARSE VAR WWW WRC WLEN
        if WRC<>0 then
          do
            call LOGMSG "ERROR DURING WRITE:" WWW
            X=SOCKET('TERMINATE','VACSERV')
            return 8
          end
        if TRC then call LOGMSG "WRITE:" WWW
        LEAVE
      end
 
    if RToken<>Token then
      do
        Read_Errors = Read_Errors + 1
        call LOGMSG "Workstation Token validation failed"
        if Read_Errors > Max_Read_Errors then
          do
            X=SOCKET('TERMINATE','VACSERV')
            return 8
          end
        L.0=1
        L.1=":ERR: Workstation Token validation failed"
      end
    else  /* execute the command */
      do
        X=OUTTRAP("L.")
          RSTR
        X=OUTTRAP("OFF")
 
 
        /*-----------------------------------------------------------
         *
         * If RC is less than 0 then the TSO did not execute.
         * There was a problem like 'COMMAND NOT FOUND'.
         * OUTTRAP doesn't trap this type of error message.
         * So, we'll dummy up a message to send back.
         *
         *-----------------------------------------------------------*/
        if rc<0 then
          do
            L.0=1
            L.1=":ERR: Host was unable to execute command:" RSTR
          end
 
      end
 
    WMSG=''
    do I = 1 TO L.0
      L.I = translate(L.I, , Low_Hex, ' ')  /* '00...3F'x --> ' ' */
      WMSG = WMSG || strip(L.I,'T')||CR||LF
    end
 
 
    WMSG = WMSG || EOT
    WWW=SOCKET('WRITE',NSID,WMSG)
    PARSE VAR WWW WRC WLEN
    if length(WMSG)>80 then TMSG = substr(WMSG,1,80) || '(...)'
    else TMSG = WMSG
    if WRC<>0 then
      do
        Write_Errors = Write_Errors + 1
        call LOGMSG "ERROR DURING WRITE:" WWW TMSG
        if Write_Errors > Max_Write_Errors then
          do
            X=SOCKET('TERMINATE','VACSERV')
            return 8
          end
      end
    if TRC then call LOGMSG "WRITE:" WWW TMSG
 
  end
 
  SRC=SOCKET('CLOSE',NSID)
  call LOGMSG "CLOSE:" SRC
 
  SRC=SOCKET('TERMINATE','VACSERV')
  call LOGMSG "TERMINATE:" SRC
 
return 0
 
/*---------------------------------------------------------------
 * Message logging routine
 *---------------------------------------------------------------*/
LogMsg:
  if trc=0 then return
 
  PARSE ARG MSG
  SAY DATE('S') TIME('L') MSG
  VAC_Err_Msg = MSG
RETURN
 
/*---------------------------------------------------------------
 * Check return code and log message
 *---------------------------------------------------------------*/
CheckRC:
 parse arg ChkRC
 
 SELECT
 
   WHEN (ChkRC=0)
     then do                            /* OK                        */
      CALL LOGMSG ' Return code 0 - OK'
     end;
 
   WHEN (ChkRC=1)
    then do                            /* Allocate Failure no retry  */
      CALL LOGMSG ' Return code 1 - Allocate Failure no retry'
     end;
 
   WHEN (ChkRC=2)
    then do;                           /* Allocate Failure retry     */
      CALL LOGMSG ' Return code 2 - Allocate Failure retry'
     end;
 
   WHEN (ChkRC=3)
    then do                            /* Conversation Type mismatch */
      CALL LOGMSG ' Return code 3 - Conversation Type mismatch'
     end;
 
   WHEN (ChkRC=6)
    then do                            /* Security not valid         */
      CALL LOGMSG ' Return code 6 - Security not valid'
     end;
 
   WHEN (ChkRC=8)
    then do                            /* Sync Level not supported   */
      CALL LOGMSG ' Return code 8 - Sync Level not supported'
     end;
 
   WHEN (ChkRC=9)
    then do                            /* TP Name not recognized     */
      CALL LOGMSG ' Return code 9 - TP Name not recognized'
     end;
 
   WHEN (ChkRC=10)
    then do                            /* TP not avail no retry      */
      CALL LOGMSG ' Return code 10 - TP not avail no retry'
     end;
 
   WHEN (ChkRC=11)
    then do                            /* TP not avail retry         */
      CALL LOGMSG ' Return code 11 - TP not avail retry'
     end;
 
   WHEN (ChkRC=17)
    then do                            /* Deallocated Abend          */
      CALL LOGMSG ' Return code 17 - Deallocated Abend'
     end;
 
   WHEN (ChkRC=30)
    then do                            /* Deallocated Abend Svc      */
      CALL LOGMSG ' Return code 30 - Deallocated Abend Svc'
     end;
 
   WHEN (ChkRC=31)
    then do                            /* Deallocated Abend Timer    */
      CALL LOGMSG ' Return code 31 - Deallocated Abend Timer'
     end;
 
   WHEN (ChkRC=32)
    then do                            /* SVC Error no truncation    */
      CALL LOGMSG ' Return code 32 - SVC Error no Truncation'
     end;
 
   WHEN (ChkRC=33)
    then do                            /* SVC Error Purging          */
      CALL LOGMSG ' Return code 33 - SVC Error Purging'
     end;
 
   WHEN (ChkRC=34)
    then do                            /* SVC Error Truncated        */
      CALL LOGMSG ' Return code 34 - SVC Error Truncated'
     end;
 
   WHEN (ChkRC=18)
    then do                            /* Deallocated Normal         */
      CALL LOGMSG ' Return code 18 - Deallocated Normal'
     end;
 
   WHEN (ChkRC=19)
    then do                            /* Parameter Error            */
      CALL LOGMSG ' Return code 19 - Parameter Error'
     end;
 
   WHEN (ChkRC=20)
    then do                            /* Product specific error     */
      CALL LOGMSG ' Return code 20 - Product specific error'
     end;
 
   WHEN (ChkRC=21)
    then do                            /* Program error no trunc     */
      CALL LOGMSG ' Return code 21 - Program error no trunc'
     end;
 
   WHEN (ChkRC=22)
    then do                            /* Program error purging      */
      CALL LOGMSG ' Return code 22 - Program error purging'
     end;
 
   WHEN (ChkRC=23)
    then do                            /* Program error trunc        */
      CALL LOGMSG ' Return code 23 - Program error trunc'
     end;
 
   WHEN (ChkRC=24)
    then do                            /* Program parameter check    */
      CALL LOGMSG ' Return code 24 - Program parameter check'
     end;
 
   WHEN (ChkRC=25)
    then do                            /* Program state check        */
      CALL LOGMSG ' Return code 25 - Program state check'
      call Ext_Conv_State
     end;
 
   WHEN (ChkRC=26)
    then do                            /* Resource failure no retry  */
      CALL LOGMSG ' Return code 26 - Resource failure no retry'
     end;
 
   WHEN (ChkRC=27)
    then do                            /* Resource failure retry     */
      CALL LOGMSG ' Return code 27 - Resource failure retry'
     end;
 
   WHEN (ChkRC=28)
    then do                            /* Unsuccessful               */
      CALL LOGMSG ' Return code 28 - Unsuccessful'
     end;
 
   OTHERWISE
     do                            /* unknown                    */
      CALL LOGMSG ' Unknown return code = 'CheckRC
     end;
 END;                                  /* End SELECT                 */
 
return
 
/*---------------------------------------------------------------
 * Set standard CPIC pseudonyms
 *---------------------------------------------------------------*/
CPIC_Const:
  CM_INITIALIZE_STATE             = 2
  CM_SEND_STATE                   = 3
  CM_RECEIVE_STATE                = 4
  CM_SEND_PENDING_STATE           = 5
  CM_CONFIRM_STATE                = 6
  CM_CONFIRM_SEND_STATE           = 7
  CM_CONFIRM_DEALLOCATE_STATE     = 8
  CM_DEFER_RECEIVE_STATE          = 9
  CM_DEFER_DEALLOCATE_STATE       = 10
  CM_SYNC_POINT_STATE             = 11
  CM_SYNC_POINT_SEND_STATE        = 12
  CM_SYNC_POINT_DEALLOCATE_STATE  = 13
                                         /* conversation_type      */
  CM_BASIC_CONVERSATION           = 0
  CM_MAPPED_CONVERSATION          = 1
                                         /* data_received          */
  CM_NO_DATA_RECEIVED             = 0
  CM_DATA_RECEIVED                = 1
  CM_COMPLETE_DATA_RECEIVED       = 2
  CM_INCOMPLETE_DATA_RECEIVED     = 3
                                         /* deallocate_type        */
  CM_DEALLOCATE_SYNC_LEVEL        = 0
  CM_DEALLOCATE_FLUSH             = 1
  CM_DEALLOCATE_CONFIRM           = 2
  CM_DEALLOCATE_ABEND             = 3
                                         /* error_direction        */
  CM_RECEIVE_ERROR                = 0
  CM_SEND_ERROR                   = 1
                                         /* fill                   */
  CM_FILL_LL                      = 0
  CM_FILL_BUFFER                  = 1
                                         /* prepare_to_receive_type */
  CM_PREP_TO_RECEIVE_SYNC_LEVEL   = 0
  CM_PREP_TO_RECEIVE_FLUSH        = 1
  CM_PREP_TO_RECEIVE_CONFIRM      = 2
                                         /* receive_type           */
  CM_RECEIVE_AND_WAIT             = 0
  CM_RECEIVE_IMMEDIATE            = 1
                                         /* request_to_send_received */
  CM_REQ_TO_SEND_NOT_RECEIVED     = 0
  CM_REQ_TO_SEND_RECEIVED         = 1
                                         /* return_code            */
  CM_OK                           = 0
  CM_ALLOCATE_FAILURE_NO_RETRY    = 1
  CM_ALLOCATE_FAILURE_RETRY       = 2
  CM_CONVERSATION_TYPE_MISMATCH   = 3
  CM_PIP_NOT_SPECIFIED_CORRECTLY  = 5
  CM_SECURITY_NOT_VALID           = 6
  CM_SYNC_LVL_NOT_SUPPORTED_LU    = 7
  CM_SYNC_LVL_NOT_SUPPORTED_PGM   = 8
  CM_TPN_NOT_RECOGNIZED           = 9
  CM_TP_NOT_AVAILABLE_NO_RETRY    = 10
  CM_TP_NOT_AVAILABLE_RETRY       = 11
  CM_DEALLOCATED_ABEND            = 17
  CM_DEALLOCATED_NORMAL           = 18
  CM_PARAMETER_ERROR              = 19
  CM_PRODUCT_SPECIFIC_ERROR       = 20
  CM_PROGRAM_ERROR_NO_TRUNC       = 21
  CM_PROGRAM_ERROR_PURGING        = 22
  CM_PROGRAM_ERROR_TRUNC          = 23
  CM_PROGRAM_PARAMETER_CHECK      = 24
  CM_PROGRAM_STATE_CHECK          = 25
  CM_RESOURCE_FAILURE_NO_RETRY    = 26
  CM_RESOURCE_FAILURE_RETRY       = 27
  CM_UNSUCCESSFUL                 = 28
  CM_DEALLOCATED_ABEND_SVC        = 30
  CM_DEALLOCATED_ABEND_TIMER      = 31
  CM_SVC_ERROR_NO_TRUNC           = 32
  CM_SVC_ERROR_PURGING            = 33
  CM_SVC_ERROR_TRUNC              = 34
  CM_TAKE_BACKOUT                 = 100
  CM_DEALLOCATED_ABEND_BO         = 130
  CM_DEALLOCATED_ABEND_SVC_BO     = 131
  CM_DEALLOCATED_ABEND_TIMER_BO   = 132
  CM_RESOURCE_FAIL_NO_RETRY_BO    = 133
  CM_RESOURCE_FAILURE_RETRY_BO    = 134
  CM_DEALLOCATED_NORMAL_BO        = 135
                                         /* return_control         */
  CM_WHEN_SESSION_ALLOCATED       = 0
  CM_IMMEDIATE                    = 1
                                         /* send_type              */
  CM_BUFFER_DATA                  = 0
  CM_SEND_AND_FLUSH               = 1
  CM_SEND_AND_CONFIRM             = 2
  CM_SEND_AND_PREP_TO_RECEIVE     = 3
  CM_SEND_AND_DEALLOCATE          = 4
                                         /* status_received        */
  CM_NO_STATUS_RECEIVED           = 0
  CM_SEND_RECEIVED                = 1
  CM_CONFIRM_RECEIVED             = 2
  CM_CONFIRM_SEND_RECEIVED        = 3
  CM_CONFIRM_DEALLOC_RECEIVED     = 4
  CM_TAKE_COMMIT                  = 5
  CM_TAKE_COMMIT_SEND             = 6
  CM_TAKE_COMMIT_DEALLOCATE       = 7
 
  CM_NONE                         = 0    /* sync_level             */
  CM_CONFIRM                      = 1
  CM_SYNC_POINT                   = 2
 
return
 
/*---------------------------------------------------------------
 *   Create unique token
 *---------------------------------------------------------------*/
Create_Token:
  token = time('s')
return
 
/*---------------------------------------------------------------
 *   Get workstation IP addres from buffer
 *---------------------------------------------------------------*/
Chk_IP_Syntax: Procedure,
  expose OK wsip trc
 
  parse arg id wsip .
 
  if id <> ':IP:' then
    do
      call LogMsg,
        "ChkIP: Format of ID string from client is invalid:" buffer
      ok=0
    end
  else
    do
      parse var wsip a.1 '.' a.2 '.' a.3 '.' a.4
 
      do i = 1 to 4
        if datatype(a.i,'W')=0 | length(a.i)>3 then
          do
            ok=0
            call LogMsg "ChkIP: Invalid IP address format:" wsip
            leave
          end
      end
    end
 
  if OK then
    do
      call LogMsg "ChkIP: Workstation IP from client is" wsip
    end
 
return
