[Project64] Add new upload_beta script

This commit is contained in:
zilmar 2017-06-30 17:15:52 +10:00
parent 91d2c4f04f
commit a61557a317
1 changed files with 123 additions and 423 deletions

View File

@ -1,286 +1,63 @@
' On Error Resume Next
if WScript.Arguments.Count < 4 then
WScript.StdOut.WriteLine "Missing parameters"
WScript.StdOut.WriteLine "[password] [file to upload] [BuildUrl] [Posttitle]"
WScript.Quit 1
end if
Set IE = CreateIeWindow()
WScript.StdOut.WriteLine IE.HWND
IE.Visible = True
Login IE
PostThread IE
IE.Quit
WScript.Quit 0
function CreateIeWindow ()
on error resume next
Set CreateIeWindow = nothing
For count = 0 to 100
WScript.StdOut.WriteLine count & ": Trying to create Internet Explorer"
Set IE = WScript.CreateObject("InternetExplorer.Application", "IE_")
if not IE is nothing then
WScript.StdOut.WriteLine count & ": Created Internet Explorer"
WScript.StdOut.WriteLine IE.HWND
IE.Visible = True
WScript.StdOut.WriteLine IE.HWND
Set CreateIeWindow = IE
exit for
end if
WScript.StdOut.WriteLine count & ": Not created"
WScript.Sleep 100
WScript.StdOut.WriteLine count & ": Should loop"
Next
if CreateIeWindow is nothing then
WScript.StdOut.WriteLine "Failed to create InternetExplorer.Application"
WScript.Quit 1
end if
End Function
Sub Wait(IE)
Dim complete
complete = False
WScript.StdOut.WriteLine "Waiting for IE"
For count = 0 to 1000
WScript.StdOut.WriteLine "before sleep"
WScript.Sleep 100
WScript.StdOut.WriteLine "after sleep"
if IE is nothing then
WScript.StdOut.WriteLine "after sleep"
end if
WScript.StdOut.WriteLine count & ": IE.readyState: " & IE.readyState
if IE.readyState >= 4 then
WScript.StdOut.WriteLine count & ": IE.Busy: " & IE.Busy
if not IE.Busy then
WScript.StdOut.WriteLine count & ": IE.document.readyState: " & IE.document.readyState
if StrComp(IE.document.readyState, "complete", vbTextCompare) = 0 then
complete = true
exit for
end if
end if
end if
Next
if not complete then
WScript.StdOut.WriteLine "Failed to wait for IE"
WScript.Quit 1
end if
WScript.StdOut.WriteLine "IE Done"
End Sub
Function FindIeWindow(ieID)
on error resume next
set IE = nothing
For count = 0 to 100
Set Shell = CreateObject("Shell.Application")
For i = 0 to Shell.Windows.Count -1
set Win = Shell.Windows.Item(i)
WScript.StdOut.WriteLine i & ": " & TypeName(win.Document)
If TypeName(win.Document) = "HTMLDocument" Then
WScript.StdOut.WriteLine "uniqueID: @" & win.HWND & "@" & ieID & "@"
if win.HWND = ieID then
WScript.StdOut.WriteLine "matched"
set IE = win
end if
End If
if not IE is nothing then
exit for
end if
Next
if not IE is nothing then
exit for
end if
WScript.StdOut.WriteLine count & ": failed, trying again"
WScript.Sleep 100
Next
set FindIeWindow = IE
if IE is nothing then
WScript.StdOut.WriteLine "Failed to find navigating window"
if WScript.Arguments.Count < 3 then
ShowUsage()
ElseIf StrComp("--create",WScript.Arguments(0)) = 0 Then
if WScript.Arguments.Count < 4 then
ShowUsage()
else
WScript.StdOut.WriteLine "HWND : " & IE.HWND
CreateUploadTarget()
end if
ElseIf StrComp("--files",WScript.Arguments(0)) = 0 Then
if WScript.Arguments.Count < 4 then
ShowUsage()
else
UploadFiles()
end if
Else
ShowUsage()
End if
sub ShowUsage()
WScript.StdOut.WriteLine "incorrect parameters"
WScript.StdOut.WriteLine "--create [password] [BuildUrl] [BuildName]"
WScript.StdOut.WriteLine "--files [password] [dir to upload] [BuildName]"
WScript.Quit 1
end sub
function Project64Url()
Project64Url = "http://www.local.pj64-emu.com"
End Function
Sub Navigate(IE, url)
dim ieId
ieID = IE.HWND
WScript.StdOut.WriteLine "Navigating (" & IE.HWND & ") to: " & url
IE.Navigate url
WScript.Sleep 100
' set IE = FindIeWindow(ieID)
Wait IE
End Sub
sub CreateUploadTarget()
dim BuildUrl
BuildUrl = WScript.Arguments(2)
Sub ValidateLoggedIn(IE)
WScript.StdOut.WriteLine "ValidateLoggedIn - 1"
WScript.StdOut.WriteLine "ValidateLoggedIn start"
WScript.StdOut.WriteLine "ValidateLoggedIn - 2"
Navigate IE, "http://forum.pj64-emu.com/"
WScript.StdOut.WriteLine "ValidateLoggedIn - 3"
Wait IE
WScript.StdOut.WriteLine "ValidateLoggedIn - 4"
Dim LoggedIn
LoggedIn = False
WScript.StdOut.WriteLine "ValidateLoggedIn - 5"
Set NodeList = IE.document.getElementsByTagName("a")
WScript.StdOut.WriteLine "ValidateLoggedIn - 6"
WScript.StdOut.WriteLine "Got Node list"
For Each Elem In NodeList
WScript.StdOut.WriteLine Elem.href
if lcase(Mid(Elem.href,1,39)) = "http://forum.pj64-emu.com/member.php?u=" then
if lcase(Mid(Elem.parentElement.innerHTML,1,11)) = "welcome, <a" then
if lcase(Elem.innerHTML) = "buildbot" then
WScript.StdOut.WriteLine "Found welcome message"
LoggedIn = true
exit for
end if
end if
end if
Next
if LoggedIn = false then
WScript.StdOut.WriteLine "Failed to login"
Dim objHTTP
Set objHTTP = CreateObject("MSXML2.XMLHTTP")
objHTTP.open "GET", BuildUrl & "buildTimestamp", False
objHTTP.send
if (objHTTP.status <> 200) then
WScript.StdOut.WriteLine "failed to get job timestamp (" & BuildUrl & "buildTimestamp)"
WScript.Quit 1
end if
WScript.StdOut.WriteLine "ValidateLoggedIn Done"
End Sub
dim d
Sub Login(IE)
On Error resume next
SetLocale 1033
build_date=CDate(objHTTP.responseText)
Set IE2 = WScript.CreateObject("InternetExplorer.Application", "IE_")
IE2.Visible = True
WScript.StdOut.WriteLine "Login start"
Navigate IE2, "http://forum.pj64-emu.com/"
Set objHTTP = CreateObject("MSXML2.XMLHTTP")
objHTTP.open "GET", BuildUrl & "api/xml?wrapper=changes", False
objHTTP.send
set navbar_username = IE2.document.getelementbyid("navbar_username")
set navbar_password = IE2.document.getelementbyid("navbar_password")
if navbar_username is nothing then
WScript.StdOut.WriteLine "Failed to find login form, checking if already logged in"
ValidateLoggedIn IE
exit sub
end if
WScript.StdOut.WriteLine "Found login form"
navbar_username.value = "buildbot"
navbar_password.value = WScript.Arguments(0)
navbar_username.form.submit
Wait IE2
Dim FoundIt
FoundIt = False
WScript.StdOut.WriteLine "Looking for redirect"
For count = 0 to 100
Set NodeList = IE2.document.getElementsByTagName("a")
WScript.StdOut.WriteLine count & ": Found " & NodeList.length & " a tags"
For Each Elem In NodeList
if StrComp(Elem.href, "http://forum.pj64-emu.com/", vbTextCompare) = 0 then
if StrComp(Elem.innerHTML, "Click here if your browser does not automatically redirect you.", vbTextCompare) = 0 then
FoundIt = True
Exit For
End if
end if
if StrComp(Mid(Elem.href,1,57), "http://forum.pj64-emu.com/login.php?do=logout&logouthash=", vbTextCompare) = 0 then
if StrComp(Elem.innerHTML, "Log Out buildbot", vbTextCompare) = 0 then
WScript.StdOut.WriteLine "missed redirect link, found logout link"
FoundIt = True
Exit For
End if
end if
Next
if FoundIt = True then
Exit For
end if
WScript.Sleep 100
Next
if FoundIt = false then
WScript.StdOut.WriteLine "Failed to find redirect"
WScript.Quit 1
end if
WScript.StdOut.WriteLine "found redirect"
Navigate IE, "http://forum.pj64-emu.com/"
Wait IE
WScript.StdOut.WriteLine "Quitting IE2"
IE2.Quit
ValidateLoggedIn IE
WScript.StdOut.WriteLine "Login Done"
End Sub
Sub PostThread(IE)
dim ieId
ieID = IE.HWND
WScript.StdOut.WriteLine "PostThread start"
Navigate IE, "http://forum.pj64-emu.com/newthread.php?do=newthread&f=10"
Wait IE
set IE = FindIeWindow(ieID)
Dim submitButton
For count = 0 to 100
WScript.StdOut.WriteLine count & ": looking for submit button"
set submitButton = nothing
Set NodeList = IE.document.getElementsByTagName("input")
For Each Elem In NodeList
WScript.StdOut.WriteLine count & ": " & lcase(Elem.className)
if lcase(Elem.className) = "button" and lcase(Elem.value) = "submit new thread" then
WScript.StdOut.WriteLine count & ": found submit button"
set submitButton = Elem
exit for
end if
Next
if not submitButton is nothing then
exit for
end if
WScript.Sleep 300
Next
if submitButton is nothing then
WScript.StdOut.WriteLine "failed to find submit button"
WScript.Quit 1
end if
SetPostDetails IE, WScript.Arguments(2), WScript.Arguments(3)
UploadDirectory ieID, WScript.Arguments(1)
WScript.StdOut.WriteLine "submitting"
submitButton.click
WScript.Sleep 100
set IE = FindIeWindow(ieID)
Wait IE
WScript.StdOut.WriteLine "PostThread Finished"
End Sub
Sub SetPostDetails(IE, BuildUrl, PostTitle)
WScript.StdOut.WriteLine "Posting Details"
Dim oReq
Set oReq = CreateObject("MSXML2.XMLHTTP")
oReq.open "GET", BuildUrl & "api/xml?wrapper=changes", False
oReq.send
if (oReq.status <> 200) then
if (objHTTP.status <> 200) then
WScript.StdOut.WriteLine "failed to get job details (" & BuildUrl & "api/xml?wrapper=changes)"
WScript.Quit 1
end if
Dim xmlDoc
Set xmlDoc = oReq.responseXML
Set xmlDoc = objHTTP.responseXML
Set objLst = xmlDoc.getElementsByTagName("freeStyleBuild")
Dim PostContent
Dim ProductDescription
For each elem in objLst
set childNodes = elem.childNodes
for each node in childNodes
@ -301,70 +78,61 @@ Sub SetPostDetails(IE, BuildUrl, PostTitle)
next
if (Len(comment) > 0 and Len(commitId) > 0) then
PostContent = PostContent & "[*]" & comment & " (commit: [URL=""https://github.com/project64/project64/commit/" & commitId & """]"& commitId & "[/URL])" & vbCr
ProductDescription = ProductDescription & "[*]" & comment & " (commit: [URL=""https://github.com/project64/project64/commit/" & commitId & """]"& commitId & "[/URL])" & vbCrLf
end if
next
end if
next
Next
if (Len(PostContent) > 0) then
PostContent = "Changes:"&vbCr&"[LIST=1]" & vbCr & PostContent & "[/LIST]"
if (Len(ProductDescription) > 0) then
ProductDescription = "Changes:"&vbCrLf&"[LIST]" & vbCrLf & ProductDescription & "[/LIST]"
else
PostContent = "No code changes"
ProductDescription = "No code changes"
end if
WScript.StdOut.WriteLine "PostTitle = """ & PostTitle & """"
WScript.StdOut.WriteLine "PostContent = """ & PostContent & """"
Dim url
url = Project64Url() + "/index.php"
Dim SetTitle
SetTitle = False
Set NodeList = IE.document.getElementsByTagName("input")
For Each Elem In NodeList
if lcase(Elem.name) = "subject" then
Elem.value = PostTitle
SetTitle = true
exit for
end if
Next
dim data
data = "option=com_betafile"
data = data & "&task=CreateProduct"
data = data & "&password="&WScript.Arguments(1)
data = data & "&jform[product_name]="&WScript.Arguments(3)
data = data & "&jform[product_desc]="&ProductDescription
data = data & "&jform[product_date]="&Year(build_date) & "-" & Month(build_date) & "-" & Day(build_date)
if not SetTitle then
WScript.StdOut.WriteLine "failed to set post title"
WScript.Quit 1
end if
Dim SetMessage
SetMessage = False
Set NodeList = IE.document.getElementsByTagName("textarea")
For Each Elem In NodeList
WScript.StdOut.WriteLine Elem.name
if lcase(Elem.name) = "message" then
Elem.value = PostContent
SetMessage = true
exit for
end if
Next
if not SetMessage then
WScript.StdOut.WriteLine "failed to set post message"
Set objHTTP = CreateObject("Microsoft.XMLHTTP")
objHTTP.open "POST", url, False
objHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
objHTTP.send data
if objHTTP.Status <> 200 then
WScript.StdOut.WriteLine "Create beta file failed"
WScript.StdOut.WriteLine "status: " & objHTTP.Status
WScript.StdOut.WriteLine objHTTP.responseText
WScript.Quit 1
end if
WScript.StdOut.WriteLine objHTTP.responseText
Set objHTTP = Nothing
end sub
sub UploadDirectory(ieID, DirToUpload)
sub UploadFiles()
DirToUpload = WScript.Arguments(2)
WScript.StdOut.WriteLine "UploadDirectory start - " & DirToUpload
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(DirToUpload)
Set colFiles = objFolder.Files
For Each objFile in colFiles
UploadFile ieID, DirToUpload & "\" & objFile.Name
UploadFile DirToUpload & "\" & objFile.Name
Next
WScript.StdOut.WriteLine "UploadDirectory Finished"
end sub
sub UploadFile(ieID, FileToUpload)
set IE = FindIeWindow(ieID)
sub UploadFile(FileToUpload)
Const adTypeBinary = 1
WScript.StdOut.WriteLine "UploadFile start - " & FileToUpload
dim filePos
@ -389,70 +157,21 @@ sub UploadFile(ieID, FileToUpload)
WScript.Quit 1
end if
set manage_attachments_button = IE.document.getelementbyid("manage_attachments_button")
if manage_attachments_button is nothing then
WScript.StdOut.WriteLine "failed to find manage_attachments_button"
WScript.Quit 1
end if
WScript.StdOut.WriteLine "InStr(1, lcase(manage_attachments_button.onclick), ""vb_attachments"") = " & InStr(1, lcase(manage_attachments_button.onclick), "vb_attachments")
dim startPos, endPos
startPos = InStr(1, lcase(manage_attachments_button.onclick), "vb_attachments")
if startPos = 0 then
WScript.StdOut.WriteLine "failed to find vb_attachments in " & manage_attachments_button.onclick
WScript.Quit 1
end if
startPos = InStr(startPos, lcase(manage_attachments_button.onclick), "'")
if startPos = 0 then
WScript.StdOut.WriteLine "failed to find first quote in " & manage_attachments_button.onclick
WScript.Quit 1
end if
startPos = startPos + 1
endPos = InStr(startPos,manage_attachments_button.onclick, "'")
if endPos = 0 then
WScript.StdOut.WriteLine "failed to find second quote in " & manage_attachments_button.onclick
WScript.Quit 1
end if
Set IE2 = WScript.CreateObject("InternetExplorer.Application", "IE_")
IE2.Visible = True
Navigate IE2, "http://forum.pj64-emu.com/" & Mid(manage_attachments_button.onclick, startPos, endPos - startPos)
Wait IE2
Set FormList = IE2.document.getElementsByTagName("form")
if FormList.length <> 1 or FormList(0).name <> "newattachment" then
WScript.StdOut.WriteLine "failed to find attachement form"
WScript.Quit 1
end if
Set InputList = FormList(0).getElementsByTagName("input")
WScript.StdOut.WriteLine "InputList.length = " & InputList.length
dim PreFormData, PostFormData
For Each Input In InputList
if lcase(Input.type) = "hidden" then
PreFormData = PreFormData & "--AaB03x" & vbCrLf & "Content-Disposition: form-data; name=""" & Input.name & """" & vbCrLf & vbCrLf & Input.value& vbCrLf
end if
WScript.StdOut.WriteLine "Input.type: " & Input.type & " Input.name: " & Input.name & " Input.value: " & Input.value
next
PreFormData = PreFormData & "--AaB03x" & vbCrLf & "Content-Disposition: form-data; name=""attachment[]""; filename=""" & fileName & """" & vbCrLf
PreFormData = PreFormData & "Content-Type: application/zip" & vbCrLf & vbCrLf
PostFormData = vbCrLf & "--AaB03x" & vbCrLf & "Content-Disposition: form-data; name=""upload""" & vbCrLf & vbCrLf & "Upload" & vbCrLf
PostFormData = PostFormData & vbCrLf & vbCrLf & "--AaB03x--"& vbCrLf
WScript.StdOut.WriteLine PreFormData & PostFormData
Dim url
url = Project64Url() + "/index.php"
dim fileContents
fileContents = ReadBinaryFile(FileToUpload)
dim UploadUrl
UploadUrl = "http://forum.pj64-emu.com/" & FormList(0).action
IE2.Quit
Header = "Content-Type: multipart/form-data; boundary=AaB03x" & vbCrLf
Const adTypeBinary = 1
dim PreFormData, PostFormData
PreFormData = PreFormData & "--AaB03x" & vbCrLf & "Content-Disposition: form-data; name=""option""" & vbCrLf & vbCrLf & "com_betafile"& vbCrLf
PreFormData = PreFormData & "--AaB03x" & vbCrLf & "Content-Disposition: form-data; name=""task""" & vbCrLf & vbCrLf & "AddFile"& vbCrLf
PreFormData = PreFormData & "--AaB03x" & vbCrLf & "Content-Disposition: form-data; name=""password""" & vbCrLf & vbCrLf & WScript.Arguments(1) & vbCrLf
PreFormData = PreFormData & "--AaB03x" & vbCrLf & "Content-Disposition: form-data; name=""jform[product_name]""" & vbCrLf & vbCrLf & WScript.Arguments(3) & vbCrLf
PreFormData = PreFormData & "--AaB03x" & vbCrLf & "Content-Disposition: form-data; name=""jform[add_file]""; filename=""" & fileName & """" & vbCrLf
PreFormData = PreFormData & "Content-Type: application/zip" & vbCrLf & vbCrLf
PostFormData = vbCrLf & "--AaB03x" & vbCrLf & "Content-Disposition: form-data; name=""upload""" & vbCrLf & vbCrLf & "Upload" & vbCrLf
PostFormData = PostFormData & vbCrLf & vbCrLf & "--AaB03x--"& vbCrLf
Dim DataToPOSTStream
Set DataToPOSTStream = CreateObject("ADODB.Stream")
@ -465,48 +184,47 @@ sub UploadFile(ieID, FileToUpload)
DataToPOSTStream.Write = Stream_StringToBinary(PostFormData,"us-ascii")
DataToPOSTStream.Position = 0
DataToPOSTStream.Type = adTypeBinary
Dim DataToPOST
DataToPOST = DataToPOSTStream.Read
Set IE3 = CreateIeWindow()
IE3.Visible = 1
dim ie3Id
ie3Id = IE3.HWND
WScript.StdOut.WriteLine "Uploading form to: " & UploadUrl
IE3.Navigate UploadUrl, Nothing, Nothing, DataToPOST, Header
WScript.Sleep 100
'set IE3 = FindIeWindow(ie3Id)
Wait IE3
Set objHTTP = CreateObject("Microsoft.XMLHTTP")
objHTTP.open "POST", url, False
Dim UploadDone
UploadDone = False
For count = 0 to 1000
WScript.StdOut.WriteLine count & ": Waiting for upload done"
Set NodeList = IE3.document.getElementsByTagName("legend")
For Each Elem In NodeList
if (len(Elem.innerHTML) > 19) and lcase(Mid(Elem.innerHTML, 1, 19)) = "current attachments" then
UploadDone = true
WScript.StdOut.WriteLine "Upload done"
exit for
end if
Next
if UploadDone then
exit for
end if
Next
objHTTP.setRequestHeader "Content-Type", "multipart/form-data; boundary=AaB03x"
objHTTP.setRequestHeader "Content-Length", Len(fileContents)
objHTTP.send DataToPOST
if not UploadDone then
if objHTTP.Status <> 200 then
WScript.StdOut.WriteLine "Failed to upload file"
WScript.StdOut.WriteLine "status: " & objHTTP.Status
WScript.StdOut.WriteLine objHTTP.responseText
WScript.Quit 1
end if
IE3.Quit
WScript.StdOut.WriteLine "UploadFile Finished"
end sub
Function Stream_StringToBinary(Text, CharSet)
Const adTypeText = 2
Function ReadBinaryFile(path)
Const adTypeBinary = 1
Const adTypeText = 2
dim inStream
dim myByte,myByteValue,myCharacter
set inStream=WScript.CreateObject("ADODB.Stream")
inStream.Open
inStream.type=1
inStream.LoadFromFile path
ReadBinaryFile=inStream.Read()
inStream.Close
End Function
Function Stream_StringToBinary(Text, CharSet)
Const adTypeBinary = 1
Const adTypeText = 2
Dim BinaryStream
Set BinaryStream = CreateObject("ADODB.Stream")
@ -523,21 +241,3 @@ Function Stream_StringToBinary(Text, CharSet)
Set BinaryStream = Nothing
End Function
Function ReadBinaryFile(path)
Const adTypeText = 2
Const adTypeBinary = 1
dim inStream
dim myByte,myByteValue,myCharacter
set inStream=WScript.CreateObject("ADODB.Stream")
inStream.Open
inStream.type=1
inStream.LoadFromFile path
ReadBinaryFile=inStream.Read()
inStream.Close
End Function