SERAPHIM

   SUBROUTINE SERAPHIM(SERVER.IP,SERVER.PORT,SSL.PATHS,ROUTES)
*
   $CATALOGUE LOCAL
*
   GIT.FILENAME = 'SERAPHIM'
   GIT.REPO = 'https://github.com/Krowemoh/TCL-Utilities.git'
*
* COMPILER DIRECTIVES
*
   $DEFINE DATABASE.QM
   $DEFINE PLATFORM.LINUX
*
   $DEFINE HTTP
*
   EQU TRUE TO 1
   EQU FALSE TO 0
*
   DIM REQUEST(12)
*
   EQU REQUEST.TYPE.ATTRIBUTE TO 1
   EQU REQUEST.VERSION.ATTRIBUTE TO 2
   EQU REQUEST.URL.ATTRIBUTE TO 3
   EQU REQUEST.SLUGS.ATTRIBUTE TO 4
   EQU REQUEST.QUERY.ATTRIBUTE TO 5
   EQU REQUEST.HEADERS.ATTRIBUTE TO 6
   EQU REQUEST.COOKIES.ATTRIBUTE TO 7
   EQU REQUEST.RAW.BODY.ATTRIBUTE TO 8
   EQU REQUEST.FORM.ATTRIBUTE TO 9
   EQU REQUEST.FILES.ATTRIBUTE TO 10
   EQU REQUEST.JSON.ATTRIBUTE TO 11
   EQU REQUEST.RAW.REQUEST.ATTRIBUTE TO 12
*
   MAT REQUEST = ''
*
   DIM RESPONSE(4)
*
   EQU RESPONSE.STATUS.ATTRIBUTE TO 1
   EQU RESPONSE.HEADERS.ATTRIBUTE TO 2
   EQU RESPONSE.CONTENT.ATTRIBUTE TO 3
   EQU RESPONSE.CONTENT.TYPE.ATTRIBUTE TO 4
*
   MAT RESPONSE = ''
*
   @USER1 = 'SERAPHIM'
   @USER2 = @USER2 : @AM : 'SERAPHIM'
*
   CALLING.PROGRAM = @USER2<1,1>
*
   CR = CHAR(13)
   LF = CHAR(10)
*
   BODY.DELIMITER = CR:LF:CR:LF
   BODY.DELIMITER.LEN = LEN(BODY.DELIMITER)
*
   ALLOWED.METHODS = 'GET POST PUT PATCH DELETE HEAD OPTIONS'
   CONVERT ' ' TO @AM IN ALLOWED.METHODS
*
   HTTP.STATUSES = ''
*
   HTTP.STATUSES<1,-1> = 200
   HTTP.STATUSES<2,-1> = 'OK'
*
   HTTP.STATUSES<1,-1> = 204
   HTTP.STATUSES<2,-1> = 'No Content'
*
   HTTP.STATUSES<1,-1> = 301
   HTTP.STATUSES<2,-1> = 'Found'
*
   HTTP.STATUSES<1,-1> = 302
   HTTP.STATUSES<2,-1> = 'Moved Permanently'
*
   HTTP.STATUSES<1,-1> = 303
   HTTP.STATUSES<2,-1> = 'See Other'
*
   HTTP.STATUSES<1,-1> = 400
   HTTP.STATUSES<2,-1> = 'Bad Request'
*
   HTTP.STATUSES<1,-1> = 401
   HTTP.STATUSES<2,-1> = 'Unauthorized'
*
   HTTP.STATUSES<1,-1> = 403
   HTTP.STATUSES<2,-1> = 'Forbidden'
*
   HTTP.STATUSES<1,-1> = 404
   HTTP.STATUSES<2,-1> = 'Not Found'
*
   HTTP.STATUSES<1,-1> = 500
   HTTP.STATUSES<2,-1> = 'Internal Server Error'
*
   HTTP.STATUSES<1,-1> = 501
   HTTP.STATUSES<2,-1> = 'Not Implemented'
*
   OPEN '','MD' TO MD.FILE ELSE
      PRINT 'Unable to open file: MD'
      STOP
   END
*
   $IFDEF DATABASE.D3
      CLEARSELECT
      FLASH.CMD = 'SELECT DICT BP SERAPHIM C/FLASH'
      EXECUTE FLASH.CMD CAPTURING OUTPUT
      READNEXT FLASH.COMPILED ELSE FLASH.COMPILED = 0
*
      IF NOT(FLASH.COMPILED) THEN
         PRINT 'SERAPHIM is not flash compiled.'
         STOP
      END
   $ENDIF
*
   GOSUB START.SERVER
*
   RETURN
*
*********************  S U B R O U T I N E  *********************
*
START.SERVER:NULL
*
* SOCKET INITIALIZATION
*
   $IFDEF DATABASE.D3
      CFUNCTION SOCKET.BUILTIN
*
      SOCKET = %SOCKET(2,1,6)
      IF SOCKET < 0 THEN
         CRT 'ERROR ' : SYSTEM(0) : ' - Socket failed.'
         STOP
      END
*
      CODE = %BIND(SOCKET,2,0,SERVER.PORT)
      IF CODE < 0 THEN
         CRT 'ERROR ' : SYSTEM(0) : ' - Bind failed.'
         %CLOSESOCKET(SOCKET)
         STOP
      END
*
      CODE = %LISTEN(SOCKET,1)
      IF CODE < 0 THEN
         CRT 'ERROR ' : SYSTEM(0) : ' - Listen failed.'
         %CLOSESOCKET(SOCKET)
         STOP
      END
   $ENDIF
*
   $IFDEF DATABASE.QM
      $IFDEF HTTP
         SOCKET = CREATE.SERVER.SOCKET(SERVER.IP,SERVER.PORT,0)
         CODE = STATUS()
         IF CODE THEN
            CRT 'ERROR ' : CODE : ' - CREATE.SERVER.SOCKET failed.'
            CLOSE.SOCKET SOCKET
            STOP
         END
      $ENDIF
      $IFDEF HTTPS
         CERTIFICATE.PATH = SSL.PATHS<1>
         KEY.PATH = SSL.PATHS<2>
         SOCKET = CREATE.SECURE.SERVER.SOCKET(SERVER.IP,SERVER.PORT,0,CERTIFICATE.PATH,KEY.PATH)
         CODE = STATUS()
         IF CODE THEN
            CRT 'ERROR ' : CODE : ' - CREATE.SECURE.SERVER.SOCKET failed.'
            CLOSE.SECURE.SOCKET SOCKET
            STOP
         END
      $ENDIF
   $ENDIF
*
   $IFDEF DATABASE.UV
      CODE = initServerSocket(SERVER.IP,SERVER.PORT,1,SOCKET)
      IF CODE # 0 THEN
         CRT 'ERROR ' : SYSTEM(0) : ' - initServerSocket failed.'
         CODE = closeSocket(SOCKET)
         STOP
      END
   $ENDIF
*
   PRINT 'Server      : ' : SERVER.IP
   PRINT 'Port        : ' : SERVER.PORT
   PRINT
   PRINT 'Listening on ' : SERVER.IP : ':' : SERVER.PORT
   PRINT
*
   DONE = FALSE
*
   CLIENT.ADDRESS = 0
   CLIENT.PORT = 0
*
   LOOP UNTIL DONE DO
*
      $IFDEF DATABASE.D3
         FD = %ACCEPT(SOCKET,&CLIENT.ADDRESS,&CLIENT.PORT)
         IF FD < 0 THEN
            CRT 'ERROR ' : SYSTEM(0) : ' = Accept failed.'
            %CLOSESOCKET(SOCKET)
            STOP
         END
      $ENDIF
*
      $IFDEF DATABASE.QM
         $IFDEF HTTP
            FD = ACCEPT.SOCKET.CONNECTION(SOCKET,0)
            CODE = STATUS()
            IF CODE THEN
               CRT 'ERROR ' : CODE : ' = Accept failed.'
               CLOSE.SOCKET SOCKET
               STOP
            END
         $ENDIF
*
         $IFDEF HTTPS
            FD = ACCEPT.SECURE.SOCKET.CONNECTION(SOCKET,0)
            CODE = STATUS()
            IF CODE THEN
               CRT 'ERROR ' : CODE : ' = Accept Secure failed.'
               CONTINUE
            END
         $ENDIF
*
      $ENDIF
*
      $IFDEF DATABASE.UV
         CODE = acceptConnection(SOCKET,1,0,NULL,NULL,FD)
         IF CODE # 0 THEN
            CRT 'ERROR ' : SYSTEM(0) : ' = Accept failed.'
            CODE = closeSocket(SOCKET)
            STOP
         END
      $ENDIF
*
      GOSUB PROCESS.REQUEST
   REPEAT
*
   $IFDEF DATABASE.D3
      %CLOSESOCKET(SOCKET)
   $ENDIF
*
   $IFDEF DATABASE.QM
      $IFDEF HTTP
         CLOSE.SOCKET SOCKET
      $ENDIF
      $IFDEF HTTPS
         CLOSE.SECURE.SOCKET SOCKET
      $ENDIF
   $ENDIF
*
   $IFDEF DATABASE.UV
      CODE = closeSocket(SOCKET)
   $ENDIF
*
   RETURN
*
*********************  S U B R O U T I N E  *********************
*
PROCESS.REQUEST:NULL
*
   T1 = TIME()
*
   GOSUB INITIALIZE.REQUEST
   MAT RESPONSE = ''
*
   GOSUB READ.REQUEST
   REQUEST(REQUEST.RAW.REQUEST.ATTRIBUTE) = RAW.REQUEST
*
   GOSUB GET.STATUS.LINE
   REQUEST(REQUEST.TYPE.ATTRIBUTE) = REQUEST.TYPE
   REQUEST(REQUEST.VERSION.ATTRIBUTE) = REQUEST.VERSION
   REQUEST(REQUEST.URL.ATTRIBUTE) = REQUEST.URL
   REQUEST(REQUEST.QUERY.ATTRIBUTE) = REQUEST.QUERY
*
   GOSUB GET.HEADERS
   REQUEST(REQUEST.HEADERS.ATTRIBUTE) = REQUEST.HEADERS
   REQUEST(REQUEST.COOKIES.ATTRIBUTE) = REQUEST.COOKIES
*
   IF REQUEST.TYPE # 'GET' THEN
      GOSUB GET.POST.DATA
*
      REQUEST(REQUEST.RAW.BODY.ATTRIBUTE) = REQUEST.RAW.BODY
      REQUEST(REQUEST.FORM.ATTRIBUTE) = REQUEST.FORM
      REQUEST(REQUEST.FILES.ATTRIBUTE) = REQUEST.FILES
      REQUEST(REQUEST.JSON.ATTRIBUTE) = REQUEST.JSON
   END
*
   BEGIN CASE
      CASE REQUEST.ERROR # ''
         PRINT 'Error: ' : REQUEST.ERROR
*
         RESPONSE(RESPONSE.STATUS.ATTRIBUTE) = 400
         RESPONSE(RESPONSE.CONTENT.ATTRIBUTE) = 'Bad request.'
         GOSUB SEND.HTTP.RESPONSE
*
      CASE REQUEST.TYPE = 'OPTIONS'
         RESPONSE(RESPONSE.STATUS.ATTRIBUTE) = 204
         RESPONSE(RESPONSE.CONTENT.ATTRIBUTE) = ''
         GOSUB SEND.HTTP.RESPONSE
*
      CASE REQUEST.URL = '/kill'
         DONE = TRUE
*
         RESPONSE(RESPONSE.STATUS.ATTRIBUTE) = 200
         RESPONSE(RESPONSE.CONTENT.ATTRIBUTE) = 'Killing server.'
         GOSUB SEND.HTTP.RESPONSE
*
      CASE REQUEST.URL = '/restart'
         DONE = TRUE
*
         RESPONSE(RESPONSE.STATUS.ATTRIBUTE) = 200
         RESPONSE(RESPONSE.CONTENT.ATTRIBUTE) = 'Restarting server.'
         GOSUB SEND.HTTP.RESPONSE
*
         $IFDEF DATABASE.D3
            %CLOSESOCKET(FD)
            %CLOSESOCKET(SOCKET)
         $ENDIF
*
         $IFDEF DATABASE.QM
            CLOSE.SOCKET FD
            CLOSE.SOCKET SOCKET
         $ENDIF
*
         $IFDEF DATABASE.UV
            CODE = closeSocket(FD)
            CODE = closeSocket(SOCKET)
         $ENDIF
*
         CHAIN CALLING.PROGRAM
*
      CASE TRUE
         PROCEED = TRUE
*
         NUMBER.OF.ROUTES = DCOUNT(ROUTES<1>,@VM)
         PROCEED = FALSE
*
         FOR ROUTE.CTR = 1 TO NUMBER.OF.ROUTES UNTIL PROCEED = TRUE
            ROUTE = ROUTES<1,ROUTE.CTR>
*
            ROUTE.PATTERN = ''
            SLUG.PATTERN = "0X'<'0X'>'0X"
            SLUG.CTR = 0
*
            LOOP UNTIL NOT(ROUTE MATCHES SLUG.PATTERN) DO
               ONE = MATCHFIELD(ROUTE,SLUG.PATTERN,1)
               SLUG = MATCHFIELD(ROUTE,SLUG.PATTERN,3)
               THREE = MATCHFIELD(ROUTE,SLUG.PATTERN,5)
*
               ROUTE = "'" : ONE : "'0X'" : THREE : "'"
*
               IF REQUEST.URL MATCHES ROUTE THEN
                  SLUG.CTR = SLUG.CTR + 2
*
                  REQUEST(REQUEST.SLUGS.ATTRIBUTE)<1,-1> = SLUG
*
                  SLUG.VALUE = MATCHFIELD(REQUEST.URL,ROUTE,SLUG.CTR)
                  REQUEST(REQUEST.SLUGS.ATTRIBUTE)<2,-1> = SLUG.VALUE
               END
            REPEAT
*
            ROUTE.PATTERN = ROUTE
*
            IF REQUEST.URL MATCHES ROUTE.PATTERN THEN
               PROCEED = TRUE
               ROUTE.POS = ROUTE.CTR
            END ELSE
               REQUEST(REQUEST.SLUGS.ATTRIBUTE)<1> = ''
               REQUEST(REQUEST.SLUGS.ATTRIBUTE)<2> = ''
            END
         NEXT ROUTE.CTR
*
         IF PROCEED THEN
            FUNC = TRIM(ROUTES<2,ROUTE.POS>)
*
            $IFDEF DATABASE.D3
               READ MD.ITEM FROM MD.FILE,FUNC ELSE
                  RESPONSE(RESPONSE.STATUS.ATTRIBUTE) = 500
                  RESPONSE(RESPONSE.CONTENT.ATTRIBUTE) = 'Subroutine "' : FUNC : '" was not cataloged.'
                  GOSUB SEND.HTTP.RESPONSE
                  PROCEED = FALSE
               END
            $ENDIF
         END
*
         IF PROCEED THEN
            $IFDEF DATABASE.D3
               PROGRAM.FOLDER.NAME = TRIM(FIELD(MD.ITEM<4>,' ',1))
*
               CLEARSELECT
               FLASH.CMD = 'SELECT DICT ' : PROGRAM.FOLDER.NAME : ' ' : FUNC : ' C/FLASH'
               EXECUTE FLASH.CMD
               READNEXT FLASH.COMPILED ELSE FLASH.COMPILED = 0
*
               IF NOT(FLASH.COMPILED) THEN
                  RESPONSE(RESPONSE.STATUS.ATTRIBUTE) = 500
                  RESPONSE(RESPONSE.CONTENT.ATTRIBUTE) = 'Subroutine "' : FUNC : '" was not flash compiled.'
                  GOSUB SEND.HTTP.RESPONSE
                  PROCEED = FALSE
               END
            $ENDIF
         END
*
         IF PROCEED THEN
            CALL @FUNC(MAT REQUEST,MAT RESPONSE)
            GOSUB SEND.HTTP.RESPONSE
         END ELSE
*
            RESPONSE(RESPONSE.STATUS.ATTRIBUTE) = 404
            RESPONSE(RESPONSE.CONTENT.ATTRIBUTE) = 'Page not found.'
            GOSUB SEND.HTTP.RESPONSE
         END
*
   END CASE
*
   T2 = TIME()
*
   TIME.TAKEN = T2 - T1
   GOSUB LOG.RESPONSE
*
   $IFDEF DATABASE.D3
      %CLOSESOCKET(FD)
   $ENDIF
*
   $IFDEF DATABASE.QM
      $IFDEF HTTP
         CLOSE.SOCKET FD
      $ENDIF
      $IFDEF HTTPS
         CLOSE.SECURE.SOCKET FD
      $ENDIF
   $ENDIF
*
   $IFDEF DATABASE.UV
      CODE = closeSocket(FD)
   $ENDIF
*
   RETURN
*
*********************  S U B R O U T I N E  *********************
*
INITIALIZE.REQUEST:NULL
*
   MAT REQUEST =''
*
   RAW.REQUEST = ''
*
   REQUEST.ERROR = ''
*
   REQUEST.TYPE = ''
   REQUEST.VERSION = ''
   REQUEST.URL = ''
   REQUEST.QUERY = ''
*
   REQUEST.HEADERS = ''
   REQUEST.COOKIES = ''
*
   REQUEST.RAW.BODY = ''
   REQUEST.FORM = ''
   REQUEST.FILES = ''
   REQUEST.JSON = ''
*
   RETURN
*
*********************  S U B R O U T I N E  *********************
*
READ.REQUEST:NULL
*
   BUFFER.SIZE = 1000
*
   CONTENT.LENGTH = ''
*
   READ.DONE = FALSE
*
   LOOP UNTIL READ.DONE DO
      $IFDEF DATABASE.D3
         CHAR BUFFER[BUFFER.SIZE]
      $ENDIF
*
      $IFDEF DATABASE.QM
         BUFFER = SPACES(BUFFER.SIZE)
         CONVERT ' ' TO '' IN BUFFER
      $ENDIF
*
      $IFDEF DATABASE.UV
         BUFFER = SPACES(BUFFER.SIZE)
         CONVERT ' ' TO '' IN BUFFER
      $ENDIF
*
      $IFDEF DATABASE.D3
         READ.SIZE = %RECV(FD,BUFFER,BUFFER.SIZE,0)
      $ENDIF
*
      $IFDEF DATABASE.QM
         $IFDEF HTTP
            BUFFER = READ.SOCKET(FD,BUFFER.SIZE,1,0)
            READ.SIZE = LEN(BUFFER)
         $ENDIF
         $IFDEF HTTPS
            BUFFER = READ.SECURE.SOCKET(FD,BUFFER.SIZE,1,0)
            READ.SIZE = LEN(BUFFER)
         $ENDIF
      $ENDIF
*
      $IFDEF DATABASE.UV
         CODE = readSocket(FD,BUFFER,BUFFER.SIZE,0,1,READ.SIZE)
      $ENDIF
*
      IF READ.SIZE < 0 THEN
         CRT 'Read Error: ' : SYSTEM(0)
         READ.DONE = TRUE
*
* RECV MAY RETURN IN FRAGMENTS, CHECK CONTENT.LENGTH TO GET REAL SIZE
*
      END ELSE IF READ.SIZE < BUFFER.SIZE THEN
         RAW.REQUEST = RAW.REQUEST : BUFFER[1,BUFFER.SIZE]
*
         IF CONTENT.LENGTH = '' THEN
            PATTERN = "0X'Content-Length:'0X": CR:LF: "0X"
            CONTENT.LENGTH = TRIM(MATCHFIELD(RAW.REQUEST,PATTERN,3))
*
* UNIVERSE HAS ISSUES WITH MATCHING AGAINST CRLF
*
            CRLF.POS = INDEX(CONTENT.LENGTH,CR:LF,1)
            IF CRLF.POS > 0 THEN
               CONTENT.LENGTH = CONTENT.LENGTH[1,CRLF.POS-1]
            END
         END
*
         IF CONTENT.LENGTH = '' THEN
            READ.DONE = TRUE
*
         END ELSE
            REQUEST.SIZE = LEN(RAW.REQUEST)
            IF NUM(CONTENT.LENGTH) AND REQUEST.SIZE >= CONTENT.LENGTH THEN
               READ.DONE = TRUE
            END
         END
*
      END ELSE
         RAW.REQUEST = RAW.REQUEST : BUFFER
      END
   REPEAT
*
   RETURN
*
*********************  S U B R O U T I N E  *********************
*
GET.STATUS.LINE:NULL
*
   RAW.REQUEST.TYPE = ''
*
   IF RAW.REQUEST = '' THEN
      REQUEST.ERROR = 'Invalid request - request is blank.'
      RETURN
   END
*
   STATUS.LINE = FIELD(RAW.REQUEST,CR:LF,1)
*
   REQUEST.TYPE = FIELD(STATUS.LINE,' ',1)
*
   LOCATE(REQUEST.TYPE,ALLOWED.METHODS;ANYPOS) ELSE
      REQUEST.ERROR = 'Invalid request type: ' : REQUEST.TYPE
      RETURN
   END
*
   RAW.REQUEST.TYPE = REQUEST.TYPE
*
   IF REQUEST.TYPE = 'HEAD' THEN
      REQUEST.TYPE = 'GET'
   END
*
   REQUEST.VERSION = FIELD(STATUS.LINE,' ',3)
*
   REQUEST.URL = FIELD(STATUS.LINE,' ',2)
   REQUEST.QUERY = ''
*
   IF INDEX(REQUEST.URL,'?',1) THEN
      QUERY.PARAMS = FIELD(REQUEST.URL,'?',2)
      QUERY.LENGTH = LEN(QUERY.PARAMS)
*
      TOKEN = ''
      IN.NAME = TRUE
*
      FOR I = 1 TO QUERY.LENGTH
         LETTER = QUERY.PARAMS[I,1]
*
         IF IN.NAME AND LETTER = '=' THEN
            REQUEST.QUERY<1,-1> = TOKEN
            TOKEN = ''
            IN.NAME = FALSE
*
         END ELSE IF LETTER = '&' THEN
            REQUEST.QUERY<2,-1> = TOKEN
            TOKEN = ''
            IN.NAME = TRUE
*
         END ELSE
            TOKEN = TOKEN : LETTER
         END
      NEXT I
*
      IF TOKEN # '' THEN
         REQUEST.QUERY<2,-1> = TOKEN
      END
*
      REQUEST.URL = FIELD(REQUEST.URL,'?',1)
   END
*
   RETURN
*
*********************  S U B R O U T I N E  *********************
*
GET.HEADERS:NULL
*
   START.POS = INDEX(RAW.REQUEST,CR:LF,1)
*
   IF REQUEST.TYPE = 'GET' THEN
      HEADERS = RAW.REQUEST[START.POS+2,LEN(RAW.REQUEST)-START.POS-2]
*
   END ELSE
      HEADERS = RAW.REQUEST[START.POS+2,INDEX(RAW.REQUEST,BODY.DELIMITER,1)-START.POS-2]
   END
*
   HEADERS.LENGTH = LEN(HEADERS)
*
   TOKEN = ''
   IN.NAME = TRUE
*
   FOR I = 1 TO HEADERS.LENGTH
      LETTER = HEADERS[I,1]
*
      IF IN.NAME AND LETTER = ':' THEN
         REQUEST.HEADERS<1,-1> = TRIM(TOKEN)
         TOKEN = ''
         IN.NAME = FALSE
*
      END ELSE IF LETTER = CR THEN
         IF HEADERS[I+1,1] = LF THEN
            I = I + 1
         END
*
         REQUEST.HEADERS<2,-1> = TRIM(TOKEN)
         TOKEN = ''
         IN.NAME = TRUE
*
      END ELSE
         TOKEN = TOKEN : LETTER
      END
   NEXT I
*
   IF TOKEN # '' THEN
      REQUEST.HEADERS<2,-1> = TRIM(TOKEN)
   END
*
   COOKIE.FOUND = TRUE
*
   LOCATE('Cookie',REQUEST.HEADERS<1>,1;ANYPOS) ELSE
      LOCATE('cookie',REQUEST.HEADERS<1>,1;ANYPOS) ELSE
         COOKIE.FOUND = FALSE
      END
   END
   
   IF COOKIE.FOUND THEN
      COOKIES = REQUEST.HEADERS<2,ANYPOS>
      CONVERT ';' TO @AM IN COOKIES
      NUMBER.OF.COOKIES = DCOUNT(COOKIES,@AM)
*
      FOR COOKIE.CTR = 1 TO NUMBER.OF.COOKIES
         COOKIE = COOKIES<COOKIE.CTR>
*
         CONVERT '=' TO @AM IN COOKIE
*
         REQUEST.COOKIES<1,-1> = TRIM(COOKIE<1>)
         REQUEST.COOKIES<2,-1> = TRIM(COOKIE<2>)
      NEXT COOKIE.CTR
   END
*
   RETURN
*
*********************  S U B R O U T I N E  *********************
*
GET.POST.DATA:NULL
*
   LOCATE('Content-Type',REQUEST.HEADERS,1;ANYPOS) ELSE
      LOCATE('content-type',REQUEST.HEADERS,1;ANYPOS) ELSE
         REQUEST.ERROR = 'Cannot find Content-Type, make sure it is spelled correctly.'
         RETURN
      END
   END
*
   CONTENT.TYPE = REQUEST.HEADERS<2,ANYPOS>
*
   LOCATE('Content-Length',REQUEST.HEADERS,1;ANYPOS) ELSE
      REQUEST.ERROR = 'Cannot find Content-Length, make sure it is set correctly.'
      RETURN
   END
*
   CONTENT.LENGTH = REQUEST.HEADERS<2,ANYPOS>
*
   REQUEST.RAW.BODY = RAW.REQUEST[INDEX(RAW.REQUEST,BODY.DELIMITER,1)+BODY.DELIMITER.LEN,CONTENT.LENGTH]
*
   POST.CTR = 1
*
   IF CONTENT.TYPE = 'application/x-www-form-urlencoded' THEN
      TOKEN = ''
*
      FOR I = 1 TO CONTENT.LENGTH
         LETTER = REQUEST.RAW.BODY[I,1]
*
         IF LETTER = '=' THEN
            REQUEST.FORM<1,POST.CTR> = TOKEN
            TOKEN = ''
*
         END ELSE IF LETTER = '&' THEN
            REQUEST.FORM<2,POST.CTR> = TOKEN
            TOKEN = ''
            POST.CTR = POST.CTR + 1
*
         END ELSE
            TOKEN = TOKEN : LETTER
         END
      NEXT I
*
      IF TOKEN # '' THEN
         REQUEST.FORM<2,POST.CTR> = TOKEN
      END
*
      NUMBER.OF.PARAMS = DCOUNT(REQUEST.FORM<1>,@VM)
      SIMPLIFIED.FORM = ''
*
      FOR I = 1 TO NUMBER.OF.PARAMS
         FORM.KEY = REQUEST.FORM<1,I>
         FORM.VALUE = REQUEST.FORM<2,I>
*
         LOCATE(FORM.KEY,SIMPLIFIED.FORM<1>,1;FORM.POS) THEN
            SIMPLIFIED.FORM<2,FORM.POS,-1> = FORM.VALUE
         END ELSE
            SIMPLIFIED.FORM<1,I> = FORM.KEY
            SIMPLIFIED.FORM<2,I> = FORM.VALUE
         END
      NEXT I
*
      REQUEST.FORM = SIMPLIFIED.FORM
*
   END ELSE IF CONTENT.TYPE = 'application/json' THEN
      REQUEST.JSON = REQUEST.RAW.BODY
*
   END ELSE IF CONTENT.TYPE[1,19] = 'multipart/form-data' THEN
      BOUNDARY = TRIM(CONTENT.TYPE[INDEX(CONTENT.TYPE,'=',1)+1,9999])
*
* BOUNDARY IS PREPENDED WITH --
*
      BOUNDARY = '--' : BOUNDARY
*
* ESCAPE OUT CHARS SO WE CAN USE @AM, 255 BREAKS THIS IS THE SEGMENT MARK
*
      REQUEST.RAW.BODY = CHANGE(REQUEST.RAW.BODY,@AM,'<ESC>254<ESC>')
      REQUEST.RAW.BODY = CHANGE(REQUEST.RAW.BODY,CHAR(255),'<ESC>255<ESC>')
      REQUEST.RAW.BODY = CHANGE(REQUEST.RAW.BODY,BOUNDARY,@AM)
*
      NUMBER.OF.BINS = DCOUNT(REQUEST.RAW.BODY,@AM)
*
      FOR BIN.CTR = 1 TO NUMBER.OF.BINS
         IF BIN.CTR = 1 OR BIN.CTR = NUMBER.OF.BINS THEN
            CONTINUE
         END
*
         BIN.DATA = REQUEST.RAW.BODY<BIN.CTR>
*
* REMOVE TRAILING CR:LF
*
         BIN.DATA = BIN.DATA[1,LEN(BIN.DATA)-2]
*
* REMOVE LEADING CR:LF
*
         BIN.DATA = BIN.DATA[3,LEN(BIN.DATA)-2]
*
* FIND \r\n\r\n TO FIND DATA SECTION
*
         BIN.POS = INDEX(BIN.DATA,CR:LF:CR:LF,1)
*
* HEADER SECTION IS UP TO THE \r\n\r\n
*
         BIN.HEADER = BIN.DATA[1,BIN.POS]
*
* DATA SECTION IS EVERYTHING AFTERWARDS, SUBTRACT 3 TO LEAVE A \n AT THE END
*
         BIN.DATA = BIN.DATA[BIN.POS+4,LEN(BIN.DATA)-LEN(BIN.HEADER)-3]
*
* UNESCAPE CHAR(254) AND CHAR(255)
*
         BIN.DATA = CHANGE(BIN.DATA,'<ESC>254<ESC>',@AM)
         BIN.DATA = CHANGE(BIN.DATA,'<ESC>255<ESC>',CHAR(255))
*
* CONVERT THE BINARY DATA INTO HEX SO WE CAN PASS AROUND
*
         BIN.DATA = OCONV(BIN.DATA,'MX0C')
*
* GET THE NAME OF THE UPLOADED FILE
*
         PATTERN = \0X'filename="'0X'"'0X\
         BIN.NAME = MATCHFIELD(BIN.HEADER,PATTERN,3)
*
         REQUEST.FILES<1,-1> = BIN.NAME
         REQUEST.FILES<2,-1> = BIN.DATA
      NEXT BIN.CTR
*
   END ELSE
      REQUEST.ERROR = 'Unsupported content type: ' : CONTENT.TYPE
   END
   
   RETURN
*
*********************  S U B R O U T I N E  *********************
*
SEND.HTTP.RESPONSE:NULL
*
   CONTENT.TYPE = RESPONSE(RESPONSE.CONTENT.TYPE.ATTRIBUTE)
*
   IF CONTENT.TYPE = '' THEN
      CONTENT.TYPE = 'text/html'
   END
*
   RESPONSE.STATUS = RESPONSE(RESPONSE.STATUS.ATTRIBUTE)
*
   IF CONTENT.TYPE[1,5] = 'text/' THEN
      RESPONSE.BODY = CHANGE(RESPONSE(RESPONSE.CONTENT.ATTRIBUTE),@AM,CR:LF)
   END ELSE
      RESPONSE.BODY = RESPONSE(RESPONSE.CONTENT.ATTRIBUTE)
   END
*
   LOCATE(RESPONSE.STATUS,HTTP.STATUSES,1;POS) THEN
      STATUS.TEXT = HTTP.STATUSES<2,POS>
   END ELSE
      PRINT 'Invalid http status "' : RESPONSE.STATUS : '".'
      STATUS.TEXT = 'Invalid Status'
   END
*
   HEADERS = RESPONSE(RESPONSE.HEADERS.ATTRIBUTE)
*
   BUFFER = ''
   BUFFER<-1> = 'HTTP/1.1 ' : RESPONSE.STATUS : ' ' : STATUS.TEXT
   BUFFER<-1> = 'Date: ' : OCONV(DATE(),'D')
   BUFFER<-1> = 'Server: SERAPHIM'
   BUFFER<-1> = 'Access-Control-Allow-Origin: *'
   BUFFER<-1> = 'Access-Control-Allow-Methods: GET, POST, OPTIONS, DELETE, HEAD, PUT'
   BUFFER<-1> = 'Access-Control-Allow-Headers: *'
*
   IF HEADERS THEN
      BUFFER<-1> = HEADERS
   END
*
   BUFFER<-1> = 'Content-Length: ' : LEN(RESPONSE.BODY)
   BUFFER<-1> = 'Content-Type: ' : CONTENT.TYPE
   BUFFER<-1> = 'Connection: Closed'
*
   BUFFER = CHANGE(BUFFER,@AM,CR:LF)
*
   IF RAW.REQUEST.TYPE # 'HEAD' THEN
      BUFFER = BUFFER : CR:LF : CR:LF : RESPONSE.BODY
   END
*
   BUFFER.LENGTH = LEN(BUFFER)
*
   $IFDEF DATABASE.D3
      CODE = %SEND(FD,BUFFER,BUFFER.LENGTH,0)
   $ENDIF
*
   $IFDEF DATABASE.QM
      $IFDEF HTTP
         WRITE.SIZE = WRITE.SOCKET(FD,BUFFER,1,0)
      $ENDIF
      $IFDEF HTTPS
         WRITE.SIZE = WRITE.SECURE.SOCKET(FD,BUFFER,1,0)
      $ENDIF
   $ENDIF
*
   $IFDEF DATABASE.UV
      CODE = writeSocket(FD,BUFFER,10000,1,WRITE.SIZE)
   $ENDIF
*
   RETURN
*
*********************  S U B R O U T I N E  *********************
*
LOG.RESPONSE:NULL
*
   PRINT '> [' : OCONV(DATE(),'D') : ' ' :
   PRINT OCONV(TIME(),'MTH') : '] ' :
   PRINT RAW.REQUEST.TYPE : ' ' :
   PRINT REQUEST.URL : ' ' :
   PRINT RESPONSE.STATUS : ' ' :
   PRINT TIME.TAKEN : 'ms '
*
   RETURN
*
* END OF PROGRAM
*
   END
*