aboutsummaryrefslogtreecommitdiff
path: root/lib/mk-ca-bundle.vbs
blob: a9b983e9bd61f9ca4e935f34f66315fd16e3ef2f (plain)
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
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
'***************************************************************************
'*                                  _   _ ____  _
'*  Project                     ___| | | |  _ \| |
'*                             / __| | | | |_) | |
'*                            | (__| |_| |  _ <| |___
'*                             \___|\___/|_| \_\_____|
'*
'* Copyright (C) 1998 - 2014, 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 https://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.4.0"

Const myUrl = "https://hg.mozilla.org/releases/mozilla-release/raw-file/default/security/nss/lib/ckfw/builtins/certdata.txt"

Const myOpenSSL = "openssl.exe"
Dim myUseOpenSSL
myUseOpenSSL = TRUE          ' Flag: TRUE to use OpenSSL. If TRUE and is not
                             ' found then a warning is shown before continuing.

Const myCdSavF = TRUE        ' 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 myWrapLe = 76          ' Default length of base64 output lines

' cert info code doesn't work properly with any recent openssl, leave disabled.
' Also: we want our certificate output by default to be as similar as possible
' to mk-ca-bundle.pl and setting this TRUE changes the base64 width to
' OpenSSL's built-in default width, which is not the same as mk-ca-bundle.pl.
Const myAskTiF = FALSE       ' Flag: ask to include certificate text info

'
'******************* Nothing to configure below! *******************
'
Const adTypeBinary = 1
Const adTypeText = 2
Const adSaveCreateNotExist = 1
Const adSaveCreateOverWrite = 2
Dim objShell, objNetwork, objFSO, objHttp
Dim myBase, mySelf, myStream, myTmpFh, myCdData, myCdFile
Dim 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)
myCaFile = "ca-bundle.crt"
myTmpName = InputBox("It will take a minute to download and parse the " & _
                     "certificate data." & _
                     vbLf & vbLf & _
                     "Please enter the output filename:", mySelf, myCaFile)
If (myTmpName = "") Then
  WScript.Quit 1
End If
myCaFile = myTmpName
If (myCdFile = "") Then
  MsgBox("URL does not contain filename!"), vbCritical, mySelf
  WScript.Quit 1
End If

' Don't use OpenSSL if it's not present.
If (myUseOpenSSL = TRUE) Then
  Dim errnum

  On Error Resume Next
  Call objShell.Run("""" & myOpenSSL & """ version", 0, TRUE)
  errnum = Err.Number
  On Error GoTo 0

  If Not (errnum = 0) Then
    myUseOpenSSL = FALSE
    MsgBox("OpenSSL was not found so the certificate bundle will not " & _
           "include the SHA256 hash of the raw certificate data file " & _
           "that was used to generate the certificates in the bundle. " & _
           vbLf & vbLf & _
           "This does not have any effect on the certificate output, " & _
           "so this script will continue." & _
           vbLf & vbLf & _
           "If you want to set a custom location for OpenSSL or disable " & _
           "this message then edit the variables at the start of the " & _
           "script."), vbInformation, mySelf
  End If
End If

If (myAskTiF = TRUE) And (myUseOpenSSL = TRUE) Then
  If (6 = objShell.PopUp("Do you want to include text information about " & _
                         "each certificate?" & vbLf & _
                         "(Requires OpenSSL.exe in the current directory " & _
                         "or search path)",, _
          mySelf, vbQuestion + vbYesNo + vbDefaultButton2)) Then
    myOptTxt = TRUE
  Else
    myOptTxt = FALSE
  End If
End If

' Uncomment the line below to 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.Status = 200) Then
  MsgBox("Failed to download '" & myCdFile & "': " & objHttp.Status & " - " & objHttp.StatusText), vbCritical, mySelf
  WScript.Quit 1
End If
' Write received data to file if enabled
If (myCdSavF = TRUE) Then
  Call SaveBinaryData(myCdFile, objHttp.ResponseBody)
End If
' Convert data from ResponseBody instead of using ResponseText because of UTF-8
myCdData = ConvertBinaryToUTF8(objHttp.ResponseBody)
Set objHttp = Nothing
' 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

' Process the received data
Dim myLines, myPattern, myInsideCert, myInsideLicense, myLicenseText, myNumCerts, myNumSkipped
Dim myLabel, myOctets, myData, myPem, myRev, myUntrusted, j
myNumSkipped = 0
myNumCerts = 0
myData = ""
myLines = Split(myCdData, vbLf, -1)
Set myStream = CreateObject("ADODB.Stream")
myStream.Open
myStream.Type = adTypeText
myStream.Charset = "utf-8"
myStream.WriteText "##" & vbLf & _
  "## Bundle of CA Root Certificates" & vbLf & _
  "##" & vbLf & _
  "## Certificate data from Mozilla as of: " & _
    ConvertDateToString(LocalDateToUTC(Now)) & " GMT" & vbLf & _
  "##" & vbLf & _
  "## This is a bundle of X.509 certificates of public Certificate Authorities" & vbLf & _
  "## (CA). These were automatically extracted from Mozilla's root certificates" & vbLf & _
  "## file (certdata.txt).  This file can be found in the mozilla source tree:" & vbLf & _
  "## " & myUrl & vbLf & _
  "##" & vbLf & _
  "## It contains the certificates in PEM format and therefore" & vbLf & _
  "## can be directly used with curl / libcurl / php_curl, or with" & vbLf & _
  "## an Apache+mod_ssl webserver for SSL client authentication." & vbLf & _
  "## Just configure this file as the SSLCACertificateFile." & vbLf & _
  "##" & vbLf & _
  "## Conversion done with mk-ca-bundle.vbs version " & myVersion & "." & vbLf
If (myCdSavF = TRUE) And (myUseOpenSSL = TRUE) Then
  myStream.WriteText "## SHA256: " & FileSHA256(myCdFile) & vbLf
End If
myStream.WriteText "##" & vbLf & vbLf

myStream.WriteText 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
      While (i < UBound(myLines)) And Not (myLines(i) = "#")
        i = i + 1
        If InstrRev(myLines(i), "CKA_TRUST_SERVER_AUTH CK_TRUST CKT_NSS_TRUSTED_DELEGATOR") Then
          myUntrusted = FALSE
        End If
      Wend
      If (myUntrusted = TRUE) Then
        myNumSkipped = myNumSkipped + 1
      Else
        myStream.WriteText myLabel & vbLf
        myStream.WriteText String(Len(myLabel), "=") & vbLf
        myPem = "-----BEGIN CERTIFICATE-----" & vbLf & _
                Base64Encode(myData) & vbLf & _
                "-----END CERTIFICATE-----" & vbLf
        If (myOptTxt = FALSE) Then
          myStream.WriteText 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)
          myStream.WriteText myTmpFh.ReadAll & vbLf
          myTmpFh.Close
          objFSO.DeleteFile myTmpOut, TRUE
        End If
        myNumCerts = myNumCerts + 1
      End If
    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))
    myStream.WriteText "# " & myRev & vbLf & vbLf
  End If
  If InstrRev(myLines(i), "CKA_VALUE MULTILINE_OCTAL") Then
    myInsideCert = TRUE
    myUntrusted = TRUE
    myData = ""
  End If
  If InstrRev(myLines(i), "***** BEGIN LICENSE BLOCK *****") Then
    myInsideLicense = TRUE
  End If
  If (myInsideLicense = TRUE) Then
    myStream.WriteText 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
        myStream.Close
        objFSO.DeleteFile myCaFile, TRUE
        WScript.Quit 2
      End If
    End If
  End If
Next

' To stop the UTF-8 BOM from being written the stream has to be copied and
' then saved as binary.
Dim myCopy
Set myCopy = CreateObject("ADODB.Stream")
myCopy.Type = adTypeBinary
myCopy.Open
myStream.Position = 3 ' Skip UTF-8 BOM
myStream.CopyTo myCopy
myCopy.SaveToFile myCaFile, adSaveCreateOverWrite
myCopy.Close
myStream.Close
Set myCopy = Nothing
Set myStream = Nothing

' Done
objShell.PopUp "Done (" & myNumCerts & " CA certs processed, " & myNumSkipped & _
               " untrusted skipped).", 20, mySelf, vbInformation
WScript.Quit 0

Function ConvertBinaryToUTF8(arrBytes)
  Dim objStream
  Set objStream = CreateObject("ADODB.Stream")
  objStream.Open
  objStream.Type = adTypeBinary
  objStream.Write arrBytes
  objStream.Position = 0
  objStream.Type = adTypeText
  objStream.Charset = "utf-8"
  ConvertBinaryToUTF8 = objStream.ReadText
  Set objStream = Nothing
End Function

Function SaveBinaryData(filename, data)
  Dim objStream
  Set objStream = CreateObject("ADODB.Stream")
  objStream.Type = adTypeBinary
  objStream.Open
  objStream.Write data
  objStream.SaveToFile filename, adSaveCreateOverWrite
  objStream.Close
  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, lWrap, I
  lWrap = Int(myWrapLe * 3 / 4)

  '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 myWrapLe chars In dest
    If (I < Len(inData) - 2) Then
      If (I + 2) Mod lWrap = 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

' Return the date in the same format as perl to match mk-ca-bundle.pl output:
' Wed Sep  7 03:12:05 2016
Function ConvertDateToString(input)
  Dim output
  output = WeekDayName(WeekDay(input), TRUE) & " " & _
           MonthName(Month(input), TRUE) & " "
  If (Len(Day(input)) = 1) Then
    output = output & " "
  End If
  output = output & _
           Day(input) & " " & _
           FormatDateTime(input, vbShortTime) & ":"
  If (Len(Second(input)) = 1) Then
    output = output & "0"
  End If
  output = output & _
           Second(input) & " " & _
           Year(input)
  ConvertDateToString = output
End Function

' Convert local Date to UTC. Microsoft says:
' Use Win32_ComputerSystem CurrentTimeZone property, because it automatically
' adjusts the Time Zone bias for daylight saving time; Win32_Time Zone Bias
' property does not.
' https://msdn.microsoft.com/en-us/library/windows/desktop/ms696015.aspx
Function LocalDateToUTC(localdate)
  Dim item, offset
  For Each item In GetObject("winmgmts:").InstancesOf("Win32_ComputerSystem")
    offset = item.CurrentTimeZone ' the offset in minutes
  Next
  If (offset < 0) Then
    LocalDateToUTC = DateAdd("n",  ABS(offset), localdate)
  Else
    LocalDateToUTC = DateAdd("n", -ABS(offset), localdate)
  End If
  'objShell.PopUp LocalDateToUTC
End Function

Function FileSHA256(filename)
  Dim cmd, rval, tmpOut, tmpFh
  if (myUseOpenSSL = TRUE) Then
    tmpOut = objFSO.GetSpecialFolder(2).Path & "\" & objFSO.GetTempName
    cmd = """" & myOpenSSL & """ dgst -r -sha256 -out """ & tmpOut & """ """ & filename & """"
    rval = objShell.Run(cmd, 0, TRUE)
    If Not (rval = 0) Then
      MsgBox("Failed to get sha256 of """ & filename & """ with OpenSSL commandline!"), vbCritical, mySelf
      objFSO.DeleteFile tmpOut, TRUE
      WScript.Quit 3
    End If
    Set tmpFh = objFSO.OpenTextFile(tmpOut, 1)
    FileSHA256 = RegExprFirst("^([0-9a-f]{64}) .+", tmpFh.ReadAll)
    tmpFh.Close
    objFSO.DeleteFile tmpOut, TRUE
  Else
    FileSHA256 = ""
  End If
End Function