1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
|
'***************************************************************************
'* _ _ ____ _
'* Project ___| | | | _ \| |
'* / __| | | | |_) | |
'* | (__| |_| | _ <| |___
'* \___|\___/|_| \_\_____|
'*
'* Copyright (C) 1998 - 2010, Daniel Stenberg, <daniel@haxx.se>, et al.
'*
'* This software is licensed as described in the file COPYING, which
'* you should have received as part of this distribution. The terms
'* are also available at http://curl.haxx.se/docs/copyright.html.
'*
'* You may opt to use, copy, modify, merge, publish, distribute and/or sell
'* copies of the Software, and permit persons to whom the Software is
'* furnished to do so, under the terms of the COPYING file.
'*
'* This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY
'* KIND, either express or implied.
'*
'***************************************************************************
'* Script to fetch certdata.txt from Mozilla.org site and create a
'* ca-bundle.crt for use with OpenSSL / libcurl / libcurl bindings
'* Requires WinHttp.WinHttpRequest.5.1 and ADODB.Stream which are part of
'* W2000 SP3 or later, WXP SP1 or later, W2003 Server SP1 or later.
'* Hacked by Guenter Knauf
'***************************************************************************
Option Explicit
Const myVersion = "0.3.5"
Const myUrl = "http://mxr.mozilla.org/mozilla/source/security/nss/lib/ckfw/builtins/certdata.txt?raw=1"
Const myOpenssl = "openssl.exe"
Const myCdSavF = FALSE ' Flag: save downloaded data to file certdata.txt
Const myCaBakF = TRUE ' Flag: backup existing ca-bundle certificate
Const myAskLiF = TRUE ' Flag: display certdata.txt license agreement
Const myAskTiF = TRUE ' Flag: ask to include certificate text info
'******************* Nothing to configure below! *******************
Dim objShell, objNetwork, objFSO, objHttp
Dim myBase, mySelf, myFh, myTmpFh, myCdData, myCdFile, myCaFile, myTmpName, myBakNum, myOptTxt, i
Set objNetwork = WScript.CreateObject("WScript.Network")
Set objShell = WScript.CreateObject("WScript.Shell")
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
Set objHttp = WScript.CreateObject("WinHttp.WinHttpRequest.5.1")
If objHttp Is Nothing Then Set objHttp = WScript.CreateObject("WinHttp.WinHttpRequest")
myBase = Left(WScript.ScriptFullName, InstrRev(WScript.ScriptFullName, "\"))
mySelf = Left(WScript.ScriptName, InstrRev(WScript.ScriptName, ".") - 1) & " " & myVersion
myCdFile = Mid(myUrl, InstrRev(myUrl, "/") + 1, InstrRev(myUrl, "?") - InstrRev(myUrl, "/") - 1)
myCaFile = "ca-bundle.crt"
myTmpName = InputBox("Enter output filename:", mySelf, myCaFile)
If Not (myTmpName = "") Then
myCaFile = myTmpName
End If
' Lets ignore SSL invalid cert errors
objHttp.Option(4) = 256 + 512 + 4096 + 8192
objHttp.SetTimeouts 0, 5000, 10000, 10000
objHttp.Open "GET", myUrl, FALSE
objHttp.setRequestHeader "User-Agent", WScript.ScriptName & "/" & myVersion
objHttp.Send ""
If Not (objHttp.statusText = "OK") Then
MsgBox("Failed to download '" & myCdFile & "': " & objHttp.statusText), vbCritical, mySelf
WScript.Quit 1
End If
' Convert data from ResponseBody instead of using ResponseText because of UTF-8
myCdData = ConvertBinaryData(objHttp.ResponseBody)
Set objHttp = Nothing
' Write received data to file if enabled
If (myCdSavF = TRUE) Then
Set myFh = objFSO.OpenTextFile(myCdFile, 2, TRUE)
myFh.Write myCdData
myFh.Close
End If
' Backup exitsing ca-bundle certificate file
If (myCaBakF = TRUE) Then
If objFSO.FileExists(myCaFile) Then
Dim myBakFile, b
b = 1
myBakFile = myCaFile & ".~" & b & "~"
While objFSO.FileExists(myBakFile)
b = b + 1
myBakFile = myCaFile & ".~" & b & "~"
Wend
Set myTmpFh = objFSO.GetFile(myCaFile)
myTmpFh.Move myBakFile
End If
End If
If (myAskTiF = TRUE) Then
If (6 = objShell.PopUp("Do you want to include text information about each certificate?" & vbLf & _
"(requires OpenSSL commandline in current directory or in search path)",, _
mySelf, vbQuestion + vbYesNo + vbDefaultButton2)) Then
myOptTxt = TRUE
Else
myOptTxt = FALSE
End If
End If
' Process the received data
Dim myLines, myPattern, myInsideCert, myInsideLicense, myLicenseText, myNumCerts
Dim myLabel, myOctets, myData, myPem, myRev, j
myData = ""
myLines = Split(myCdData, vbLf, -1)
Set myFh = objFSO.OpenTextFile(myCaFile, 2, TRUE)
myFh.Write "##" & vbLf
myFh.Write "## " & myCaFile & " -- Bundle of CA Root Certificates" & vbLf
myFh.Write "##" & vbLf
myFh.Write "## Converted at: " & Now & vbLf
myFh.Write "##" & vbLf
myFh.Write "## This is a bundle of X.509 certificates of public Certificate Authorities" & vbLf
myFh.Write "## (CA). These were automatically extracted from Mozilla's root certificates" & vbLf
myFh.Write "## file (certdata.txt). This file can be found in the mozilla source tree:" & vbLf
myFh.Write "## '/mozilla/security/nss/lib/ckfw/builtins/certdata.txt'" & vbLf
myFh.Write "##" & vbLf
myFh.Write "## It contains the certificates in PEM format and therefore" & vbLf
myFh.Write "## can be directly used with curl / libcurl / php_curl, or with" & vbLf
myFh.Write "## an Apache+mod_ssl webserver for SSL client authentication." & vbLf
myFh.Write "## Just configure this file as the SSLCACertificateFile." & vbLf
myFh.Write "##" & vbLf
myFh.Write vbLf
For i = 0 To UBound(myLines)
If InstrRev(myLines(i), "CKA_LABEL ") Then
myPattern = "^CKA_LABEL\s+[A-Z0-9]+\s+""(.+?)"""
myLabel = RegExprFirst(myPattern, myLines(i))
End If
If (myInsideCert = TRUE) Then
If InstrRev(myLines(i), "END") Then
myInsideCert = FALSE
myFh.Write myLabel & vbLf
myFh.Write String(Len(myLabel), "=") & vbLf
myPem = "-----BEGIN CERTIFICATE-----" & vbLf & _
Base64Encode(myData) & vbLf & _
"-----END CERTIFICATE-----" & vbLf
If (myOptTxt = FALSE) Then
myFh.Write myPem & vbLf
Else
Dim myCmd, myRval, myTmpIn, myTmpOut
myTmpIn = objFSO.GetSpecialFolder(2).Path & "\" & objFSO.GetTempName
myTmpOut = objFSO.GetSpecialFolder(2).Path & "\" & objFSO.GetTempName
Set myTmpFh = objFSO.OpenTextFile(myTmpIn, 2, TRUE)
myTmpFh.Write myPem
myTmpFh.Close
myCmd = myOpenssl & " x509 -md5 -fingerprint -text -inform PEM" & _
" -in " & myTmpIn & " -out " & myTmpOut
myRval = objShell.Run (myCmd, 0, TRUE)
objFSO.DeleteFile myTmpIn, TRUE
If Not (myRval = 0) Then
MsgBox("Failed to process PEM cert with OpenSSL commandline!"), vbCritical, mySelf
objFSO.DeleteFile myTmpOut, TRUE
WScript.Quit 3
End If
Set myTmpFh = objFSO.OpenTextFile(myTmpOut, 1)
myFh.Write myTmpFh.ReadAll & vbLf
myTmpFh.Close
objFSO.DeleteFile myTmpOut, TRUE
End If
myData = ""
myNumCerts = myNumCerts + 1
Else
myOctets = Split(myLines(i), "\")
For j = 1 To UBound(myOctets)
myData = myData & Chr(CByte("&o" & myOctets(j)))
Next
End If
End If
If InstrRev(myLines(i), "CVS_ID ") Then
myPattern = "^CVS_ID\s+""(.+?)"""
myRev = RegExprFirst(myPattern, myLines(i))
myFh.Write "# " & myRev & vbLf & vbLf
End If
If InstrRev(myLines(i), "CKA_VALUE MULTILINE_OCTAL") Then
myInsideCert = TRUE
End If
If InstrRev(myLines(i), "***** BEGIN LICENSE BLOCK *****") Then
myInsideLicense = TRUE
End If
If (myInsideLicense = TRUE) Then
myFh.Write myLines(i) & vbLf
myLicenseText = myLicenseText & Mid(myLines(i), 2) & vbLf
End If
If InstrRev(myLines(i), "***** END LICENSE BLOCK *****") Then
myInsideLicense = FALSE
If (myAskLiF = TRUE) Then
If Not (6 = objShell.PopUp(myLicenseText & vbLf & _
"Do you agree to the license shown above (required to proceed) ?",, _
mySelf, vbQuestion + vbYesNo + vbDefaultButton1)) Then
myFh.Close
objFSO.DeleteFile myCaFile, TRUE
WScript.Quit 2
End If
End If
End If
Next
myFh.Close
objShell.PopUp "Done (" & myNumCerts & " CA certs processed).", 20, mySelf, vbInformation
WScript.Quit 0
Function ConvertBinaryData(arrBytes)
Dim objStream
Set objStream = CreateObject("ADODB.Stream")
objStream.Open
objStream.Type = 1
objStream.Write arrBytes
objStream.Position = 0
objStream.Type = 2
objStream.Charset = "ascii"
ConvertBinaryData = objStream.ReadText
Set objStream = Nothing
End Function
Function RegExprFirst(SearchPattern, TheString)
Dim objRegExp, Matches ' create variables.
Set objRegExp = New RegExp ' create a regular expression.
objRegExp.Pattern = SearchPattern ' sets the search pattern.
objRegExp.IgnoreCase = TRUE ' set to ignores case.
objRegExp.Global = TRUE ' set to gloabal search.
Set Matches = objRegExp.Execute(TheString) ' do the search.
If (Matches.Count) Then
RegExprFirst = Matches(0).SubMatches(0) ' return first match.
Else
RegExprFirst = ""
End If
Set objRegExp = Nothing
End Function
Function Base64Encode(inData)
Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Dim cOut, sOut, I
'For each group of 3 bytes
For I = 1 To Len(inData) Step 3
Dim nGroup, pOut, sGroup
'Create one long from this 3 bytes.
nGroup = &H10000 * Asc(Mid(inData, I, 1)) + _
&H100 * MyASC(Mid(inData, I + 1, 1)) + _
MyASC(Mid(inData, I + 2, 1))
'Oct splits the long To 8 groups with 3 bits
nGroup = Oct(nGroup)
'Add leading zeros
nGroup = String(8 - Len(nGroup), "0") & nGroup
'Convert To base64
pOut = Mid(Base64, CLng("&o" & Mid(nGroup, 1, 2)) + 1, 1) & _
Mid(Base64, CLng("&o" & Mid(nGroup, 3, 2)) + 1, 1) & _
Mid(Base64, CLng("&o" & Mid(nGroup, 5, 2)) + 1, 1) & _
Mid(Base64, CLng("&o" & Mid(nGroup, 7, 2)) + 1, 1)
'Add the part To OutPut string
sOut = sOut + pOut
'Add a new line For Each 76 chars In dest (76*3/4 = 57)
If (I < Len(inData) - 2) Then
If (I + 2) Mod 57 = 0 Then sOut = sOut & vbLf
End If
Next
Select Case Len(inData) Mod 3
Case 1: '8 bit final
sOut = Left(sOut, Len(sOut) - 2) & "=="
Case 2: '16 bit final
sOut = Left(sOut, Len(sOut) - 1) & "="
End Select
Base64Encode = sOut
End Function
Function MyASC(OneChar)
If OneChar = "" Then MyASC = 0 Else MyASC = Asc(OneChar)
End Function
|
