#include "directry.ch"

#include "error.ch"

#include "hbclass.ch"

#include "hbsocket.ch"

#include "hbthread.ch"

#include "hbver.ch"

#include "hbssl.ch"

#include "hbssl.hbx"

#pragma -km+

#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 UHttpdConnection

EXPORTED:

VAR hSocket

VAR hSSL

VAR bTrace

VAR cRequest

METHOD Read( /* @ */ cRequest, nReqLen, nTimeout )

METHOD Write( cBuffer )

METHOD New( hSocket, hSSL, bTrace )

HIDDEN:

VAR cBuffer INIT ""

METHOD New( hSocket, hSSL, bTrace ) CLASS UHttpdConnection

::hSocket := hSocket

::hSSL := hSSL

::bTrace := bTrace

RETURN Self

METHOD Read( /* @ */ cRequest, nReqLen, nTimeout ) CLASS UHttpdConnection

LOCAL nTime := hb_MilliSeconds() + hb_defaultValue( nTimeout, 1 ) * 1000

LOCAL cBuf := Space( 4096 ), nLen := 1, nErr

hb_default( @nReqLen, -1 ) // Non-numeric or negative value will read till the first double-CRLF

DO WHILE iif( nReqLen >= 0, hb_BLen( ::cBuffer ) < nReqLen, !( CR_LF + CR_LF $ ::cBuffer ) ) .AND. ! httpd:IsStopped()

IF ::hSSL != NIL

nLen := MY_SSL_READ( ::bTrace, ::hSSL, ::hSocket, @cBuf, 1000, @nErr )

ELSEIF ( nLen := hb_socketRecv( ::hSocket, @cBuf,,, 1000 ) ) < 0

nErr := hb_socketGetError()

ENDIF

DO CASE

CASE nLen > 0

::cBuffer += hb_BLeft( cBuf, nLen )

CASE nLen == 0

/* connection closed */

nLen := -1

EXIT

OTHERWISE

/* nLen == -1 socket error */

IF nErr == HB_SOCKET_ERR_TIMEOUT

IF hb_MilliSeconds() > nTime .OR. httpd:IsStopped()

Eval( ::bTrace, "receive timeout", ::hSocket )

nLen := 0

EXIT

ENDIF

ELSE

Eval( ::bTrace, "receive error:", nErr, hb_socketErrorString( nErr ) )

nLen := -1

EXIT

ENDIF

ENDCASE

ENDDO

DO CASE

CASE nLen <= 0

cRequest := ""

CASE nReqLen > 0

cRequest := hb_BLeft( ::cBuffer, nReqLen )

::cBuffer := hb_BSubStr( ::cBuffer, nReqLen + 1 )

nLen := nReqLen

CASE nReqLen == 0

cRequest := ""

nLen := 1

OTHERWISE

nLen := hb_BAt( CR_LF + CR_LF, ::cBuffer ) + 3

cRequest := hb_BLeft( ::cBuffer, nLen )

::cBuffer := hb_BSubStr( ::cBuffer, nLen + 1 )

ENDCASE

RETURN nLen

METHOD Write( cBuffer ) CLASS UHttpdConnection

LOCAL nLen := 0, nErr

DO WHILE ! HB_ISNULL( cBuffer ) .AND. ! httpd:IsStopped()

IF ::hSSL != NIL

nLen := MY_SSL_WRITE( ::bTrace, ::hSSL, ::hSocket, cBuffer, 1000, @nErr )

ELSEIF ( nLen := hb_socketSend( ::hSocket, cBuffer,,, 1000 ) ) < 0

nErr := hb_socketGetError()

ENDIF

DO CASE

CASE nLen < 0

Eval( ::bTrace, "send error:", nErr, hb_socketErrorString( nErr ) )

EXIT

CASE nLen > 0

cBuffer := hb_BSubStr( cBuffer, nLen + 1 )

ENDCASE

ENDDO

RETURN nLen

CREATE CLASS UHttpd MODULE FRIENDLY

EXPORTED:

METHOD Run( hConfig )

METHOD Stop()

METHOD IsStopped() INLINE ::lStop

VAR cError INIT ""

VAR bNoop INIT {|| NIL } READONLY

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 )

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", ;

"SocketReuse" => .F., ;

"LogAccess" => ::bNoop, ;

"LogError" => ::bNoop, ;

"Trace" => ::bNoop, ;

"Idle" => ::bNoop, ;

"Mount" => { => }, ;

"PrivateKeyFilename" => "", ;

"CertificateFilename" => "", ;

"RequestFilter" => ::bNoop, ;

"FirewallFilter" => "0.0.0.0/0" }

FOR EACH xValue IN hConfig

IF !( xValue:__enumKey $ ::hConfig ) .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( hb_randStr( 20 ) + Str( hb_MilliSeconds(), 20 ), 1 )

ENDDO

Self:hSSLCtx := SSL_CTX_new( HB_SSL_CTX_NEW_METHOD_SSLV23_SERVER )

SSL_CTX_set_options( Self: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 ::hConfig[ "SocketReuse" ]

hb_socketSetReuseAddr( ::hListen, .T. )

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 PROCEDURE Stop() CLASS UHttpd

Eval( ::hConfig[ "Trace" ], "stopping" )

::lStop := .T.

RETURN

METHOD PROCEDURE LogError( cError ) CLASS UHttpd

hb_mutexLock( ::hmtxLog )

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

hb_mutexUnlock( ::hmtxLog )

RETURN

METHOD PROCEDURE LogAccess() CLASS UHttpd

LOCAL tDate := hb_DateTime()

hb_mutexLock( ::hmtxLog )

Eval( ::hConfig[ "LogAccess" ], ;

server[ "REMOTE_ADDR" ] + " - - [" + StrZero( Day( tDate ), 2 ) + "/" + ;

{ "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" }[ Month( tDate ) ] + ;

"/" + StrZero( Year( tDate ), 4 ) + ":" + hb_TToC( tDate, "", "hh:mm:ss" ) + " +0000] " + '"' + server[ "REQUEST_ALL" ] + '"' + " " + ;

hb_ntos( t_nStatusCode ) + " " + hb_ntos( hb_BLen( t_cResult ) ) + ;

" " + '"' + server[ "HTTP_REFERER" ] + '"' + " " + '"' + server[ "HTTP_USER_AGENT" ] + ;

'"' )

hb_mutexUnlock( ::hmtxLog )

RETURN

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 := hb_LeftEq( cExpr, "!" ) )

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( bTrace, hSSL, hSocket, cBuf, nTimeout, nError )

LOCAL nErr, nLen

nLen := SSL_read( hSSL, @cBuf )

IF nLen < 0

SWITCH nErr := SSL_get_error( hSSL, nLen )

CASE 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

CASE 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

OTHERWISE

Eval( bTrace, "SSL_read() error", nErr )

nError := 1000 + nErr

RETURN -1

ENDSWITCH

ENDIF

RETURN nLen

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

LOCAL nErr, nLen

nLen := SSL_write( hSSL, cBuf )

IF nLen <= 0

SWITCH nErr := SSL_get_error( hSSL, nLen )

CASE 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

CASE 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

OTHERWISE

Eval( bTrace, "SSL_write() error", nErr )

nError := 1000 + nErr

RETURN -1

ENDSWITCH

ENDIF

RETURN nLen

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

LOCAL nErr

nErr := SSL_accept( hSSL )

DO CASE

CASE nErr > 0

RETURN 0

CASE nErr < 0

SWITCH nErr := SSL_get_error( hSSL, nErr )

CASE HB_SSL_ERROR_WANT_READ

nErr := hb_socketSelectRead( hSocket, nTimeout )

IF nErr < 0

nErr := hb_socketGetError()

ELSE

nErr := HB_SOCKET_ERR_TIMEOUT

ENDIF

EXIT

CASE HB_SSL_ERROR_WANT_WRITE

nErr := hb_socketSelectWrite( hSocket, nTimeout )

IF nErr < 0

nErr := hb_socketGetError()

ELSE

nErr := HB_SOCKET_ERR_TIMEOUT

ENDIF

EXIT

OTHERWISE

Eval( bTrace, "SSL_accept() error", nErr )

nErr := 1000 + nErr

ENDSWITCH

OTHERWISE /* nErr == 0 */

nErr := SSL_get_error( hSSL, nErr )

Eval( bTrace, "SSL_accept() shutdown error", nErr )

nErr := 1000 + nErr

ENDCASE

RETURN nErr

STATIC FUNCTION ProcessConnection( oServer )

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

LOCAL hSSL, oConnection

LOCAL lRequestFilter := !( oServer:hConfig[ "RequestFilter" ] == oServer:bNoop )

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,

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[ "Trace" ], 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 */

oConnection := UHttpdConnection():New( hSocket, hSSL, oServer:hConfig[ "Trace" ] )

/* Set cRequest to empty string here. This enables request pipelining */

cRequest := ""

DO WHILE ! oServer:lStop

/* receive query header */

nLen := oConnection:Read( @cRequest,, 30 )

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 ) )

cBuf := NIL

nReqLen := ParseRequestHeader( @cRequest )

IF nReqLen == NIL

USetStatusCode( 400 )

UAddHeader( "Connection", "close" )

ELSE

/* receive query body */

nLen := oConnection:Read( @cRequest, nReqLen, 120 )

IF nLen <= 0 .OR. oServer:lStop

EXIT

ENDIF

Eval( oServer:hConfig[ "Trace" ], cRequest )

ParseRequestBody( hb_BLeft( cRequest, nReqLen ) )

cRequest := hb_BSubStr( cRequest, nReqLen + 1 )

/* Deal with supported protocols and methods */

IF ! hb_LeftEq( server[ "SERVER_PROTOCOL" ], "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 */

IF lRequestFilter

cBuf := Eval( oServer:hConfig[ "RequestFilter" ], oConnection, cRequest )

ENDIF

ProcessRequest( oServer )

dbCloseAll()

ENDIF

ENDIF /* request header ok */

// Send response (unless the custom processor formed one already)

IF cBuf == NIL

cBuf := MakeResponse( oServer:hConfig )

ENDIF

oConnection:Write( cBuf )

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, hMount, cMount, cPath, bEval, xRet, nT := hb_MilliSeconds()

// Search mounting table

hMount := oServer:hConfig[ "Mount" ]

cMount := server[ "SCRIPT_NAME" ]

IF cMount $ hMount

cPath := ""

ELSE

nI := Len( cMount )

DO WHILE ( nI := hb_RAt( "/", cMount,, nI ) ) > 0

IF ( Left( cMount, nI ) + "*" ) $ hMount

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 := hMount[ cMount ]

BEGIN SEQUENCE WITH {| oErr | UErrorHandler( oErr, oServer ) }

xRet := Eval( bEval, cPath )

DO CASE

CASE HB_ISSTRING( xRet )

UWrite( xRet )

CASE HB_ISHASH( xRet )

UWrite( UParse( xRet,, oServer:hConfig[ "Trace" ] ) )

ENDCASE

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. hb_LeftEq( aLine[ 3 ], "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 ! hb_LeftEq( server[ "REQUEST_URI" ], "/" )

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 "CONTENT_TYPE" $ server .AND. ;

hb_LeftEq( server[ "CONTENT_TYPE" ], "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( hb_BLen( 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 )

LOCAL nOffset := hb_UTCOffset()

RETURN ;

{ "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" }[ DoW( tDate ) ] + ", " + ;

StrZero( Day( tDate ), 2 ) + " " + ;

{ "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" }[ Month( tDate ) ] + " " + ;

StrZero( Year( tDate ), 4 ) + " " + ;

hb_TToC( tDate, "", "hh:mm:ss" ) + " " + ;

hb_StrFormat( "UTC%1$s%2$02d%3$02d", ;

iif( nOffset < 0, "-", "+" ), ;

Int( Abs( nOffset ) / 3600 ), ;

Int( Abs( nOffset ) % 3600 / 60 ) )

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 ) == ", "

IF ( nMonth := AScan( { "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" }, SubStr( cDate, 9, 3 ) ) ) > 0

tI := hb_SToT( SubStr( cDate, 13, 4 ) + StrZero( nMonth, 2 ) + SubStr( cDate, 6, 2 ) + StrTran( SubStr( cDate, 18, 8 ), ":" ) )

IF ! Empty( tI )

tDate := tI + hb_UTCOffset() / ( 3600 * 24 )

RETURN .T.

ENDIF

ENDIF

ENDIF