/*
 * Copyright 2009 Mindaugas Kavaliauskas <dbtopas / at / dbtopas.lt>
 */

#include "hbclass.ch"
#include "error.ch"
#include "hbsocket.ch"
#include "hbthread.ch"

#include "hbssl.ch"
#undef __HBEXTREQ__
#include "hbssl.hbx"

#pragma -km+

/* Docs:

   RFC 1945 - Hypertext Transfer Protocol -- HTTP/1.0 - https://tools.ietf.org/html/rfc1945
   RFC 2616 - Hypertext Transfer Protocol -- HTTP/1.1 - https://tools.ietf.org/html/rfc2616
   HTTP Made Really Easy - https://www.jmarshall.com/easy/http/
 */

#define THREAD_COUNT_PREALLOC   3
#define THREAD_COUNT_MAX        50
#define SESSION_TIMEOUT         600

#define CR_LF                   ( Chr( 13 ) + Chr( 10 ) )

THREAD STATIC t_cResult, t_nStatusCode, t_aHeader, t_aSessionData

MEMVAR server, get, post, cookie, session, httpd

CREATE CLASS UHttpd MODULE FRIENDLY

   EXPORTED:

   METHOD Run( hConfig )
   METHOD Stop()

   VAR cError INIT ""

   HIDDEN:

   VAR hConfig

   VAR aFirewallFilter

   VAR hmtxQueue
   VAR hmtxLog
   VAR hmtxSession

   VAR hListen
   VAR hSSLCtx
   VAR hSession

   VAR lStop

   VAR lHasSSL INIT hb_IsFunction( "__HBEXTERN__HBSSL__" )

   METHOD LogAccess()
   METHOD LogError( cError )

ENDCLASS

FUNCTION UHttpdNew()
   RETURN UHttpd()

METHOD Run( hConfig ) CLASS UHttpd

   LOCAL hSocket, nI, aI, xValue, aThreads, nJobs, nWorkers

   IF ! hb_mtvm()
      ::cError := "Multithread support required"
      RETURN .F.
   ENDIF

   ::hConfig := { ;
      "SSL"                  => .F., ;
      "Port"                 => 80, ;
      "BindAddress"          => "0.0.0.0", ;
      "LogAccess"            => {|| NIL }, ;
      "LogError"             => {|| NIL }, ;
      "Trace"                => {|| NIL }, ;
      "Idle"                 => {|| NIL }, ;
      "Mount"                => { => }, ;
      "PrivateKeyFilename"   => "", ;
      "CertificateFilename"  => "", ;
      "FirewallFilter"       => "0.0.0.0/0" }

   FOR EACH xValue IN hConfig
      IF ! hb_HHasKey( ::hConfig, xValue:__enumKey ) .OR. !( ValType( xValue ) == ValType( ::hConfig[ xValue:__enumKey ] ) )
         ::cError := "Invalid config option '" + xValue:__enumKey + "'"
         RETURN .F.
      ENDIF
      ::hConfig[ xValue:__enumKey ] := xValue
   NEXT

   IF ::hConfig[ "SSL" ]
      IF ::lHasSSL
         SSL_init()
         DO WHILE RAND_status() != 1
            RAND_add( Str( hb_Random(), 18, 15 ) + Str( hb_MilliSeconds(), 20 ), 1 )
         ENDDO

         ::hSSLCtx := SSL_CTX_new( HB_SSL_CTX_NEW_METHOD_SSLV23_SERVER )
         SSL_CTX_set_options( ::hSSLCtx, HB_SSL_OP_NO_TLSv1 )
         IF SSL_CTX_use_PrivateKey_file( ::hSSLCtx, ::hConfig[ "PrivateKeyFilename" ], HB_SSL_FILETYPE_PEM ) != 1
            ::cError := "Invalid private key file"
            RETURN .F.
         ENDIF
         IF SSL_CTX_use_certificate_file( ::hSSLCtx, ::hConfig[ "CertificateFilename" ], HB_SSL_FILETYPE_PEM ) != 1
            ::cError := "Invalid certificate file"
            RETURN .F.
         ENDIF
      ELSE
         ::cError := "SSL not supported"
         RETURN .F.
      ENDIF
   ENDIF

   IF ::hConfig[ "Port" ] < 1 .OR. ::hConfig[ "Port" ] > 65535
      ::cError := "Invalid port number"
      RETURN .F.
   ENDIF

   IF ParseFirewallFilter( ::hConfig[ "FirewallFilter" ], @aI )
      ::aFirewallFilter := aI
   ELSE
      ::cError := "Invalid firewall filter"
      RETURN .F.
   ENDIF

   ::hmtxQueue   := hb_mutexCreate()
   ::hmtxLog     := hb_mutexCreate()
   ::hmtxSession := hb_mutexCreate()

   IF Empty( ::hListen := hb_socketOpen() )
      ::cError := "Socket create error: " + hb_socketErrorString()
      RETURN .F.
   ENDIF

   IF ! hb_socketBind( ::hListen, { HB_SOCKET_AF_INET, ::hConfig[ "BindAddress" ], ::hConfig[ "Port" ] } )
      ::cError := "Bind error: " + hb_socketErrorString()
      hb_socketClose( ::hListen )
      RETURN .F.
   ENDIF

   IF ! hb_socketListen( ::hListen )
      ::cError := "Listen error: " + hb_socketErrorString()
      hb_socketClose( ::hListen )
      RETURN .F.
   ENDIF

   aThreads := {}
   FOR nI := 1 TO THREAD_COUNT_PREALLOC
      AAdd( aThreads, hb_threadStart( HB_THREAD_INHERIT_PUBLIC, @ProcessConnection(), Self ) )
   NEXT

   ::lStop := .F.
   ::hSession := { => }

   DO WHILE .T.
      IF Empty( hSocket := hb_socketAccept( ::hListen,, 1000 ) )
         IF hb_socketGetError() == HB_SOCKET_ERR_TIMEOUT
            Eval( ::hConfig[ "Idle" ], Self )
            IF ::lStop
               EXIT
            ENDIF
         ELSE
            ::LogError( "[error] Accept error: " + hb_socketErrorString() )
         ENDIF
      ELSE
         Eval( ::hConfig[ "Trace" ], "New connection", hSocket )
         IF hb_mutexQueueInfo( ::hmtxQueue, @nWorkers, @nJobs ) .AND. ;
               Len( aThreads ) < THREAD_COUNT_MAX .AND. ;
               nJobs >= nWorkers
            AAdd( aThreads, hb_threadStart( HB_THREAD_INHERIT_PUBLIC, @ProcessConnection(), Self ) )
         ENDIF
         hb_mutexNotify( ::hmtxQueue, hSocket )
      ENDIF
   ENDDO
   hb_socketClose( ::hListen )

   /* End child threads */
   AEval( aThreads, {|| hb_mutexNotify( ::hmtxQueue, NIL ) } )
   AEval( aThreads, {| h | hb_threadJoin( h ) } )

   RETURN .T.

METHOD Stop() CLASS UHttpd

   Eval( ::hConfig[ "Trace" ], "stopping" )
   ::lStop := .T.

   RETURN NIL

METHOD LogError( cError ) CLASS UHttpd

   hb_mutexLock( ::hmtxLog )
   Eval( ::hConfig[ "LogError" ], DToS( Date() ) + " " + Time() + " " + cError )
   hb_mutexUnlock( ::hmtxLog )

   RETURN NIL

METHOD LogAccess() CLASS UHttpd

   LOCAL cDate := DToS( Date() ), cTime := Time()

   hb_mutexLock( ::hmtxLog )
   Eval( ::hConfig[ "LogAccess" ], ;
      server[ "REMOTE_ADDR" ] + " - - [" + Right( cDate, 2 ) + "/" + ;
      { "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" }[ Val( SubStr( cDate, 5, 2 ) ) ] + ;
      "/" + Left( cDate, 4 ) + ":" + cTime + ' +0000] "' + server[ "REQUEST_ALL" ] + '" ' + ;
      hb_ntos( t_nStatusCode ) + " " + hb_ntos( Len( t_cResult ) ) + ;
      ' "' + server[ "HTTP_REFERER" ] + '" "' + server[ "HTTP_USER_AGENT" ] + ;
      '"' )
   hb_mutexUnlock( ::hmtxLog )

   RETURN NIL

STATIC FUNCTION IPAddr2Num( cIP )

   LOCAL aA, n1, n2, n3, n4

   aA := hb_regex( "^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$", cIP )
   IF Len( aA ) == 5 .AND. ( n1 := Val( aA[ 2 ] ) ) <= 255 .AND. ( n2 := Val( aA[ 3 ] ) ) <= 255 .AND. ;
         ( n3 := Val( aA[ 4 ] ) ) <= 255 .AND. ( n4 := Val( aA[ 5 ] ) ) <= 255
      RETURN ( ( ( n1 * 256 ) + n2 ) * 256 + n3 ) * 256 + n4
   ENDIF

   RETURN NIL

STATIC FUNCTION ParseFirewallFilter( cFilter, aFilter )

   LOCAL cExpr, nI, cI, nPrefix, nAddr, nAddr2, nPos, nPos2, lDeny, aDeny, aI

   aFilter := { => }
   hb_HKeepOrder( aFilter, .F. )
   aDeny := {}
   FOR EACH cExpr IN hb_ATokens( cFilter, " " )
      IF ! Empty( cExpr )
         IF lDeny := ( Left( cExpr, 1 ) == "!" )
            cExpr := SubStr( cExpr, 2 )
         ENDIF
         IF ( nI := At( "/", cExpr ) ) > 0
            cI := SubStr( cExpr, nI + 1 )
            cExpr := Left( cExpr, nI - 1 )
            IF "." $ cI
               IF ( nI := IPAddr2Num( cI ) ) == NIL
                  RETURN .F.
               ENDIF
               nPrefix := 32
               DO WHILE hb_bitAnd( nI, 1 ) == 0
                  nPrefix--
                  nI := hb_bitShift( nI, -1 )
               ENDDO
               IF nI + 1 != hb_bitShift( 1, nPrefix )
                  RETURN .F.
               ENDIF
            ELSE
               nPrefix := Val( cI )
               IF nPrefix < 0 .OR. nPrefix > 32 .OR. ! hb_ntos( nPrefix ) == cI
                  RETURN .F.
               ENDIF
            ENDIF
         ELSE
            nPrefix := 32
         ENDIF
         IF ( nAddr := IPAddr2Num( cExpr ) ) == NIL
            RETURN .F.
         ENDIF
         nPrefix := 0x100000000 - hb_bitShift( 1, 32 - nPrefix )

         // Remove unnecessary network address part
         nAddr := hb_bitAnd( nAddr, nPrefix )
         nAddr2 := hb_bitOr( nAddr, hb_bitXor( nPrefix, 0xFFFFFFFF ) )

         IF lDeny
            AAdd( aDeny, { nAddr, nAddr2 } )
         ELSE
            // Add to filter
            hb_HHasKey( aFilter, nAddr, @nPos )
            IF nPos == 0 .OR. hb_HValueAt( aFilter, nPos ) + 1 < nAddr
               // Does not overlap/glue with nPos
               // So, add new interval
               aFilter[ nAddr ] := nAddr2
               nPos++
            ENDIF
            hb_HHasKey( aFilter, nAddr2 + 1, @nPos2 )
            // Merge and delete inner subintervals
            aFilter[ hb_HKeyAt( aFilter, nPos ) ] := Max( hb_HValueAt( aFilter, nPos2 ), nAddr2 )
            DO WHILE nPos2-- > nPos
               hb_HDelAt( aFilter, nPos + 1 )
            ENDDO
         ENDIF
      ENDIF
   NEXT

   FOR EACH aI IN aDeny
      nAddr := aI[ 1 ]
      nAddr2 := aI[ 2 ]

      // Delete from filter
      hb_HHasKey( aFilter, nAddr, @nPos )
      IF nPos == 0 .OR. hb_HValueAt( aFilter, nPos ) < nAddr
         nPos++
      ENDIF
      IF nPos > Len( aFilter )
         LOOP
      ENDIF

      hb_HHasKey( aFilter, nAddr2, @nPos2 )
      IF nPos2 > 0 .AND. hb_HValueAt( aFilter, nPos2 ) > nAddr2
         aFilter[ nAddr2 + 1 ] := hb_HValueAt( aFilter, nPos2 )
      ENDIF
      IF nAddr > hb_HKeyAt( aFilter, nPos )
         aFilter[ hb_HKeyAt( aFilter, nPos ) ] := nAddr - 1
         nPos++
      ENDIF
      DO WHILE nPos2-- >= nPos
         hb_HDelAt( aFilter, nPos )
      ENDDO
   NEXT

   RETURN .T.

STATIC FUNCTION MY_SSL_READ( hConfig, hSSL, hSocket, cBuf, nTimeout, nError )

   LOCAL nErr, nLen

   nLen := SSL_read( hSSL, @cBuf )
   IF nLen < 0
      nErr := SSL_get_error( hSSL, nLen )
      IF nErr == HB_SSL_ERROR_WANT_READ
         nErr := hb_socketSelectRead( hSocket, nTimeout )
         IF nErr < 0
            nError := hb_socketGetError()
         ELSE // Both cases: data received and timeout
            nError := HB_SOCKET_ERR_TIMEOUT
         ENDIF
         RETURN -1
      ELSEIF nErr == HB_SSL_ERROR_WANT_WRITE
         nErr := hb_socketSelectWrite( hSocket, nTimeout )
         IF nErr < 0
            nError := hb_socketGetError()
         ELSE // Both cases: data sent and timeout
            nError := HB_SOCKET_ERR_TIMEOUT
         ENDIF
         RETURN -1
      ELSE
         Eval( hConfig[ "Trace" ], "SSL_read() error", nErr )
         nError := 1000 + nErr
         RETURN -1
      ENDIF
   ENDIF

   RETURN nLen

STATIC FUNCTION MY_SSL_WRITE( hConfig, hSSL, hSocket, cBuf, nTimeout, nError )

   LOCAL nErr, nLen

   nLen := SSL_write( hSSL, cBuf )
   IF nLen <= 0
      nErr := SSL_get_error( hSSL, nLen )
      IF nErr == HB_SSL_ERROR_WANT_READ
         nErr := hb_socketSelectRead( hSocket, nTimeout )
         IF nErr < 0
            nError := hb_socketGetError()
            RETURN -1
         ELSE  // Both cases: data received and timeout
            RETURN 0
         ENDIF
      ELSEIF nErr == HB_SSL_ERROR_WANT_WRITE
         nErr := hb_socketSelectWrite( hSocket, nTimeout )
         IF nErr < 0
            nError := hb_socketGetError()
            RETURN -1
         ELSE  // Both cases: data sent and timeout
            RETURN 0
         ENDIF
      ELSE
         Eval( hConfig[ "Trace" ], "SSL_write() error", nErr )
         nError := 1000 + nErr
         RETURN -1
      ENDIF
   ENDIF

   RETURN nLen

STATIC FUNCTION MY_SSL_ACCEPT( hConfig, hSSL, hSocket, nTimeout )

   LOCAL nErr

   nErr := SSL_accept( hSSL )
   IF nErr > 0
      RETURN 0
   ELSEIF nErr < 0
      nErr := SSL_get_error( hSSL, nErr )
      IF nErr == HB_SSL_ERROR_WANT_READ
         nErr := hb_socketSelectRead( hSocket, nTimeout )
         IF nErr < 0
            nErr := hb_socketGetError()
         ELSE
            nErr := HB_SOCKET_ERR_TIMEOUT
         ENDIF
      ELSEIF nErr == HB_SSL_ERROR_WANT_WRITE
         nErr := hb_socketSelectWrite( hSocket, nTimeout )
         IF nErr < 0
            nErr := hb_socketGetError()
         ELSE
            nErr := HB_SOCKET_ERR_TIMEOUT
         ENDIF
      ELSE
         Eval( hConfig[ "Trace" ], "SSL_accept() error", nErr )
         nErr := 1000 + nErr
      ENDIF
   ELSE /* nErr == 0 */
      nErr := SSL_get_error( hSSL, nErr )
      Eval( hConfig[ "Trace" ], "SSL_accept() shutdown error", nErr )
      nErr := 1000 + nErr
   ENDIF

   RETURN nErr

STATIC FUNCTION ProcessConnection( oServer )

   LOCAL hSocket, cRequest, aI, nLen, nErr, nTime, nReqLen, cBuf, aServer
   LOCAL hSSL

   ErrorBlock( {| o | UErrorHandler( o, oServer ) } )

   PRIVATE server, get, post, cookie, session, httpd

   httpd := oServer

   /* main worker thread loop */
   DO WHILE .T.
      hb_mutexSubscribe( oServer:hmtxQueue,, @hSocket )
      IF hSocket == NIL
         EXIT
      ENDIF

      /* Prepare server variable and clone it for every query,
         because request handler script can ruin variable value */
      aServer := { => }
      aServer[ "HTTPS" ] := oServer:hConfig[ "SSL" ]
      IF ! Empty( aI := hb_socketGetPeerName( hSocket ) )
         aServer[ "REMOTE_ADDR" ] := aI[ 2 ]
         aServer[ "REMOTE_HOST" ] := aServer[ "REMOTE_ADDR" ] // no reverse DNS
         aServer[ "REMOTE_PORT" ] := aI[ 3 ]
      ENDIF
      IF ! Empty( aI := hb_socketGetSockName( hSocket ) )
         aServer[ "SERVER_ADDR" ] := aI[ 2 ]
         aServer[ "SERVER_PORT" ] := aI[ 3 ]
      ENDIF

      /* Firewall */
      nLen := IPAddr2Num( aServer[ "REMOTE_ADDR" ] )
      hb_HHasKey( oServer:aFirewallFilter, nLen, @nErr )
      IF nErr > 0 .AND. nLen <= hb_HValueAt( oServer:aFirewallFilter, nErr )
         Eval( oServer:hConfig[ "Trace" ], "Firewall denied", aServer[ "REMOTE_ADDR" ] )
         hb_socketShutdown( hSocket )
         hb_socketClose( hSocket )
         LOOP
      ENDIF

      IF oServer:lHasSSL .AND. oServer:hConfig[ "SSL" ]
         hSSL := SSL_new( oServer:hSSLCtx )
         SSL_set_mode( hSSL, hb_bitOr( SSL_get_mode( hSSL ), HB_SSL_MODE_ENABLE_PARTIAL_WRITE ) )
         hb_socketSetBlockingIO( hSocket, .F. )
         SSL_set_fd( hSSL, hb_socketGetFD( hSocket ) )

         nTime := hb_MilliSeconds()
         DO WHILE .T.
            IF ( nErr := MY_SSL_ACCEPT( oServer:hConfig, hSSL, hSocket, 1000 ) ) == 0
               EXIT
            ELSE
               IF nErr == HB_SOCKET_ERR_TIMEOUT
                  IF ( hb_MilliSeconds() - nTime ) > 1000 * 30 .OR. oServer:lStop
                     Eval( oServer:hConfig[ "Trace" ], "SSL accept timeout", hSocket )
                     EXIT
                  ENDIF
               ELSE
                  Eval( oServer:hConfig[ "Trace" ], "SSL accept error:", nErr, hb_socketErrorString( nErr ) )
                  EXIT
               ENDIF
            ENDIF
         ENDDO

         IF nErr != 0
            Eval( oServer:hConfig[ "Trace" ], "Close connection", hSocket )
            hb_socketShutdown( hSocket )
            hb_socketClose( hSocket )
            LOOP
         ENDIF

         aServer[ "SSL_CIPHER" ] := SSL_get_cipher( hSSL )
         aServer[ "SSL_PROTOCOL" ] := SSL_get_version( hSSL )
         aServer[ "SSL_CIPHER_USEKEYSIZE" ] := SSL_get_cipher_bits( hSSL, @nErr )
         aServer[ "SSL_CIPHER_ALGKEYSIZE" ] := nErr
         aServer[ "SSL_VERSION_LIBRARY" ] := SSLeay_version( HB_SSLEAY_VERSION )
         aServer[ "SSL_SERVER_I_DN" ] := X509_name_oneline( X509_get_issuer_name( SSL_get_certificate( hSSL ) ) )
         aServer[ "SSL_SERVER_S_DN" ] := X509_name_oneline( X509_get_subject_name( SSL_get_certificate( hSSL ) ) )
      ENDIF

      /* loop for processing connection */

      /* Set cRequest to empty string here. This enables request pipelining */
      cRequest := ""
      DO WHILE ! oServer:lStop

         /* receive query header */
         nLen := 1
         nTime := hb_MilliSeconds()
         cBuf := Space( 4096 )
         DO WHILE At( CR_LF + CR_LF, cRequest ) == 0
            IF oServer:lHasSSL .AND. oServer:hConfig[ "SSL" ]
               nLen := MY_SSL_READ( oServer:hConfig, hSSL, hSocket, @cBuf, 1000, @nErr )
            ELSE
               nLen := hb_socketRecv( hSocket, @cBuf,,, 1000 )
               IF nLen < 0
                  nErr := hb_socketGetError()
               ENDIF
            ENDIF

            IF nLen > 0
               cRequest += hb_BLeft( cBuf, nLen )
            ELSEIF nLen == 0
               /* connection closed */
               EXIT
            ELSE
               /* nLen == -1  socket error */
               IF nErr == HB_SOCKET_ERR_TIMEOUT
                  IF ( hb_MilliSeconds() - nTime ) > 1000 * 30 .OR. oServer:lStop
                     Eval( oServer:hConfig[ "Trace" ], "receive timeout", hSocket )
                     EXIT
                  ENDIF
               ELSE
                  Eval( oServer:hConfig[ "Trace" ], "receive error:", nErr, hb_socketErrorString( nErr ) )
                  EXIT
               ENDIF
            ENDIF
         ENDDO

         IF nLen <= 0 .OR. oServer:lStop
            EXIT
         ENDIF

         // PRIVATE
         server := hb_HClone( aServer )
         get := { => }
         post := { => }
         cookie := { => }
         session := NIL

         t_cResult := ""
         t_aHeader := {}
         t_nStatusCode := 200
         t_aSessionData := NIL

         Eval( oServer:hConfig[ "Trace" ], Left( cRequest, At( CR_LF + CR_LF, cRequest ) + 1 ) )

         nReqLen := ParseRequestHeader( @cRequest )
         IF nReqLen == NIL
            USetStatusCode( 400 )
            UAddHeader( "Connection", "close" )
         ELSE

            /* receive query body */
            nLen := 1
            nTime := hb_MilliSeconds()
            cBuf := Space( 4096 )
            DO WHILE Len( cRequest ) < nReqLen
               IF oServer:lHasSSL .AND. oServer:hConfig[ "SSL" ]
                  nLen := MY_SSL_READ( oServer:hConfig, hSSL, hSocket, @cBuf, 1000, @nErr )
               ELSE
                  nLen := hb_socketRecv( hSocket, @cBuf,,, 1000 )
                  IF nLen < 0
                     nErr := hb_socketGetError()
                  ENDIF
               ENDIF

               IF nLen > 0
                  cRequest += hb_BLeft( cBuf, nLen )
               ELSEIF nLen == 0
                  /* connection closed */
                  EXIT
               ELSE
                  /* nLen == -1  socket error */
                  IF nErr == HB_SOCKET_ERR_TIMEOUT
                     IF ( hb_MilliSeconds() - nTime ) > 1000 * 120 .OR. oServer:lStop
                        Eval( oServer:hConfig[ "Trace" ], "receive timeout", hSocket )
                        EXIT
                     ENDIF
                  ELSE
                     Eval( oServer:hConfig[ "Trace" ], "receive error:", nErr, hb_socketErrorString( nErr ) )
                     EXIT
                  ENDIF
               ENDIF
            ENDDO

            IF nLen <= 0 .OR. oServer:lStop
               EXIT
            ENDIF

            Eval( oServer:hConfig[ "Trace" ], cRequest )
            ParseRequestBody( Left( cRequest, nReqLen ) )
            cRequest := SubStr( cRequest, nReqLen + 1 )

            /* Deal with supported protocols and methods */
            IF !( Left( server[ "SERVER_PROTOCOL" ], 5 ) == "HTTP/" )
               USetStatusCode( 400 ) /* Bad request */
               UAddHeader( "Connection", "close" )
            ELSEIF ! SubStr( server[ "SERVER_PROTOCOL" ], 6 ) $ "1.0 1.1"
               USetStatusCode( 505 ) /* HTTP version not supported */
            ELSEIF ! server[ "REQUEST_METHOD" ] $ "GET POST"
               USetStatusCode( 501 ) /* Not implemented */
            ELSE
               IF server[ "SERVER_PROTOCOL" ] == "HTTP/1.1"
                  IF Lower( server[ "HTTP_CONNECTION" ] ) == "close"
                     UAddHeader( "Connection", "close" )
                  ELSE
                     UAddHeader( "Connection", "keep-alive" )
                  ENDIF
               ENDIF

               /* Do the job */
               ProcessRequest( oServer )
               dbCloseAll()
            ENDIF
         ENDIF /* request header ok */

         // Send response
         cBuf := MakeResponse( oServer:hConfig )

         DO WHILE hb_BLen( cBuf ) > 0 .AND. ! oServer:lStop
            IF oServer:lHasSSL .AND. oServer:hConfig[ "SSL" ]
               nLen := MY_SSL_WRITE( oServer:hConfig, hSSL, hSocket, cBuf, 1000, @nErr )
            ELSE
               nLen := hb_socketSend( hSocket, cBuf,,, 1000 )
               IF nLen < 0
                  nErr := hb_socketGetError()
               ENDIF
            ENDIF

            IF nLen < 0
               Eval( oServer:hConfig[ "Trace" ], "send error:", nErr, hb_socketErrorString( nErr ) )
               EXIT
            ELSEIF nLen > 0
               cBuf := hb_BSubStr( cBuf, nLen + 1 )
            ENDIF
         ENDDO

         IF oServer:lStop
            EXIT
         ENDIF

         oServer:LogAccess()

         IF Lower( UGetHeader( "Connection" ) ) == "close" .OR. server[ "SERVER_PROTOCOL" ] == "HTTP/1.0"
            EXIT
         ENDIF
      ENDDO

      IF oServer:lHasSSL
         hSSL := NIL
      ENDIF

      Eval( oServer:hConfig[ "Trace" ], "Close connection1", hSocket )
      hb_socketShutdown( hSocket )
      hb_socketClose( hSocket )
   ENDDO

   RETURN 0

STATIC PROCEDURE ProcessRequest( oServer )

   LOCAL nI, aMount, cMount, cPath, bEval, xRet, nT := hb_MilliSeconds()

   // Search mounting table
   aMount := oServer:hConfig[ "Mount" ]
   cMount := server[ "SCRIPT_NAME" ]
   IF hb_HHasKey( aMount, cMount )
      cPath := ""
   ELSE
      nI := Len( cMount )
      DO WHILE ( nI := hb_RAt( "/", cMount,, nI ) ) > 0
         IF hb_HHasKey( aMount, Left( cMount, nI ) + "*" )
            Eval( oServer:hConfig[ "Trace" ], "HAS", Left( cMount, nI ) + "*" )
            cMount := Left( cMount, nI ) + "*"
            cPath := SubStr( server[ "SCRIPT_NAME" ], nI + 1 )
            EXIT
         ENDIF
         IF --nI == 0
            EXIT
         ENDIF
      ENDDO
   ENDIF

   IF cPath != NIL
      bEval := aMount[ cMount ]
      BEGIN SEQUENCE WITH {| oErr | UErrorHandler( oErr, oServer ) }
         xRet := Eval( bEval, cPath )
         IF HB_ISSTRING( xRet )
            UWrite( xRet )
         ELSEIF HB_ISHASH( xRet )
            UWrite( UParse( xRet ) )
         ENDIF
      RECOVER
         USetStatusCode( 500 )
         UAddHeader( "Connection", "close" )
      END SEQUENCE
      dbCloseAll()
      // Unlock session
      IF t_aSessionData != NIL
         session := NIL
         hb_mutexUnlock( t_aSessionData[ 1 ] )
         t_aSessionData := NIL
      ENDIF
   ELSE
      USetStatusCode( 404 )
   ENDIF
   Eval( oServer:hConfig[ "Trace" ], "ProcessRequest time:", hb_ntos( hb_MilliSeconds() - nT ), "ms" )

   RETURN

STATIC FUNCTION ParseRequestHeader( cRequest )

   LOCAL aRequest, aLine, nI, nJ, cI, nK, nContentLength := 0

   nI := At( CR_LF + CR_LF, cRequest )
   aRequest := hb_ATokens( Left( cRequest, nI - 1 ), CR_LF )
   cRequest := SubStr( cRequest, nI + 4 )

   aLine := hb_ATokens( aRequest[ 1 ], " " )

   server[ "REQUEST_ALL" ] := aRequest[ 1 ]
   IF Len( aLine ) == 3 .AND. Left( aLine[ 3 ], 5 ) == "HTTP/"
      server[ "REQUEST_METHOD" ] := aLine[ 1 ]
      server[ "REQUEST_URI" ] := aLine[ 2 ]
      server[ "SERVER_PROTOCOL" ] := aLine[ 3 ]
   ELSE
      server[ "REQUEST_METHOD" ] := aLine[ 1 ]
      server[ "REQUEST_URI" ] := iif( Len( aLine ) >= 2, aLine[ 2 ], "" )
      server[ "SERVER_PROTOCOL" ] := iif( Len( aLine ) >= 3, aLine[ 3 ], "" )
      RETURN NIL
   ENDIF

   // Fix invalid queries: bind to root
   IF !( Left( server[ "REQUEST_URI" ], 1 ) == "/" )
      server[ "REQUEST_URI" ] := "/" + server[ "REQUEST_URI" ]
   ENDIF

   IF ( nI := At( "?", server[ "REQUEST_URI" ] ) ) > 0
      server[ "SCRIPT_NAME" ] := Left( server[ "REQUEST_URI" ], nI - 1 )
      server[ "QUERY_STRING" ] := SubStr( server[ "REQUEST_URI" ], nI + 1 )
   ELSE
      server[ "SCRIPT_NAME" ] := server[ "REQUEST_URI" ]
      server[ "QUERY_STRING" ] := ""
   ENDIF

   server[ "HTTP_ACCEPT" ] := ""
   server[ "HTTP_ACCEPT_CHARSET" ] := ""
   server[ "HTTP_ACCEPT_ENCODING" ] := ""
   server[ "HTTP_ACCEPT_LANGUAGE" ] := ""
   server[ "HTTP_CONNECTION" ] := ""
   server[ "HTTP_HOST" ] := ""
   server[ "HTTP_KEEP_ALIVE" ] := ""
   server[ "HTTP_REFERER" ] := ""
   server[ "HTTP_USER_AGENT" ] := ""

   FOR nI := 2 TO Len( aRequest )
      IF aRequest[ nI ] == ""
         EXIT
      ELSEIF ( nJ := At( ":", aRequest[ nI ] ) ) > 0
         cI := AllTrim( SubStr( aRequest[ nI ], nJ + 1 ) )
         SWITCH Upper( Left( aRequest[ nI ], nJ - 1 ) )
         CASE "COOKIE"
            server[ "HTTP_COOKIE" ] := cI
            IF ( nK := At( ";", cI ) ) == 0
               nK := Len( RTrim( cI ) )
            ENDIF
            cI := Left( cI, nK )
            IF ( nK := At( "=", cI ) ) > 0
               /* cookie names are case insensitive, uppercase it */
               cookie[ Upper( Left( cI, nK - 1 ) ) ] := SubStr( cI, nK + 1 )
            ENDIF
            EXIT
         CASE "CONTENT-LENGTH"
            nContentLength := Val( cI )
            EXIT
         CASE "CONTENT-TYPE"
            server[ "CONTENT_TYPE" ] := cI
            EXIT
         OTHERWISE
            server[ "HTTP_" + StrTran( Upper( Left( aRequest[ nI ], nJ - 1 ) ), "-", "_" ) ] := cI
            EXIT
         ENDSWITCH
      ENDIF
   NEXT
   IF ! server[ "QUERY_STRING" ] == ""
      FOR EACH cI IN hb_ATokens( server[ "QUERY_STRING" ], "&" )
         IF ( nI := At( "=", cI ) ) > 0
            get[ UUrlDecode( Left( cI, nI - 1 ) ) ] := UUrlDecode( SubStr( cI, nI + 1 ) )
         ELSE
            get[ UUrlDecode( cI ) ] := NIL
         ENDIF
      NEXT
   ENDIF

   RETURN nContentLength

STATIC PROCEDURE ParseRequestBody( cRequest )

   LOCAL nI, cPart, cEncoding

   IF hb_HHasKey( server, "CONTENT_TYPE" ) .AND. ;
         Left( server[ "CONTENT_TYPE" ], 33 ) == "application/x-www-form-urlencoded"
      IF ( nI := At( "CHARSET=", Upper( server[ "CONTENT_TYPE" ] ) ) ) > 0
         cEncoding := Upper( SubStr( server[ "CONTENT_TYPE" ], nI + 8 ) )
      ENDIF
      IF ! cRequest == ""
         IF cEncoding == "UTF-8"
            FOR EACH cPart IN hb_ATokens( cRequest, "&" )
               IF ( nI := At( "=", cPart ) ) > 0
                  post[ hb_UTF8ToStr( UUrlDecode( Left( cPart, nI - 1 ) ) ) ] := hb_UTF8ToStr( UUrlDecode( SubStr( cPart, nI + 1 ) ) )
               ELSE
                  post[ hb_UTF8ToStr( UUrlDecode( cPart ) ) ] := NIL
               ENDIF
            NEXT
         ELSE
            FOR EACH cPart IN hb_ATokens( cRequest, "&" )
               IF ( nI := At( "=", cPart ) ) > 0
                  post[ UUrlDecode( Left( cPart, nI - 1 ) ) ] := UUrlDecode( SubStr( cPart, nI + 1 ) )
               ELSE
                  post[ UUrlDecode( cPart ) ] := NIL
               ENDIF
            NEXT
         ENDIF
      ENDIF
   ENDIF

   RETURN

STATIC FUNCTION MakeResponse( hConfig )

   LOCAL cRet, cStatus

   IF UGetHeader( "Content-Type" ) == NIL
      UAddHeader( "Content-Type", "text/html" )
   ENDIF
   UAddHeader( "Date", HttpDateFormat( hb_DateTime() ) )

   cRet := iif( server[ "SERVER_PROTOCOL" ] == "HTTP/1.0", "HTTP/1.0 ", "HTTP/1.1 " )
   SWITCH t_nStatusCode
   CASE 100 ; cStatus := "100 Continue"                        ;  EXIT
   CASE 101 ; cStatus := "101 Switching Protocols"             ;  EXIT
   CASE 200 ; cStatus := "200 OK"                              ;  EXIT
   CASE 201 ; cStatus := "201 Created"                         ;  EXIT
   CASE 202 ; cStatus := "202 Accepted"                        ;  EXIT
   CASE 203 ; cStatus := "203 Non-Authoritative Information"   ;  EXIT
   CASE 204 ; cStatus := "204 No Content"                      ;  EXIT
   CASE 205 ; cStatus := "205 Reset Content"                   ;  EXIT
   CASE 206 ; cStatus := "206 Partial Content"                 ;  EXIT
   CASE 300 ; cStatus := "300 Multiple Choices"                ;  EXIT
   CASE 301 ; cStatus := "301 Moved Permanently"               ;  EXIT
   CASE 302 ; cStatus := "302 Found"                           ;  EXIT
   CASE 303 ; cStatus := "303 See Other"                       ;  EXIT
   CASE 304 ; cStatus := "304 Not Modified"                    ;  EXIT
   CASE 305 ; cStatus := "305 Use Proxy"                       ;  EXIT
   CASE 307 ; cStatus := "307 Temporary Redirect"              ;  EXIT
   CASE 400 ; cStatus := "400 Bad Request"                     ;  EXIT
   CASE 401 ; cStatus := "401 Unauthorized"                    ;  EXIT
   CASE 402 ; cStatus := "402 Payment Required"                ;  EXIT
   CASE 403 ; cStatus := "403 Forbidden"                       ;  EXIT
   CASE 404 ; cStatus := "404 Not Found"                       ;  EXIT
   CASE 405 ; cStatus := "405 Method Not Allowed"              ;  EXIT
   CASE 406 ; cStatus := "406 Not Acceptable"                  ;  EXIT
   CASE 407 ; cStatus := "407 Proxy Authentication Required"   ;  EXIT
   CASE 408 ; cStatus := "408 Request Timeout"                 ;  EXIT
   CASE 409 ; cStatus := "409 Conflict"                        ;  EXIT
   CASE 410 ; cStatus := "410 Gone"                            ;  EXIT
   CASE 411 ; cStatus := "411 Length Required"                 ;  EXIT
   CASE 412 ; cStatus := "412 Precondition Failed"             ;  EXIT
   CASE 413 ; cStatus := "413 Request Entity Too Large"        ;  EXIT
   CASE 414 ; cStatus := "414 Request-URI Too Long"            ;  EXIT
   CASE 415 ; cStatus := "415 Unsupprted Media Type"           ;  EXIT
   CASE 416 ; cStatus := "416 Requested Range Not Satisfiable" ;  EXIT
   CASE 417 ; cStatus := "417 Expectation Failed"              ;  EXIT
   CASE 500 ; cStatus := "500 Internal Server Error"           ;  EXIT
   CASE 501 ; cStatus := "501 Not Implemented"                 ;  EXIT
   CASE 502 ; cStatus := "502 Bad Gateway"                     ;  EXIT
   CASE 503 ; cStatus := "503 Service Unavailable"             ;  EXIT
   CASE 504 ; cStatus := "504 Gateway Timeout"                 ;  EXIT
   CASE 505 ; cStatus := "505 HTTP Version Not Supported"      ;  EXIT
   OTHERWISE; cStatus := "500 Internal Server Error"
   ENDSWITCH

   cRet += cStatus + CR_LF
   IF t_nStatusCode != 200
      t_cResult := "<html><body><h1>" + cStatus + "</h1></body></html>"
   ENDIF
   UAddHeader( "Content-Length", hb_ntos( Len( t_cResult ) ) )
   AEval( t_aHeader, {| x | cRet += x[ 1 ] + ": " + x[ 2 ] + CR_LF } )
   cRet += CR_LF
   Eval( hConfig[ "Trace" ], cRet )
   cRet += t_cResult

   RETURN cRet

STATIC FUNCTION HttpDateFormat( tDate )

   tDate -= hb_UTCOffset() / ( 3600 * 24 )

   RETURN ;
      { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" }[ DoW( tDate ) ] + ", " + ;
      PadL( Day( tDate ), 2, "0" ) + " " + ;
      { "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" }[ Month( tDate ) ] + ;
      " " + PadL( Year( tDate ), 4, "0" ) + " " + hb_TToC( tDate, "", "HH:MM:SS" ) + " GMT" // FIXME: time zone

STATIC FUNCTION HttpDateUnformat( cDate, tDate )

   LOCAL nMonth, tI

   // TODO: support outdated compatibility format RFC2616
   IF Len( cDate ) == 29 .AND. Right( cDate, 4 ) == " GMT" .AND. SubStr( cDate, 4, 2 ) == ", "
      nMonth := AScan( { "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", ;
         "Oct", "Nov", "Dec" }, SubStr( cDate, 9, 3 ) )
      IF nMonth > 0
         tI := hb_SToT( SubStr( cDate, 13, 4 ) + PadL( nMonth, 2, "0" ) + SubStr( cDate, 6, 2 ) + StrTran( SubStr( cDate, 18, 8 ), ":" ) )
         IF ! Empty( tI )
            tDate := tI + hb_UTCOffset() / ( 3600 * 24 )
            RETURN .T.
         ENDIF
      ENDIF
   ENDIF

   RETURN .F.

STATIC FUNCTION UErrorHandler( oErr, oServer )

   Eval( oServer:hConfig[ "Trace" ], "UErrorHandler" )
   DO CASE
   CASE oErr:genCode == EG_ZERODIV
      RETURN 0
   CASE oErr:genCode == EG_LOCK
      RETURN .T.
   CASE ( oErr:genCode == EG_OPEN .AND. oErr:osCode == 32 .OR. ;
         oErr:genCode == EG_APPENDLOCK ) .AND. oErr:canDefault
      NetErr( .T. )
      RETURN .F.
   ENDCASE
   oServer:LogError( GetErrorDesc( oErr ) )
   IF oErr != NIL // Dummy check to avoid unreachable code warning for RETURN NIL
      Break( oErr )
   ENDIF

   RETURN NIL

STATIC FUNCTION GetErrorDesc( oErr )

   LOCAL cRet, nI, cI, aPar, nJ, xI

   cRet := "ERRORLOG ============================================================" + hb_eol() + ;
      "Error: " + oErr:subsystem + "/" + ErrDescCode( oErr:genCode ) + "(" + hb_ntos( oErr:genCode ) + ") " + ;
      hb_ntos( oErr:subcode ) + hb_eol()
   IF ! Empty( oErr:filename );      cRet += "File: " + oErr:filename + hb_eol()
   ENDIF
   IF ! Empty( oErr:description );   cRet += "Description: " + oErr:description + hb_eol()
   ENDIF
   IF ! Empty( oErr:operation );     cRet += "Operation: " + oErr:operation + hb_eol()
   ENDIF
   IF ! Empty( oErr:osCode );        cRet += "OS error: " + hb_ntos( oErr:osCode ) + hb_eol()
   ENDIF
   IF HB_ISARRAY( oErr:args )
      cRet += "Arguments:" + hb_eol()
      AEval( oErr:args, {| X, Y | cRet += Str( Y, 5 ) + ": " + hb_CStr( X ) + hb_eol() } )
   ENDIF
   cRet += hb_eol()

   cRet += "Stack:" + hb_eol()
   nI := 2
#if 0
   DO WHILE ! Empty( ProcName( ++nI ) )
      cRet += "    " + ProcName( nI ) + "(" + hb_ntos( ProcLine( nI ) ) + ")" + hb_eol()
   ENDDO
#else
   DO WHILE ! Empty( ProcName( ++nI ) )
      cI := "    " + ProcName( nI ) + "(" + hb_ntos( ProcLine( nI ) ) + ")"
      cI := PadR( cI, Max( 32, Len( cI ) + 1 ) )
      cI += "("
      aPar := __dbgVMParLList( nI )
      FOR nJ := 1 TO Len( aPar )
         cI += cvt2str( aPar[ nJ ] )
         IF nJ < Len( aPar )
            cI += ", "
         ENDIF
      NEXT
      cI += ")"
      nJ := Len( aPar )
      DO WHILE ! HB_ISSYMBOL( xI := __dbgVMVarLGet( nI, ++nJ ) )
         cI += ", " + cvt2str( xI )
      ENDDO
      xI := NIL
      cRet += cI + hb_eol()
   ENDDO
#endif
   cRet += hb_eol()

   cRet += "Executable:  " + hb_ProgName() + hb_eol()
   cRet += "Versions:" + hb_eol()
   cRet += "  OS: " + OS() + hb_eol()
   cRet += "  Harbour: " + Version() + ", " + hb_BuildDate() + hb_eol()
   cRet += hb_eol()

   IF oErr:genCode != EG_MEM
      cRet += "Database areas:" + hb_eol()
      cRet += "    Current: " + hb_ntos( Select() ) + "  " + Alias() + hb_eol()

      BEGIN SEQUENCE WITH {| o | Break( o ) }
         IF Used()
            cRet += "    Filter: " + dbFilter() + hb_eol()
            cRet += "    Relation: " + dbRelation() + hb_eol()
            cRet += "    Index expression: " + ordKey( ordSetFocus() ) + hb_eol()
            cRet += hb_eol()
            BEGIN SEQUENCE WITH {| o | Break( o ) }
               FOR nI := 1 TO FCount()
                  cRet += Str( nI, 6 ) + " " + PadR( FieldName( nI ), 14 ) + ": " + hb_ValToExp( FieldGet( nI ) ) + hb_eol()
               NEXT
            RECOVER
               cRet += "!!! Error reading database fields !!!" + hb_eol()
            END SEQUENCE
            cRet += hb_eol()
         ENDIF
      RECOVER
         cRet += "!!! Error accessing current workarea !!!" + hb_eol()
      END SEQUENCE

      FOR nI := 1 TO 250
         BEGIN SEQUENCE WITH {| o | Break( o ) }
            IF Used()
               dbSelectArea( nI )
               cRet += Str( nI, 6 ) + " " + rddName() + " " + PadR( Alias(), 15 ) + ;
                  Str( RecNo() ) + "/" + Str( LastRec() ) + ;
                  iif( Empty( ordSetFocus() ), "", " Index " + ordSetFocus() + "(" + hb_ntos( ordNumber() ) + ")" ) + hb_eol()
               dbCloseArea()
            ENDIF
         RECOVER
            cRet += "!!! Error accessing workarea number: " + Str( nI, 4 ) + "!!!" + hb_eol()
         END SEQUENCE
      NEXT
      cRet += hb_eol()
   ENDIF

   RETURN cRet

STATIC FUNCTION ErrDescCode( nCode )

   LOCAL cI := NIL

   IF nCode > 0 .AND. nCode <= 41
      cI := { ;
         "ARG"     , "BOUND"    , "STROVERFLOW", "NUMOVERFLOW", "ZERODIV" , "NUMERR"     , "SYNTAX"  , "COMPLEXITY" , ; //  1,  2,  3,  4,  5,  6,  7,  8
         NIL       , NIL        , "MEM"        , "NOFUNC"     , "NOMETHOD", "NOVAR"      , "NOALIAS" , "NOVARMETHOD", ; //  9, 10, 11, 12, 13, 14, 15, 16
         "BADALIAS", "DUPALIAS" , NIL          , "CREATE"     , "OPEN"    , "CLOSE"      , "READ"    , "WRITE"      , ; // 17, 18, 19, 20, 21, 22, 23, 24
         "PRINT"   , NIL        , NIL          , NIL          , NIL       , "UNSUPPORTED", "LIMIT"   , "CORRUPTION" , ; // 25, 26 - 29, 30, 31, 32
         "DATATYPE", "DATAWIDTH", "NOTABLE"    , "NOORDER"    , "SHARED"  , "UNLOCKED"   , "READONLY", "APPENDLOCK" , ; // 33, 34, 35, 36, 37, 38, 39, 40
         "LOCK"    }[ nCode ]                                                                                           // 41
   ENDIF

   RETURN iif( cI == NIL, "", "EG_" + cI )

STATIC FUNCTION cvt2str( xI, lLong )

   LOCAL cValtype, cI, xJ

   cValtype := ValType( xI )
   lLong := ! Empty( lLong )
   IF cValtype == "U"
      RETURN iif( lLong, "[U]:NIL", "NIL" )
   ELSEIF cValtype == "N"
      RETURN iif( lLong, "[N]:" + Str( xI ), hb_ntos( xI ) )
   ELSEIF cValtype $ "CM"
      IF Len( xI ) <= 260
         RETURN iif( lLong, "[" + cValtype + hb_ntos( Len( xI ) ) + "]:", "" ) + '"' + xI + '"'
      ELSE
         RETURN iif( lLong, "[" + cValtype + hb_ntos( Len( xI ) ) + "]:", "" ) + '"' + Left( xI, 100 ) + '"...'
      ENDIF
   ELSEIF cValtype == "A"
      RETURN "[A" + hb_ntos( Len( xI ) ) + "]"
   ELSEIF cValtype == "H"
      RETURN "[H" + hb_ntos( Len( xI ) ) + "]"
   ELSEIF cValtype == "O"
      cI := ""
      IF __objHasMsg( xI, "ID" )
         xJ := xI:ID
         IF ! HB_ISOBJECT( xJ )
            cI += ",ID=" + cvt2str( xJ )
         ENDIF
      ENDIF
      IF __objHasMsg( xI, "nID" )
         xJ := xI:nID
         IF ! HB_ISOBJECT( xJ )
            cI += ",NID=" + cvt2str( xJ )
         ENDIF
      ENDIF
      IF __objHasMsg( xI, "xValue" )
         xJ := xI:xValue
         IF ! HB_ISOBJECT( xJ )
            cI += ",XVALUE=" + cvt2str( xJ )
         ENDIF
      ENDIF
      RETURN "[O:" + xI:ClassName() + cI + "]"
   ELSEIF cValtype == "D"
      RETURN iif( lLong, "[D]:", "" ) + DToC( xI )
   ELSEIF cValtype == "L"
      RETURN iif( lLong, "[L]:", "" ) + iif( xI, ".T.", ".F." )
   ELSEIF cValtype == "P"
      RETURN iif( lLong, "[P]:", "" ) + "0p" + hb_NumToHex( xI )
   ELSE
      RETURN "[" + cValtype + "]" // BS,etc
   ENDIF

   RETURN NIL


/* Public functions */

PROCEDURE USetStatusCode( nStatusCode )

   t_nStatusCode := nStatusCode

   RETURN

FUNCTION UGetHeader( cType )

   LOCAL nI

   IF ( nI := AScan( t_aHeader, {| x | Upper( x[ 1 ] ) == Upper( cType ) } ) ) > 0
      RETURN t_aHeader[ nI ][ 2 ]
   ENDIF

   RETURN NIL

PROCEDURE UAddHeader( cType, cValue )

   LOCAL nI

   IF ( nI := AScan( t_aHeader, {| x | Upper( x[ 1 ] ) == Upper( cType ) } ) ) > 0
      t_aHeader[ nI ][ 2 ] := cValue
   ELSE
      AAdd( t_aHeader, { cType, cValue } )
   ENDIF

   RETURN

PROCEDURE URedirect( cURL, nCode )

   IF nCode == NIL
      nCode := 303
   ENDIF
   USetStatusCode( nCode )
   UAddHeader( "Location", cURL )

   RETURN

PROCEDURE UWrite( cString )

   t_cResult += cString

   RETURN

STATIC PROCEDURE USessionCreateInternal()

   LOCAL cSID, hMtx

   cSID := hb_MD5( DToS( Date() ) + Time() + Str( hb_Random(), 15, 12 ) )
   hMtx := hb_mutexCreate()
   hb_mutexLock( hMtx )
   t_aSessionData := httpd:hSession[ cSID ] := { hMtx, { "_unique" => hb_MD5( Str( hb_Random(), 15, 12 ) ) }, hb_MilliSeconds() + SESSION_TIMEOUT * 1000, cSID }
   session := t_aSessionData[ 2 ]
   UAddHeader( "Set-Cookie", "SESSID=" + cSID + "; path=/" )

   RETURN

STATIC PROCEDURE USessionDestroyInternal()

   hb_HDel( httpd:hSession, t_aSessionData[ 4 ] )
   hb_mutexUnlock( t_aSessionData[ 1 ] )
   UAddHeader( "Set-Cookie", "SESSID=" + t_aSessionData[ 4 ] + "; path=/; Max-Age=0" )

   RETURN

PROCEDURE USessionStart()

   LOCAL cSID

   IF hb_HHasKey( cookie, "SESSID" )
      cSID := cookie[ "SESSID" ]
   ENDIF

   hb_mutexLock( httpd:hmtxSession )
   IF cSID == NIL .OR. ! hb_HHasKey( httpd:hSession, cSID )
      // Session does not exist
      USessionCreateInternal()
   ELSE

      // Session exists
      t_aSessionData := httpd:hSession[ cSID ]
      IF hb_mutexLock( t_aSessionData[ 1 ], 0 )

         // No concurrent sessions
         IF t_aSessionData[ 3 ] > hb_MilliSeconds()
            t_aSessionData[ 3 ] := hb_MilliSeconds() + SESSION_TIMEOUT * 1000
            session := t_aSessionData[ 2 ]
         ELSE
            USessionDestroyInternal()
            USessionCreateInternal()
         ENDIF
      ELSE

         // Concurrent process exists
         hb_mutexUnlock( httpd:hmtxSession )

         // Wait for session
         hb_mutexLock( t_aSessionData[ 1 ] )

         // Check if session is not destroyed
         hb_mutexLock( httpd:hmtxSession )
         IF hb_HHasKey( httpd:hSession, cSID )
            // Session exists
            IF t_aSessionData[ 3 ] > hb_MilliSeconds()
               t_aSessionData[ 3 ] := hb_MilliSeconds() + SESSION_TIMEOUT * 1000
               session := t_aSessionData[ 2 ]
            ELSE
               USessionDestroyInternal()
               USessionCreateInternal()
            ENDIF
         ELSE
            // Session was destroyed by concurrent process
            USessionCreateInternal()
         ENDIF
      ENDIF
   ENDIF
   hb_mutexUnlock( httpd:hmtxSession )

   RETURN

PROCEDURE USessionStop()

   session := NIL
   hb_mutexUnlock( t_aSessionData[ 1 ] )
   t_aSessionData := NIL

   RETURN

PROCEDURE USessionDestroy()

   hb_mutexLock( httpd:hmtxSession )
   USessionDestroyInternal()
   USessionStop()
   hb_mutexUnlock( httpd:hmtxSession )

   RETURN

FUNCTION UOsFileName( cFileName )

   IF ! hb_ps() == "/"
      RETURN StrTran( cFileName, "/", hb_ps() )
   ENDIF

   RETURN cFileName

FUNCTION UHtmlEncode( cString )

   LOCAL nI, cI, cRet := ""

   FOR nI := 1 TO Len( cString )
      cI := SubStr( cString, nI, 1 )
      IF cI == "<"
         cRet += "&lt;"
      ELSEIF cI == ">"
         cRet += "&gt;"
      ELSEIF cI == "&"
         cRet += "&amp;"
      ELSEIF cI == '"'
         cRet += "&quot;"
      ELSE
         cRet += cI
      ENDIF
   NEXT

   RETURN cRet

FUNCTION UUrlEncode( cString )

   LOCAL nI, cI, cRet := ""

   FOR nI := 1 TO Len( cString )
      cI := SubStr( cString, nI, 1 )
      IF cI == " "
         cRet += "+"
      ELSEIF Asc( cI ) >= 127 .OR. Asc( cI ) <= 31 .OR. cI $ '=&%+'
         cRet += "%" + hb_StrToHex( cI )
      ELSE
         cRet += cI
      ENDIF
   NEXT

   RETURN cRet

FUNCTION UUrlDecode( cString )

   LOCAL nI

   cString := StrTran( cString, "+", " " )
   nI := 1
   DO WHILE nI <= Len( cString )
      nI := hb_At( "%", cString, nI )
      IF nI == 0
         EXIT
      ENDIF
      IF Upper( SubStr( cString, nI + 1, 1 ) ) $ "0123456789ABCDEF" .AND. ;
            Upper( SubStr( cString, nI + 2, 1 ) ) $ "0123456789ABCDEF"
         cString := Stuff( cString, nI, 3, hb_HexToStr( SubStr( cString, nI + 1, 2 ) ) )
      ENDIF
      nI++
   ENDDO

   RETURN cString

FUNCTION ULink( cText, cUrl )

   RETURN '<a href="' + cUrl + '">' + UHtmlEncode( cText ) + '</a>'

FUNCTION UUrlChecksum( cUrl )

   RETURN cUrl + iif( "?" $ cUrl, "&", "?" ) + "_ucs=" + hb_MD5( session[ "_unique" ] + cUrl + session[ "_unique" ] )

FUNCTION UUrlValidate( cUrl )

   LOCAL nI

   IF cUrl == NIL
      cUrl := server[ "REQUEST_URI" ]
   ENDIF
   IF ( nI := At( "?_ucs=", cUrl ) ) == 0
      nI := At( "&_ucs=", cUrl )
   ENDIF

   RETURN hb_MD5( session[ "_unique" ] + Left( cUrl, nI - 1 ) + session[ "_unique" ] ) == SubStr( cUrl, nI + 6 )

PROCEDURE UProcFiles( cFileName, lIndex )

   LOCAL aDir, aF, nI, cI, tDate, tHDate

   IF ! HB_ISLOGICAL( lIndex )
      lIndex := .F.
   ENDIF

   cFileName := StrTran( cFileName, "//", "/" )

   // Security
   IF "/../" $ cFileName
      USetStatusCode( 403 )
      RETURN
   ENDIF

   IF hb_FileExists( UOsFileName( cFileName ) )
      IF hb_HHasKey( server, "HTTP_IF_MODIFIED_SINCE" ) .AND. ;
            HttpDateUnformat( server[ "HTTP_IF_MODIFIED_SINCE" ], @tHDate ) .AND. ;
            hb_FGetDateTime( UOsFileName( cFileName ), @tDate ) .AND. ;
            tDate <= tHDate
         USetStatusCode( 304 )
      ELSEIF hb_HHasKey( server, "HTTP_IF_UNMODIFIED_SINCE" ) .AND. ;
            HttpDateUnformat( server[ "HTTP_IF_UNMODIFIED_SINCE" ], @tHDate ) .AND. ;
            hb_FGetDateTime( UOsFileName( cFileName ), @tDate ) .AND. ;
            tDate > tHDate
         USetStatusCode( 412 )
      ELSE
         IF ( nI := RAt( ".", cFileName ) ) > 0
            SWITCH Lower( SubStr( cFileName, nI + 1 ) )
            CASE "css";                                 cI := "text/css";  EXIT
            CASE "htm";   CASE "html";                  cI := "text/html";  EXIT
            CASE "txt";   CASE "text";  CASE "asc"
            CASE "c";     CASE "h";     CASE "cpp"
            CASE "hpp";   CASE "log";                   cI := "text/plain";  EXIT
            CASE "rtf";                                 cI := "text/rtf";  EXIT
            CASE "xml";                                 cI := "text/xml";  EXIT
            CASE "bmp";                                 cI := "image/bmp";  EXIT
            CASE "gif";                                 cI := "image/gif";  EXIT
            CASE "jpg";   CASE "jpe";   CASE "jpeg";    cI := "image/jpeg";  EXIT
            CASE "png";                                 cI := "image/png";   EXIT
            CASE "tif";   CASE "tiff";                  cI := "image/tiff";  EXIT
            CASE "djv";   CASE "djvu";                  cI := "image/vnd.djvu";  EXIT
            CASE "ico";                                 cI := "image/x-icon";  EXIT
            CASE "xls";                                 cI := "application/excel";  EXIT
            CASE "doc";                                 cI := "application/msword";  EXIT
            CASE "pdf";                                 cI := "application/pdf";  EXIT
            CASE "ps";    CASE "eps";                   cI := "application/postscript";  EXIT
            CASE "ppt";                                 cI := "application/powerpoint";  EXIT
            CASE "bz2";                                 cI := "application/x-bzip2";  EXIT
            CASE "gz";                                  cI := "application/x-gzip";  EXIT
            CASE "tgz";                                 cI := "application/x-gtar";  EXIT
            CASE "js";                                  cI := "application/x-javascript";  EXIT
            CASE "tar";                                 cI := "application/x-tar";  EXIT
            CASE "tex";                                 cI := "application/x-tex";  EXIT
            CASE "zip";                                 cI := "application/zip";  EXIT
            CASE "midi";                                cI := "audio/midi";  EXIT
            CASE "mp3";                                 cI := "audio/mpeg";  EXIT
            CASE "wav";                                 cI := "audio/x-wav";  EXIT
            CASE "qt";    CASE "mov";                   cI := "video/quicktime";  EXIT
            CASE "avi";                                 cI := "video/x-msvideo";  EXIT
            OTHERWISE
               cI := "application/octet-stream"
            ENDSWITCH
         ELSE
            cI := "application/octet-stream"
         ENDIF
         UAddHeader( "Content-Type", cI )

         IF hb_FGetDateTime( UOsFileName( cFileName ), @tDate )
            UAddHeader( "Last-Modified", HttpDateFormat( tDate ) )
         ENDIF

         UWrite( hb_MemoRead( UOsFileName( cFileName ) ) )
      ENDIF
   ELSEIF hb_DirExists( UOsFileName( cFileName ) )
      IF !( Right( cFileName, 1 ) == "/" )
         URedirect( "http://" + server[ "HTTP_HOST" ] + server[ "SCRIPT_NAME" ] + "/" )
         RETURN
      ENDIF
      IF AScan( { "index.html", "index.htm" }, ;
            {| x | iif( hb_FileExists( UOsFileName( cFileName + X ) ), ( cFileName += X, .T. ), .F. ) } ) > 0
         UAddHeader( "Content-Type", "text/html" )
         UWrite( hb_MemoRead( UOsFileName( cFileName ) ) )
         RETURN
      ENDIF
      IF ! lIndex
         USetStatusCode( 403 )
         RETURN
      ENDIF

      UAddHeader( "Content-Type", "text/html" )

      aDir := Directory( UOsFileName( cFileName ), "D" )
      IF hb_HHasKey( get, "s" )
         IF get[ "s" ] == "s"
            ASort( aDir,,, {| X, Y | iif( X[ 5 ] == "D", iif( Y[ 5 ] == "D", X[ 1 ] < Y[ 1 ], .T. ), ;
               iif( Y[ 5 ] == "D", .F., X[ 2 ] < Y[ 2 ] ) ) } )
         ELSEIF get[ "s" ] == "m"
            ASort( aDir,,, {| X, Y | iif( X[ 5 ] == "D", iif( Y[ 5 ] == "D", X[ 1 ] < Y[ 1 ], .T. ), ;
               iif( Y[ 5 ] == "D", .F., DToS( X[ 3 ] ) + X[ 4 ] < DToS( Y[ 3 ] ) + Y[ 4 ] ) ) } )
         ELSE
            ASort( aDir,,, {| X, Y | iif( X[ 5 ] == "D", iif( Y[ 5 ] == "D", X[ 1 ] < Y[ 1 ], .T. ), ;
               iif( Y[ 5 ] == "D", .F., X[ 1 ] < Y[ 1 ] ) ) } )
         ENDIF
      ELSE
         ASort( aDir,,, {| X, Y | iif( X[ 5 ] == "D", iif( Y[ 5 ] == "D", X[ 1 ] < Y[ 1 ], .T. ), ;
            iif( Y[ 5 ] == "D", .F., X[ 1 ] < Y[ 1 ] ) ) } )
      ENDIF

      UWrite( '<html><body><h1>Index of ' + server[ "SCRIPT_NAME" ] + '</h1><pre>' )
      UWrite( '<a href="?s=n">Name</a>' )
      UWrite( '<a href="?s=m">Modified</a>' )
      UWrite( '<a href="?s=s">Size</a>' + CR_LF + '<hr>' )
      FOR EACH aF IN aDir
         IF Left( aF[ 1 ], 1 ) == "."
         ELSEIF "D" $ aF[ 5 ]
            UWrite( '[DIR] <a href="' + aF[ 1 ] + '/">' + aF[ 1 ] + '</a>' + Space( 50 - Len( aF[ 1 ] ) ) + ;
               DToC( aF[ 3 ] ) + ' ' + aF[ 4 ] + CR_LF )
         ELSE
            UWrite( '      <a href="' + aF[ 1 ] + '">' + aF[ 1 ] + '</a>' + Space( 50 - Len( aF[ 1 ] ) ) + ;
               DToC( aF[ 3 ] ) + ' ' + aF[ 4 ] + Str( aF[ 2 ], 12 ) + CR_LF )
         ENDIF
      NEXT
      UWrite( "<hr></pre></body></html>" )
   ELSE
      USetStatusCode( 404 )
   ENDIF

   RETURN

PROCEDURE UProcInfo()

   LOCAL cI

   UWrite( '<h1>Info</h1>' )

   UWrite( '<h2>Platform</h2>' )
   UWrite( '<table border=1 cellspacing=0>' )
   UWrite( '<tr><td>OS</td><td>' + UHtmlEncode( OS() ) + '</td></tr>' )
   UWrite( '<tr><td>Harbour</td><td>' + UHtmlEncode( Version() ) + '</td></tr>' )
   UWrite( '<tr><td>Build date</td><td>' + UHtmlEncode( hb_BuildDate() ) + '</td></tr>' )
   UWrite( '<tr><td>Compiler</td><td>' + UHtmlEncode( hb_Compiler() ) + '</td></tr>' )
   UWrite( '</table>' )

   UWrite( '<h2>Capabilities</h2>' )
   UWrite( '<table border=1 cellspacing=0>' )
   cI := ""
   AEval( rddList(), {| X | cI += iif( Empty( cI ), "", ", " ) + X } )
   UWrite( '<tr><td>RDD</td><td>' + UHtmlEncode( cI ) + '</td></tr>' )
   UWrite( '</table>' )

   UWrite( '<h2>Variables</h2>' )

   UWrite( '<h3>server</h3>' )
   UWrite( '<table border=1 cellspacing=0>' )
   AEval( ASort( hb_HKeys( server ) ), {| X | UWrite( '<tr><td>' + X + '</td><td>' + UHtmlEncode( hb_CStr( server[ X ] ) ) + '</td></tr>' ) } )
   UWrite( '</table>' )

   IF ! Empty( get )
      UWrite( '<h3>get</h3>' )
      UWrite( '<table border=1 cellspacing=0>' )
      AEval( ASort( hb_HKeys( get ) ), {| X | UWrite( '<tr><td>' + X + '</td><td>' + UHtmlEncode( hb_CStr( get[ X ] ) ) + '</td></tr>' ) } )
      UWrite( '</table>' )
   ENDIF

   IF ! Empty( post )
      UWrite( '<h3>post</h3>' )
      UWrite( '<table border=1 cellspacing=0>' )
      AEval( ASort( hb_HKeys( post ) ), {| X | UWrite( '<tr><td>' + X + '</td><td>' + UHtmlEncode( hb_CStr( post[ X ] ) ) + '</td></tr>' ) } )
      UWrite( '</table>' )
   ENDIF

   RETURN

FUNCTION UParse( aData, cFileName, hConfig )

   RETURN parse_data( aData, compile_file( cFileName, hConfig ), hConfig )

STATIC FUNCTION parse_data( aData, aCode, hConfig )

   LOCAL aInstr, aData2, cRet, xValue, aValue, cExtend := ""

   DO WHILE cExtend != NIL
      cExtend := NIL
      cRet := ""
      FOR EACH aInstr IN aCode
         SWITCH aInstr[ 1 ]
         CASE "txt"
            cRet += aInstr[ 2 ]
            EXIT

         CASE "="
            IF hb_HHasKey( aData, aInstr[ 2 ] )
               xValue := aData[ aInstr[ 2 ] ]
               IF HB_ISSTRING( xValue )
                  cRet += UHtmlEncode( xValue )
               ELSEIF HB_ISNUMERIC( xValue )
                  cRet += UHtmlEncode( Str( xValue ) )
               ELSEIF HB_ISDATE( xValue )
                  cRet += UHtmlEncode( DToC( xValue ) )
               ELSEIF HB_ISTIMESTAMP( xValue )
                  cRet += UHtmlEncode( hb_TToC( xValue ) )
               ELSEIF HB_ISOBJECT( xValue )
                  cRet += UHtmlEncode( xValue:Output() )
               ELSE
                  Eval( hConfig[ "Trace" ], hb_StrFormat( "Template error: invalid type '%s'", ValType( xValue ) ) )
               ENDIF
            ELSE
               Eval( hConfig[ "Trace" ], hb_StrFormat( "Template error: variable '%s' not found", aInstr[ 2 ] ) )
            ENDIF
            EXIT

         CASE ":"
            IF hb_HHasKey( aData, aInstr[ 2 ] )
               xValue := aData[ aInstr[ 2 ] ]
               IF HB_ISSTRING( xValue )
                  cRet += xValue
               ELSEIF HB_ISNUMERIC( xValue )
                  cRet += Str( xValue )
               ELSEIF HB_ISDATE( xValue )
                  cRet += DToC( xValue )
               ELSEIF HB_ISTIMESTAMP( xValue )
                  cRet += hb_TToC( xValue )
               ELSEIF HB_ISOBJECT( xValue )
                  cRet += xValue:Output()
               ELSE
                  Eval( hConfig[ "Trace" ], hb_StrFormat( "Template error: invalid type '%s'", ValType( xValue ) ) )
               ENDIF
            ELSE
               Eval( hConfig[ "Trace" ], hb_StrFormat( "Template error: variable '%s' not found", aInstr[ 2 ] ) )
            ENDIF
            EXIT

         CASE "if"
            xValue := iif( hb_HHasKey( aData, aInstr[ 2 ] ), aData[ aInstr[ 2 ] ], NIL )
            IF ! Empty( xValue )
               cRet += parse_data( aData, aInstr[ 3 ], hConfig )
            ELSE
               cRet += parse_data( aData, aInstr[ 4 ], hConfig )
            ENDIF
            EXIT

         CASE "loop"
            IF hb_HHasKey( aData, aInstr[ 2 ] ) .AND. HB_ISARRAY( aValue := aData[ aInstr[ 2 ] ] )
               FOR EACH xValue IN aValue
                  aData2 := hb_HClone( aData )
                  hb_HEval( xValue, {| k, v | aData2[ aInstr[ 2 ] + "." + k ] := v } )
                  aData2[ aInstr[ 2 ] + ".__index" ] := xValue:__enumIndex
                  cRet += parse_data( aData2, aInstr[ 3 ], hConfig )
                  aData2 := NIL
               NEXT
            ELSE
               Eval( hConfig[ "Trace" ], hb_StrFormat( "Template error: loop variable '%s' not found", aInstr[ 2 ] ) )
            ENDIF
            EXIT

         CASE "extend"
            cExtend := aInstr[ 2 ]
            EXIT

         CASE "include"
            cRet += parse_data( aData, compile_file( aInstr[ 2 ], hConfig ), hConfig )
            EXIT
         ENDSWITCH
      NEXT
      IF cExtend != NIL
         aData[ "" ] := cRet
         cRet := ""
         aCode := compile_file( cExtend, hConfig )
      ENDIF
   ENDDO

   RETURN cRet

STATIC FUNCTION compile_file( cFileName, hConfig )

   LOCAL nPos, cTpl, aCode := {}

   IF cFileName == NIL
      cFileName := MEMVAR->server[ "SCRIPT_NAME" ]
   ENDIF
   cFileName := UOsFileName( hb_DirBase() + "tpl/" + cFileName + ".html" )
   IF hb_FileExists( cFileName )
      cTpl := hb_MemoRead( cFileName )
      BEGIN SEQUENCE
         IF ( nPos := compile_buffer( cTpl, 1, aCode ) ) < Len( cTpl ) + 1
            Break( nPos )
         ENDIF
      RECOVER USING nPos
         Eval( hConfig[ "Trace" ], hb_StrFormat( "Template error: syntax at %s(%d,%d)", cFileName, SUBSTRCOUNT( Chr( 10 ), cTpl,, nPos ) + 1, nPos - hb_RAt( Chr( 10 ), cTpl,, nPos - 1 ) ) )
         aCode := {}
      END SEQUENCE
   ELSE
      Eval( hConfig[ "Trace" ], hb_StrFormat( "Template error: file '%s' not found", cFileName ) )
   ENDIF

   RETURN aCode

STATIC FUNCTION compile_buffer( cTpl, nStart, aCode )

   LOCAL nI, nS, nE, cTag, cParam

   DO WHILE ( nS := hb_At( "{{", cTpl, nStart ) ) > 0
      IF nS > nStart
         AAdd( aCode, { "txt", SubStr( cTpl, nStart, nS - nStart ) } )
      ENDIF
      nE := hb_At( "}}", cTpl, nS )
      IF nE > 0
         IF ( nI := hb_At( " ", cTpl, nS, nE ) ) == 0
            nI := nE
         ENDIF
         cTag := SubStr( cTpl, nS + 2, nI - nS - 2 )
         cParam := SubStr( cTpl, nI + 1, nE - nI - 1 )

         SWITCH cTag
         CASE "="
         CASE ":"
            AAdd( aCode, { cTag, cParam } )
            nStart := nE + 2
            EXIT

         CASE "if"
            AAdd( aCode, { "if", cParam, {}, {} } )
            nI := compile_buffer( cTpl, nE + 2, ATail( aCode )[ 3 ] )
            IF SubStr( cTpl, nI, 8 ) == "{{else}}"
               nI := compile_buffer( cTpl, nI + 8, ATail( aCode )[ 4 ] )
            ENDIF
            IF SubStr( cTpl, nI, 9 ) == "{{endif}}"
               nStart := nI + 9
            ELSE
               Break( nI )
            ENDIF
            EXIT

         CASE "loop"
            AAdd( aCode, { "loop", cParam, {} } )
            nI := compile_buffer( cTpl, nE + 2, ATail( aCode )[ 3 ] )
            IF SubStr( cTpl, nI, 11 ) == "{{endloop}}"
               nStart := nI + 11
            ELSE
               Break( nI )
            ENDIF
            EXIT

         CASE "extend"
            AAdd( aCode, { "extend", cParam } )
            nStart := nE + 2
            EXIT

         CASE "include"
            AAdd( aCode, { "include", cParam } )
            nStart := nE + 2
            EXIT

         OTHERWISE
            RETURN nS

         ENDSWITCH
      ELSE
         Break( nS )
      ENDIF
   ENDDO
   IF nStart < Len( cTpl )
      AAdd( aCode, { "txt", SubStr( cTpl, nStart ) } )
   ENDIF

   RETURN Len( cTpl ) + 1

STATIC FUNCTION SubStrCount( cSub, cString, nStart, nEnd )

   LOCAL nCount := 0

   IF nStart == NIL
      nStart := 1
   ENDIF
   DO WHILE ( nStart := hb_At( cSub, cString, nStart, nEnd ) ) > 0
      nCount++
      nStart++
   ENDDO

   RETURN nCount