HTTP.SERVER

*
   GIT.FILENAME = 'HTTP.SERVER'
   GIT.REPO = 'https://github.com/Krowemoh/TCL-Utilities.git'
*
* COMPILER DIRECTIVES
*
   $DEFINE DATABASE.UV
   $DEFINE PLATFORM.LINUX
*
   EQU TRUE TO 1
   EQU FALSE TO 0
*
   DIM REQUEST(10)
*
   EQU REQUEST.TYPE.ATTRIBUTE TO 1
   EQU REQUEST.VERSION.ATTRIBUTE TO 2
   EQU REQUEST.URL.ATTRIBUTE TO 3
   EQU REQUEST.QUERY.ATTRIBUTE TO 4
   EQU REQUEST.HEADERS.ATTRIBUTE TO 5
   EQU REQUEST.COOKIES.ATTRIBUTE TO 6
   EQU REQUEST.RAW.BODY.ATTRIBUTE TO 7
   EQU REQUEST.FORM.ATTRIBUTE TO 8
   EQU REQUEST.JSON.ATTRIBUTE TO 9
   EQU REQUEST.RAW.REQUEST.ATTRIBUTE TO 10
*
   MAT REQUEST = ''
*
   DIM RESPONSE(3)
*
   EQU RESPONSE.STATUS.ATTRIBUTE TO 1
   EQU RESPONSE.HEADERS.ATTRIBUTE TO 2
   EQU RESPONSE.CONTENT.ATTRIBUTE TO 3
*
   MAT RESPONSE = ''
*
   @USER1 = 'HTTP.SERVER'
   @USER2 = 'HTTP.SERVER'
*
   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 '
*
   HTTP.STATUSES = ''
*
   HTTP.STATUSES<1,-1> = 200
   HTTP.STATUSES<2,-1> = 'OK'
*
   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> = 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'
*
*
   SERVER.PORT = 7122
*
   OPEN '','MD' TO MD.FILE ELSE
      PRINT 'Unable to open file: MD'
      STOP
   END
*
   $IFDEF DATABASE.D3
      CLEARSELECT
      FLASH.CMD = 'SELECT DICT BP HTTP.SERVER C/FLASH'
      EXECUTE FLASH.CMD CAPTURING OUTPUT
      READNEXT FLASH.COMPILED ELSE FLASH.COMPILED = 0
*
      IF NOT(FLASH.COMPILED) THEN
         PRINT 'HTTP.SERVER is not flash compiled.'
         STOP
      END
   $ENDIF
*
* 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
      SOCKET = CREATE.SERVER.SOCKET('',SERVER.PORT,0)
      CODE = STATUS()
      IF CODE THEN
         CRT 'ERROR ' : CODE : ' - CREATE.SERVER.SOCKET failed.'
         CLOSE.SOCKET SOCKET
      END
   $ENDIF
*
   $IFDEF DATABASE.UV
      CODE = initServerSocket('0.0.0.0',SERVER.PORT,1,SOCKET)
      IF CODE # 0 THEN
         CRT 'ERROR ' : SYSTEM(0) : ' - initServerSocket failed.'
         CODE = closeSocket(SOCKET)
      END
   $ENDIF
*
   CRT 'Listening on: 0.0.0.0:' : SERVER.PORT
   CRT
*
   OPEN '','CONTROL-FILE' TO CONTROL.FILE ELSE
      PRINT 'Unable to open file: CONTROL-FILE - Press RETURN':
      INPUT ANYTHING
      STOP
   END
*
   DONE = FALSE
*
   CLIENT.ADDRESS = 0
   CLIENT.PORT = 0
*
   LOOP UNTIL DONE DO
*
      READ ROUTES FROM CONTROL.FILE,'ROUTES' ELSE ROUTES = ''
*
      $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
         FD = ACCEPT.SOCKET(SOCKET,0)
         CODE = STATUS()
         IF CODE THEN
            CRT 'ERROR ' : CODE : ' = Accept failed.'
            CLOSE.SOCKET SOCKET
            STOP
         END
      $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 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 = 'POST' THEN
         GOSUB GET.POST.DATA
         REQUEST(REQUEST.RAW.BODY.ATTRIBUTE) = REQUEST.RAW.BODY
         REQUEST(REQUEST.FORM.ATTRIBUTE) = REQUEST.FORM
         REQUEST(REQUEST.JSON.ATTRIBUTE) = REQUEST.JSON
      END
*
*TEMP       GOSUB LOG.REQUEST
*
      T1 = TIME()
*
      BEGIN CASE
         CASE REQUEST.ERROR # ''
            PRINT REQUEST.ERROR
*
            RESPONSE(RESPONSE.STATUS.ATTRIBUTE) = 400
            RESPONSE(RESPONSE.CONTENT.ATTRIBUTE) = 'Bad request.'
            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 'HTTP.SERVER'
*
         CASE TRUE
            PROCEED = TRUE
*
            LOCATE(REQUEST.URL,ROUTES<1>,1;ROUTE.POS) ELSE
               RESPONSE(RESPONSE.STATUS.ATTRIBUTE) = 404
               RESPONSE(RESPONSE.CONTENT.ATTRIBUTE) = 'Page not found.'
               GOSUB SEND.HTTP.RESPONSE
               PROCEED = FALSE
            END
*
            IF PROCEED THEN
               FUNC = TRIM(ROUTES<2,ROUTE.POS>)
*
               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
            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
               $IFDEF DATABASE.D3
                  %CLOSESOCKET(SOCKET)
               $ENDIF
*
               $IFDEF DATABASE.QM
                  CLOSE.SOCKET SOCKET
               $ENDIF
*
               $IFDEF DATABASE.UV
                  CODE = closeSocket(SOCKET)
               $ENDIF
*
               EXECUTE 'PHANTOM BRIEF HTTP.SERVER' CAPTURING RESULT
*
               PHANTOM.STARTED = INDEX(RESULT,'started',1) > 0
*
               IF PHANTOM.STARTED THEN
                  DONE = TRUE
               END ELSE
                  DONE = FALSE
               END
*
               CALL @FUNC(MAT REQUEST,MAT RESPONSE)
               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
         CLOSE.SOCKET FD
      $ENDIF
*
      $IFDEF DATABASE.UV
         CODE = closeSocket(FD)
      $ENDIF
   REPEAT
*
   $IFDEF DATABASE.D3
      %CLOSESOCKET(SOCKET)
   $ENDIF
*
   $IFDEF DATABASE.QM
      CLOSE.SOCKET SOCKET
   $ENDIF
*
   $IFDEF DATABASE.UV
      CODE = closeSocket(SOCKET)
   $ENDIF
*
   STOP
*
*********************  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.JSON = ''
*
   RETURN
*
*********************  S U B R O U T I N E  *********************
*
READ.REQUEST:NULL
*
   BUFFER.SIZE = 300
*
   READ.DONE = FALSE
*
   LOOP UNTIL READ.DONE DO
      $IFDEF DATABASE.D3
         CHAR BUFFER[BUFFER.SIZE]
      $ENDIF
*
      $IFDEF DATABASE.QM
         CHAR BUFFER[BUFFER.SIZE]
      $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
         BUFFER = READ.SOCKET(FD,BUFFER.SIZE,1,0)
      $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
*
      END ELSE IF READ.SIZE < BUFFER.SIZE THEN
         RAW.REQUEST = RAW.REQUEST : BUFFER[1,BUFFER.SIZE]
         READ.DONE = TRUE
*
      END ELSE
         RAW.REQUEST = RAW.REQUEST : BUFFER
      END
   REPEAT
*
   RETURN
*
*********************  S U B R O U T I N E  *********************
*
GET.STATUS.LINE:NULL
*
   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)
   IF INDEX(ALLOWED.METHODS,REQUEST.TYPE:' ',1) = 0 THEN
      REQUEST.ERROR = 'Invalid request - type: ' : REQUEST.TYPE
      RETURN
   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 = 'POST' THEN
      HEADERS = RAW.REQUEST[START.POS+2,INDEX(RAW.REQUEST,BODY.DELIMITER,1)-START.POS-2]
   END ELSE
      HEADERS = RAW.REQUEST[START.POS+2,LEN(RAW.REQUEST)-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
*
   LOCATE('Cookie',REQUEST.HEADERS<1>,1;ANYPOS) 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
      REQUEST.ERROR = 'Cannot find Content-Type, make sure it is spelled correctly.'
      RETURN
   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]
*
   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,-1> = TOKEN
            TOKEN = ''
*
         END ELSE IF LETTER = '&' THEN
            REQUEST.FORM<2,-1> = TOKEN
            TOKEN = ''
*
         END ELSE
            TOKEN = TOKEN : LETTER
         END
      NEXT I
*
      IF TOKEN # '' THEN
         REQUEST.FORM<2,-1> = TOKEN
      END
*
   END ELSE IF CONTENT.TYPE = 'application/json' THEN
      REQUEST.JSON = REQUEST.RAW.BODY
*
   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
*
   RESPONSE.STATUS = RESPONSE(RESPONSE.STATUS.ATTRIBUTE)
   RESPONSE.BODY = CHANGE(RESPONSE(RESPONSE.CONTENT.ATTRIBUTE),@AM,CR:LF)
*
   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: HTTP.SERVER'
   BUFFER<-1> = 'Access-Control-Allow-Origin: *'
   BUFFER<-1> = 'Access-Control-Allow-Methods: GET, POST, OPTIONS, DELETE, 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: text/html'
   BUFFER<-1> = 'Connection: Closed'
*
   BUFFER = BUFFER : @AM : '' : @AM : RESPONSE.BODY
*
   BUFFER = CHANGE(BUFFER,@AM,CR:LF)
*
   BUFFER.LENGTH = LEN(BUFFER)
*
   $IFDEF DATABASE.D3
      CODE = %SEND(FD,BUFFER,BUFFER.LENGTH,0)
   $ENDIF
*
   $IFDEF DATABASE.QM
      WRITE.SIZE = WRITE.SOCKET(FD,BUFFER,0,0)
   $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.REQUEST:NULL
*
   PRINT '< [' : OCONV(DATE(),'D') : ' ' :
   PRINT OCONV(TIME(),'MTH') : '] ' :
   PRINT REQUEST.TYPE : ' ' :
   PRINT REQUEST.URL : ' '
*
   RETURN
*
*********************  S U B R O U T I N E  *********************
*
LOG.RESPONSE:NULL
*
   PRINT '> [' : OCONV(DATE(),'D') : ' ' :
   PRINT OCONV(TIME(),'MTH') : '] ' :
   PRINT REQUEST.TYPE : ' ' :
   PRINT REQUEST.URL : ' ' :
   PRINT RESPONSE.STATUS : ' ' :
   PRINT TIME.TAKEN : 's '
*
   RETURN
*
* END OF PROGRAM
*
   END
*