PixyWebServer

Another tiny web server

Option Explicit
'Force the program in console mode
ForceCscript False

'Versions
' 0.1 : 29 Jul 2001
'	Send HTML pages with HTTP protocol
'	Admin console and commands : quit, header, winsock, system
'	Real-Time log with Pages requests and IP
'	Self update system
' 0.2 : 06 Aug 2001
'	Optionnally beep when somebody connects
'	Optionnally log to a database
'	Autogenerate the database if it does not exist
'	Trace "CodeRed" Attacks

'uses the component c:\winnt\system32\Mswinsck.ocx version 6.00.8804

' Constantes de protocoles
Const sckTCPProtocol = 0
Const sckUDPProtocol = 1
' Constantes d'�tat
Const sckClosed=0 
const sckOpen=1
Const sckListening=2
Const sckConnectionPending=3
Const sckResolvingHost=4
Const sckHostResolved=5
Const sckConnecting=6
Const sckConnected=7
Const sckClosing=8
Const sckError=9
' Constantes d'erreurs
Const sckInvalidPropertyValue = 380
Const sckGetNotSupported = 394
Const sckSetNotSupported = 383
Const sckOutOfMemory = 7
Const sckBadState = 40006
Const sckInvalidArg = 40014
Const sckSuccess = 40017
Const sckUnsupported = 40018
Const sckInvalidOp = 40020
Const sckOutOfRange = 40021
Const sckWrongProtocol = 40026
Const sckOpCanceled = 10004
Const sckInvalidArgument = 10014
Const sckWouldBlock = 10035
Const sckInProgress = 10036
Const sckAlreadyComplete = 10037
Const sckNotSocket = 10038
Const sckMsgTooBig = 10040
Const sckPortNotSupported = 10043
Const sckAddressInUse = 10048
Const sckAddressNotAvailable = 10049
Const sckNetworkSubsystemFailed = 10050
Const sckNetworkUnreachable = 10051
Const sckNetReset = 10052
Const sckConnectAborted = 10053
Const sckConnectionReset = 10054
Const sckNoBufferSpace = 10055
Const sckAlreadyConnected = 10056
Const sckNotConnected = 10057
Const sckSocketShutdown = 10058
Const sckTimedout = 10060
Const sckConnectionRefused = 10061
Const sckNotInitialized = 10093
Const sckHostNotFound = 11001
Const sckHostNotFoundTryAgain = 11002
Const sckNonRecoverableError = 11003
Const sckNoData = 11004

'Constants for Type Librairy Microsoft ActiveX Data Objects Recordset 2.5 Library

'Cursor Types
Const adOpenUnspecified = &Hffffffff
Const adOpenForwardOnly = 0
Const adOpenKeyset = 1
Const adOpenDynamic = 2
Const adOpenStatic = 3

'Lock Type
Const adLockUnspecified = &Hffffffff
Const adLockReadOnly = 1
Const adLockPessimistic = 2
Const adLockOptimistic = 3
Const adLockBatchOptimistic = 4

'Data Types
Const adEmpty = 0
Const adTinyInt = 16
Const adSmallInt = 2
Const adInteger = 3
Const adBigInt = 20
Const adUnsignedTinyInt = 17
Const adUnsignedSmallInt = 18
Const adUnsignedInt = 19
Const adUnsignedBigInt = 21
Const adSingle = 4
Const adDouble = 5
Const adCurrency = 6
Const adDecimal = 14
Const adNumeric = 131
Const adBoolean = 11
Const adError = 10
Const adUserDefined = 132
Const adVariant = 12
Const adIDispatch = 9
Const adIUnknown = 13
Const adGUID = 72
Const adDate = 7
Const adDBDate = 133
Const adDBTime = 134
Const adDBTimeStamp = 135
Const adBSTR = 8
Const adChar = 129
Const adVarChar = 200
Const adLongVarChar = 201
Const adWChar = 130
Const adVarWChar = 202
Const adLongVarWChar = 203
Const adBinary = 128
Const adVarBinary = 204
Const adLongVarBinary = 205
Const adChapter = 136
Const adFileTime = 64
Const adPropVariant = 138
Const adVarNumeric = 139
Const adArray = 8192

'Object State
Const adStateClosed = 0
Const adStateOpen = 1
Const adStateConnecting = 2
Const adStateExecuting = 4
Const adStateFetching = 8

'Column properties
Const adColFixed = 1
Const adColNullable = 2	



'Activate the Beep for each connexion
Const bBeep=True
Const bInteractif=False 'To enable the prompt but show popups
'Activate the Database Trace
Dim LogBaseName
LogBaseName="PixyWebServer.MDB"
Const LogBase=True


'Web Virtual Root Directory
Const RootDir="D:\JL\serialscripter\WEB"
Dim ServerVersion
ServerVersion=GetFileDateTime(Wscript.ScriptFullName)
Dim LastHeader
LastHeader="No conection yet"

LogBaseName=Left(WScript.ScriptFullName,InstrRev(WScript.ScriptFullName,"\")) & LogBaseName

Dim oSck
Set oSck=InitWinsock()
'pour du Chat, instancier un sender et un receiver
'oSck.Connect "216.239.33.100","80"
'wscript.sleep 30000
'oSck.LocalPort=1234
'oSck.Connect "srv1","8088"
' connecter client : remotehost, remoteport, localport, connect

'UDP :
'With oSck
'	.Protocol = sckUDPProtocol	' Set the control to UDP protocol.
'	.RemoteHost= "PeerB"		' Set RemoteHost property to the name of the other computer.
'	.RemotePort = 1001		' Port to connect to.
'	.Bind 1002			' Bind to the local port.
'Pour le PC de destination il faudrait inverser les ports de remoteport et bind
'End With

If Wscript.Arguments.Count > 0 Then
	oSck.Bind 10,WScript.Arguments(0)
	oSck.Close
End If

MyLog "PixyWebServer (c) JL, running on " & oSck.LocalHostName & " (" & oSck.LocalIP & ")"

oSck.LocalPort=80
oSck.Listen
MyLog "Listening on port " & oSck.LocalPort
ParseInput
oSck.Close
Set oSck=Nothing
MyLog "Program ended normally"

Sub MyLog(Chaine)
	WScript.Echo Now & " " & Chaine
End Sub

Sub sck_ConnectionRequest(Byval requestID)
'RequestID as long
' Check if the value of the control's State property
' is closed. If not, close the connection before
' accepting the new connection.
'#### If oSck.State <> sckClosed Then oSck.Close
' Accept the request with the requestID parameter.
'Sinon faire un oSck(i).Accept requestID

	oSck.Close
	MyLog oSck.RemoteHostIP & " - Connection request n�" & requestID
	'Accept ne fonctione pas si l'�tat est diff�rent de closed
	oSck.Accept requestID

	'Beep when somebody connects
	If bBeep Then
		'Dim WshShell
		'Set WshShell = CreateObject("WScript.Shell")
		'WshShell.Run "%comspec% /c echo " & Chr(7), 0, False
		wscript.stdout.write chr(7)
		'Set WshShell = Nothing
	End If

	If LogBase Then LogBaseReq oSck.RemoteHostIP
End Sub

Sub sck_Connect
	MyLog "Connected"
	oSck.SendData "GET / HTTP/1.1" & vbCrLf & "Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/vnd.ms-excel, application/msword, application/vnd.ms-powerpoint, */*" & vbCrLf & "Accept-Language: fr" & vbCrLf & "Accept-Encoding: gzip, deflate" & vbCrLf & "User-Agent: Mozilla/4.0 (compatible; MSIE 5.5; Windows 98; Win 9x 4.90; Test)" & vbCrLF & "Host: 216.239.33.100" & vbCrLf & "Connection: Keep-Alive" & vbCrLf & vbCrLf
End Sub

Sub sck_Close
	MyLog "closed - re-listening"
	oSck.Listen
End Sub

Sub sck_SendComplete
	oSck.close
	oSck.Listen
End Sub

Sub sck_DataArrival(Byval bytesTotal)
'bytesTotal as long
	Dim Chaine
	Chaine = Space(bytesTotal)
	oSck.GetData Chaine,,bytesTotal
	'oSck.GetData val, vbArray + vbByte, lBytesTotal

	If LogBase Then LogDataArrival oSck.RemoteHostIP,Chaine

	LastHeader=Chaine

	'Parse l'en-t�te HTTP
	Dim FirstWord,headers
	FirstWord=GetFirstWord(Chaine)

	Select Case Ucase(FirstWord)
	Case "GET"
		EnvoiHTML GetFirstWord(Chaine),GetFirstWord(Chaine),Chaine
	Case Else
		mylog "chaine : " & chaine
	End Select

End Sub

Sub EnvoiHTML(URI,Proto,Reste)
	Dim Chaine,FicLocal,fso,Param,x,k,strTemp

	'Can contain special coded chars (%20 for space...)
	URI=unescape(URI)

	'On d�compose l'URL et ses param�tres
	Param=""
	x=Instr(URI,"?")
	If x>0 Then
		Param=Mid(URI,x+1)
		URI=Left(URI,x-1)
	End If

	'on emp�che l'acc�s aux r�pertoires parents du r�pertoire virtuel
	'style de nom de fichier Unix->NT
	Uri=Replace(Uri,"/","\")
	x=Instr(URI,"\..")
	While x>0
		k=InstrRev(Left(Uri,x-1),"\")
		if k>0 Then
			Uri=Left(Uri,k-1) & Mid(Uri,x+3)
		Else
			Uri=Mid(Uri,x+3)
		End If
		x=Instr(URI,"\..")
	Wend

	Set fso=CreateObject("Scripting.FileSystemObject")
	'Le fichier html par d�faut pour les r�pertoires est index.html
	If Right(Uri,1)<>"\" Then
		If fso.FolderExists(fso.BuildPath(RootDir,URI)) Then Uri=Uri & "\"
	End If
	If Right(Uri,1)="\" Then Uri=Uri & "index.html"
	'Convertit l'URL en fichier local
	FicLocal=fso.BuildPath(RootDir,URI)
	If fso.FileExists(FicLocal) Then
		Chaine="HTTP/1.0 200 OK" & vbCrLf
'### Mettre l'heure serveur ou fichier ?
		Chaine =Chaine & "Date: " & FormatHeaderDate(Now) & vbCrLf
		Chaine=Chaine & "Server: PixyWebServer/0.01" & vbCrLf
		'Set-Cookie: PREF=ID=364fd411612ec989:TM=996415222:LM=996415222; domain=.google.com; path=/; expires=Sun, 17-Jan-2038 19:14:07 GMT
		'Ask both sides to shutdown the connexion after processing request
		Chaine=Chaine & "Connection: close" & vbCrLf
		'Chaine=Chaine & "Last-Modified: Tue, 21 Nov 2000 16:20:07 GMT"
		Select Case UCase(right(Ficlocal,4))
		Case ".JPG"
			Chaine=Chaine & "Content-Type: image/jpeg" & vbCrLf
		Case ".GIF"
			Chaine=Chaine & "Content-Type: image/gif" & vbCrLf
		Case Else
			Chaine=Chaine & "Content-Type: text/html" & vbCrLf
		End Select
		'Chaine=Chaine & "Accept-Ranges: bytes" & vbCrLf
		Chaine =Chaine & "Last-Modified: " & FormatHeaderDate(Now) & vbCrLf
		'Chaine=Chaine & "Content-Transfer-Encoding:binary" & vbCrLf 'binary ou 8bit

		'Read The file in binary format
		Dim f
		x=fso.GetFile(ficlocal).size
		Set f=fso.OpenTextFile(ficLocal,1)
		strTemp=f.Read(x)
		f.close
		Set f=Nothing
		Chaine = Chaine & "Content-Length: " & x & vbCrLf & vbCrLf & strTemp & vbCrLf & vbCrLf
		MyLog "Page " & ficlocal & " (" & Proto & ") sent"
	Else
		Select Case ucase(URI)
		case "\DEFAULT.IDA"
			Chaine="HTTP/1.0 200 OK" & vbCrLf
			Chaine =Chaine & "Date: " & FormatHeaderDate(Now) & vbCrLf
			Chaine=Chaine & "Server: PixyWebServer/0.01" & vbCrLf
			Chaine=Chaine & "Connection: close" & vbCrLf
			Chaine=Chaine & "Content-Type: text/html" & vbCrLf & vbCrLf
			Chaine=Chaine & "<HTML><HEAD></HEAD><BODY><H1>Hey, you little ""CodeRed"" hacker !</H1><H3>You've been logged and a trace has been send to the FBI.</H3>Thanks ;=)</BODY></HTML>"
			Chaine = Chaine & vbCrLf & vbCrLf
			MyLog oSck.RemoteHostIP & " - CodeRed"
		Case Else
			Chaine="HTTP/1.0 404 Not Found" & vbCrLf
			'"Date: Sun, 29 Jul 2001 14:00:22 GMT"
			Chaine =Chaine & "Date: " & FormatHeaderDate(Now) & vbCrLf 
			Chaine=Chaine & "Server: PixyWebServer/0.01" & vbCrLf
			'Set-Cookie: PREF=ID=364fd411612ec989:TM=996415222:LM=996415222; domain=.google.com; path=/; expires=Sun, 17-Jan-2038 19:14:07 GMT
			Chaine=Chaine & "Connection: close" & vbCrLf
			Chaine=Chaine & "Content-Type: text/html" & vbCrLf
			'Content-Length: 1662
			'Cache-Control: private

			Chaine=Chaine & vbCrLF & "<HTML><HEAD><TITLE>PixyWebServer</TITLE></HEAD><BODY>Copyright JL<br>Heure server : " & Now
			Chaine=Chaine & "<br>Page demand�e <font color=red><b>introuvable</b></font> : " & URI & " (" & Proto & ")"
			Chaine=Chaine & "<br>IP Client : " & oSck.RemoteHostIP & " - " & oSck.RemoteHost & "</BODY></HTML>"
			Chaine=Chaine & "<p>Header client :<br>" & Replace(reste,chr(13),"<br>")
			Chaine = Chaine & vbCrLf & vbCrLf
			MyLog "Page " & URI & " (" & Proto & ") not found"
		End Select
	End If
	Set fso=Nothing

	oSck.SendData Chaine
End Sub

Function FormatHeaderDate(MyDateTime)
	FormatHeaderDate = Array("","Sun","Mon","Tue","Wed","Thu","Fri","Sat")(WeekDay(MyDateTime)) & ", " & Day(MyDateTime) & " " & Array("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec")(Month(MyDateTime)-1) & " " & Year(MyDateTime) & " " & FormatDateTime(MyDateTime,3) & " GMT"
End Function

Function GetFirstWord(ByRef Chaine)
	Dim x,k
	Chaine=Trim(chaine)
	x=instr(chaine," ")
	k=instr(chaine,chr(13))
	If k<x Then x=k
	k=instr(chaine,chr(10))
	If k<x Then x=k
	If x>1 Then
		GetFirstword=Left(Chaine,x-1)
		Chaine=Mid(Chaine,x+1)
	Else
		GetFirstWord=Chaine
		Chaine=""
	End If
End Function

Function InitWinsock()
' Create Winsock Object Instance and put the license if needed
	On Error Resume Next
	Err.Number=0
	Set InitWinsock=WScript.CreateObject("MSWinsock.Winsock","sck_")
	Select Case Err.Number
	Case 0
		'No error
	case &H80040112
		MyLog "no licence for Winsock"
	case &H80020009
		MyLog "ActiveX Winsock not in the registry, check if installed or use regsvr32"
	Case else
		MyLog "Error " & Err.Number & " - &H" & Hex(Err.Number) & vbCrLf & Err.Description
	End Select
End Function


Sub sck_Error(ByVal Number, Description, ByVal Scode, ByVal Source, ByVal HelpFile, ByVal HelpContext, CancelDisplay)
'Number As Integer, Description As String, Scode As Long, Source As String, HelpFile As String, HelpContext As Long, CancelDisplay As Boolean
  CancelDisplay = True
  MyLog "Error" & Number & " - " & Description
	oSck.Close
	oSck.Listen
End Sub 

Sub ForceCscript(bForceRelance)
'Force to reload the program in non interactive mode
If (right(Ucase(WScript.FullName),11)="WSCRIPT.EXE") Or bForceRelance Then
	Dim WshShell,args,objArgs,I
	Set WshShell = CreateObject("WScript.Shell")
	args=""
	If Wscript.Arguments.Count > 0 Then
		Set objArgs = WScript.Arguments
		For I = 0 to objArgs.Count - 1
			args = args & " " & objArgs(I)
		Next
	End If
	WshShell.Run WshShell.ExpandEnvironmentStrings("%COMSPEC%") & " /C cscript.exe """ & Wscript.ScriptFullName & """" & args,1,False
	Set WshShell = Nothing
	WScript.Quit
End If
End Sub

Sub ParseInput
	Dim InputString,MyCommand, MyParam,x,MAJ
	Dim bTerminate,wshShell
	bTerminate=False
	Set WshShell = CreateObject("WScript.Shell")
	If bInteractif Then
		MyLog "Type help to get info about commands"
		Do
			Do
				wscript.sleep 9999
				'Self update. Warning, a client connection could be broken
				MAJ=GetFileDateTime(Wscript.ScriptFullName)
				If MAJ<>ServerVersion Then
					MyLog "New server version detected " & MAJ
					ForceCscript True
				End If
			Loop Until 1=WshShell.Popup("Clic on OK to switch to admin mode" & vbCrLf & "Warning, the server will be in suspend mode until you validate the command",90,"Pixy Web Server - Activated",128+64+0) ',6 in state of 0 -> invisible, no commands , &HB in state of 0 to display no button
			WScript.stdout.Write "Web server suspended - type a command>"
			InputString=Trim(Wscript.stdin.readline)
			If InputString<>"" Then
				x=instr(InputString," ")
				If x>0 Then
					MyCommand=Left(InputString,x-1)
					MyParam=Trim(Mid(InputString,x+1))
				Else
					MyCommand=InputString
				End If
				Select Case Ucase(MyCommand)
				Case "HELP"
					MyLog "Quit : exit the program"
					MyLog "Help : obtain the list of commands"
					MyLog "Header : Display the header of the last client connection"
					MyLog "WinSock : Display version information on Winsock"
					MyLog "System : Display system information : virtual root dir..."
				Case "QUIT"
					bTerminate=True
				Case "HEADER"
					MyLog "Header of the last client : " & vbCrLf & LastHeader
				Case "WINSOCK"
					oSck.AboutBox
				Case "SYSTEM"
					MyLog "Virtual Directory : " & RootDir
					MyLog "Web Server Version : " & ServerVersion
				Case Else
					MyLog "Unknown command " & MyCommand & " " & MyParam & " - Type Help to get info"
				End Select
			End If
		Loop until bTerminate
	Else
		MyLog "Type ^C to quit"
		While ServerVersion=GetFileDateTime(Wscript.ScriptFullName)
			WScript.Sleep 5000
		Wend
		MyLog "New server version detected " & MAJ
		ForceCscript True
	End If
	Set WshShell = Nothing
End Sub

Function GetFileDateTime(filename)
'Get the dateTime of the last modification of the file
	'The file must exist
	Dim fso,f
	Set fso=createobject("Scripting.FileSystemObject")
	Set f=fso.Getfile(filename)
	GetFileDateTime=f.DateLastModified
	Set f=Nothing
	Set fso=Nothing
End Function

Sub LogBaseReq(MyIP)
'Logs the IP that have accessed the server
	DIM oRs, conn

	dim fso, cat,tbl
	Set cat = WScript.CreateObject("ADOX.Catalog")
	set fso=WScript.Createobject("Scripting.FileSystemObject")
	If Not fso.FileExists(LogBaseName) Then
		'Creates the new MDB file
		cat.Create "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=""" & LogBaseName & """; Jet OLEDB:Engine Type=4;"
		'Open it
		cat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=""" & LogBaseName & """;"

		Set tbl = WScript.CreateObject("ADOX.Table")
		tbl.Name="Machines"
		tbl.Columns.Append "IP", adVarWChar, 15
		'tbl.Columns.Append "Host", adVarWChar, 50
		tbl.Columns.Append "NbConReq", adInteger
		cat.Tables.Append tbl
		Set tbl=Nothing

		Set tbl = WScript.CreateObject("ADOX.Table")
		tbl.Name="Infected"
		tbl.Columns.Append "IP", adVarWChar, 15
		tbl.Columns.Append "ConTime", adDate
		tbl.Columns.Append "Header", adLongVarWChar
		cat.Tables.Append tbl
		Set tbl=Nothing

		Set tbl = WScript.CreateObject("ADOX.Table")
		tbl.Name="Files"
		tbl.Columns.Append "IP", adVarWChar, 15
		tbl.Columns.Append "URL", adVarWChar, 50
		tbl.Columns("URL").Attributes = adColNullable
		tbl.Columns.Append "ConTime", adDate
		tbl.Columns.Append "Header", adLongVarWChar
		tbl.Columns("Header").Attributes = adColNullable
		cat.Tables.Append tbl
		Set tbl=Nothing

		'Dim col
		'Set col = Wscript.CreateObject("ADOX.Column")
		'With col
		'	.Name = "NbConReq"
		'	.Type = adInteger
		'	'.DefinedSize = 15
		'	.ParentCatalog = cat
		'	'.Properties("Jet OLEDB:Hyperlink") = True
		'End With
		'cat.Tables("Machines").Columns.Append(col)
		'Set col=Nothing

		If cat.ActiveConnection.State = adStateOpen Then
		        cat.ActiveConnection.Close
		End If
		Set cat=Nothing
		WScript.Sleep 3000
	End If
	set fso=Nothing


	' Now create a connection object
	Set conn = CreateObject("ADODB.Connection")
	conn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source = " & LogBaseName
	' Open the connection to the Database
	conn.Open
	'WScript.Echo conn.Provider
	' Create a record set for the data.
	Set oRs=CreateObject("ADODB.Recordset")

	oRs.Open "SELECT * FROM Machines where IP=""" & MyIP & """", conn, adOpenKeyset, adLockOptimistic
'while not oRs.eof
' for each fld in oRs.Fields
'  wscript.echo fld.Value
' next
' oRs.movenext
'wend
	If oRs.RecordCount=0 Then
		oRs.AddNew
		oRs.Fields("NbConReq")=1
	Else
		oRs.Fields("NbConReq")=oRs("NbConReq")+1
	End If
	oRs.Fields("IP")=MyIP
	oRs.Update
	oRs.Close
	Set oRs=Nothing
	conn.Close
	Set conn=Nothing
End Sub

Sub LogDataArrival(MyIP,Chaine)
'Logs every request
	DIM oRs, conn, strTemp,x

	' Now create a connection object
	Set conn = CreateObject("ADODB.Connection")
	conn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source = " & LogBaseName
	' Open the connection to the Database
	'Conn.Open ConnectionString,"UserID","password"
	conn.Open
	'WScript.Echo conn.Provider
	' Create a record set for the data.
	Set oRs=CreateObject("ADODB.Recordset")

	If Left(Chaine,16)="GET /default.ida" Then
		'Log CodeRed intrusion
		oRs.Open "SELECT * FROM Infected where IP=""" & MyIP & """", conn, adOpenKeyset, adLockOptimistic
		If oRs.RecordCount=0 Then
			oRs.AddNew
		End If
	Else
		'Log other requests
		oRs.Open "SELECT * FROM Files where IP=""" & MyIP & """", conn, adOpenKeyset, adLockOptimistic
		If oRs.RecordCount=0 Then
			oRs.AddNew
		End If
		strTemp=Trim(Mid(Chaine,4,60))
		x=Instr(strTemp,"HTTP")
		If x>0 Then
			oRs.Fields("Url")=Trim(Left(strTemp,x-1))
		End If
	End If

	oRs.Fields("ConTime")=Now
	oRs.Fields("IP")=MyIP
	oRs.Fields("Header")=Chaine
	oRs.Update
	oRs.Close
	Set oRs=Nothing
	conn.Close
	Set conn=Nothing
End Sub