summaryrefslogtreecommitdiff
path: root/lib/mk-ca-bundle.vbs
blob: 39d2fbc6be5f05f358d6bc604bb49915fd16cb70 (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
'***************************************************************************
'*                                  _   _ ____  _
'*  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