[Source - Download] Simples Servidor WEB HTTP

[Dark_Side]

Hi,
acabou de sair do forno  ::)

Code Select Expand

'Simples Servidor HTTP by Dark Side
Option Explicit
Dim x As Long
Dim i As Long
Private Const chunk As Long = 2048
Dim arq As Long
Dim go As Boolean
Dim content As String
Dim data As String
Dim bagaco As String
Dim parte_boa As String
Private Sub Form_Load()
sock(0).LocalPort = 80
sock(0).Listen
dir1.Path = "c:\web"
Timer1.Interval = 2000
End Sub

Private Sub sock_ConnectionRequest(Index As Integer, ByVal requestID As Long)
'Pedido de conexão -> carrega socket, aceita conexão e adiciona à lista de acessos.
x = sock.UBound
Load sock(x + 1)
sock(x + 1).Accept requestID
List1.AddItem "Acesso: " & sock(x + 1).RemoteHostIP & " em " & Now
List1.ListIndex = List1.ListCount - 1
End Sub

Private Sub sock_DataArrival(Index As Integer, ByVal bytesTotal As Long)
'Recebimento -> obtém dados, obtém arquivo em questão
go = False
sock(Index).GetData data, vbString
bagaco = Mid(data, InStr(1, data, "GET ") + 4)
parte_boa = Mid(bagaco, 1, InStr(1, bagaco, "HTTP") - 2)
If parte_boa = "/" Then parte_boa = "/index.html"
procurar Index 'Verifica se o arquivo existe em "C:\WEB"

End Sub
Function procurar(ByVal n As Long)
For i = 0 To dir1.ListCount - 1
If Mid(parte_boa, 2) = dir1.List(i) Then  'Caso exista
Call conteudo 'Verifica tipo de arquivo
enviar n 'Função de envio
Exit Function 'Não executa restante do código, quando o arquivo for encontrado.
End If
Next
'Caso não exista o arquivo, em C:\WEB:
sock(n).SendData "HTTP/1.1 404 Not Found" & vbCrLf & vbCrLf
go = True 'Ajusta variável, para que quando a resposta 404 for enviada, o socket seja fechada e descarregado.
End Function
Function conteudo()
'Verifica extensão e associa ao conteúdo.
Select Case Mid(parte_boa, InStr(1, parte_boa, ".") + 1)
Case "jpg"
content = "image/jpeg"
Case "jpeg"
content = "image/jpeg"
Case "gif"
content = "image/gif"
Case "mpg"
content = "video/mpeg"
Case "mpeg"
content = "video/mpeg"
Case "htm"
content = "text/html"
Case "html"
content = "text/html"
Case "txt"
content = "text/plain"
Case "zip"
content = "application/zip"
Case "exe"
content = "application/exe"
End Select
End Function
Function enviar(ByVal n As Long)
arq = FreeFile 'Pega um número livre para ser usado no ponteiro do arquivo.
Open "c:\web\" & Mid(parte_boa, 2) For Binary As arq 'Abre o arquivo requisitado.
sock(n).SendData "HTTP/1.1 200 OK" & vbCrLf & "Content-Type:" & content & vbCrLf & vbCrLf 'Envia header inicial
While Loc(arq) < LOF(arq) 'Enquanto todo o arquivo não for enviado
DoEvents 'Permite que o programa execute outras tarefas, fora do LOOP.
If sock(n).State <> 7 Then GoTo fim 'Verifica se a conexão foi perdida, caso sim, vai para 'FIM'.
data = Input(chunk, #arq) 'Armazena em buffer(chunk = 2048), o conteúdo binário do arquivo, por vez.
sock(n).SendData data 'Envia buffer
DoEvents
Wend
'No final da operação -> fecha e descarrega socket.
sock(n).Close
Unload sock(n)
Close #arq 'Fecha arquivo.
Exit Function 'Sai da função, ignorando o código abaixo
fim: 'Erro na conexão...
MsgBox "Ocorreu um erro na conexão!", vbCritical, "Erro"
sock(n).Close
Unload sock(n)
End Function
Private Sub sock_SendComplete(Index As Integer)
If go = True Then 'Caso a variável que define se o socket deve ser fechado estiver com valor verdadeiro:
sock(Index).Close
Unload sock(Index)
'Fecha e descarrega socket.
End If
End Sub

Private Sub List1_Click()

End Sub

Private Sub Timer1_Timer()
dir1.Refresh 'Atualiza constatemente(intervalo 2000 = 2 segundos) a lista de arquivos em "C:\WEB"
End Sub
Versão compilada  + source (formato VB):
http://geocities.yahoo.com.br/wdfbily/webserver.zip
Bye.

[rog]

vc estas bem produtivo

parabems

rog

[Drew]

Olá Dark_Side ! :-\ apelei pra esse code seu, mas não emtendi muito, se fosse possivel você me ajudar a fazer um "Servidor Web" no delphi eu agradeceria tutorial, artigo, code... alguma coisa q me ajudasse, oq eu quero é fazer e entender, não quero code prontinho ::)