lib/mk-ca-bundle.vbs

   1 '***************************************************************************\r
   2 '*                                  _   _ ____  _\r
   3 '*  Project                     ___| | | |  _ \| |\r
   4 '*                             / __| | | | |_) | |\r
   5 '*                            | (__| |_| |  _ <| |___\r
   6 '*                             \___|\___/|_| \_\_____|\r
   7 '*\r
   8 '* Copyright (C) 1998 - 2014, Daniel Stenberg, <daniel@haxx.se>, et al.\r
   9 '*\r
  10 '* This software is licensed as described in the file COPYING, which\r
  11 '* you should have received as part of this distribution. The terms\r
  12 '* are also available at https://curl.haxx.se/docs/copyright.html.\r
  13 '*\r
  14 '* You may opt to use, copy, modify, merge, publish, distribute and/or sell\r
  15 '* copies of the Software, and permit persons to whom the Software is\r
  16 '* furnished to do so, under the terms of the COPYING file.\r
  17 '*\r
  18 '* This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY\r
  19 '* KIND, either express or implied.\r
  20 '*\r
  21 '***************************************************************************\r
  22 '* Script to fetch certdata.txt from Mozilla.org site and create a\r
  23 '* ca-bundle.crt for use with OpenSSL / libcurl / libcurl bindings\r
  24 '* Requires WinHttp.WinHttpRequest.5.1 and ADODB.Stream which are part of\r
  25 '* W2000 SP3 or later, WXP SP1 or later, W2003 Server SP1 or later.\r
  26 '* Hacked by Guenter Knauf\r
  27 '***************************************************************************\r
  28 Option Explicit\r
  29 Const myVersion = "0.4.0"\r
  30 \r
  31 Const myUrl = "https://hg.mozilla.org/releases/mozilla-release/raw-file/default/security/nss/lib/ckfw/builtins/certdata.txt"\r
  32 \r
  33 Const myOpenSSL = "openssl.exe"\r
  34 Dim myUseOpenSSL\r
  35 myUseOpenSSL = TRUE          ' Flag: TRUE to use OpenSSL. If TRUE and is not\r
  36                              ' found then a warning is shown before continuing.\r
  37 \r
  38 Const myCdSavF = TRUE        ' Flag: save downloaded data to file certdata.txt\r
  39 Const myCaBakF = TRUE        ' Flag: backup existing ca-bundle certificate\r
  40 Const myAskLiF = TRUE        ' Flag: display certdata.txt license agreement\r
  41 Const myWrapLe = 76          ' Default length of base64 output lines\r
  42 \r
  43 ' cert info code doesn't work properly with any recent openssl, leave disabled.\r
  44 ' Also: we want our certificate output by default to be as similar as possible\r
  45 ' to mk-ca-bundle.pl and setting this TRUE changes the base64 width to\r
  46 ' OpenSSL's built-in default width, which is not the same as mk-ca-bundle.pl.\r
  47 Const myAskTiF = FALSE       ' Flag: ask to include certificate text info\r
  48 \r
  49 '\r
  50 '******************* Nothing to configure below! *******************\r
  51 '\r
  52 Const adTypeBinary = 1\r
  53 Const adTypeText = 2\r
  54 Const adSaveCreateNotExist = 1\r
  55 Const adSaveCreateOverWrite = 2\r
  56 Dim objShell, objNetwork, objFSO, objHttp\r
  57 Dim myBase, mySelf, myStream, myTmpFh, myCdData, myCdFile\r
  58 Dim myCaFile, myTmpName, myBakNum, myOptTxt, i\r
  59 Set objNetwork = WScript.CreateObject("WScript.Network")\r
  60 Set objShell = WScript.CreateObject("WScript.Shell")\r
  61 Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")\r
  62 Set objHttp = WScript.CreateObject("WinHttp.WinHttpRequest.5.1")\r
  63 If objHttp Is Nothing Then Set objHttp = WScript.CreateObject("WinHttp.WinHttpRequest")\r
  64 myBase = Left(WScript.ScriptFullName, InstrRev(WScript.ScriptFullName, "\"))\r
  65 mySelf = Left(WScript.ScriptName, InstrRev(WScript.ScriptName, ".") - 1) & " " & myVersion\r
  66 \r
  67 myCdFile = Mid(myUrl, InstrRev(myUrl, "/") + 1)\r
  68 myCaFile = "ca-bundle.crt"\r
  69 myTmpName = InputBox("It will take a minute to download and parse the " & _\r
  70                      "certificate data." & _\r
  71                      vbLf & vbLf & _\r
  72                      "Please enter the output filename:", mySelf, myCaFile)\r
  73 If (myTmpName = "") Then\r
  74   WScript.Quit 1\r
  75 End If\r
  76 myCaFile = myTmpName\r
  77 If (myCdFile = "") Then\r
  78   MsgBox("URL does not contain filename!"), vbCritical, mySelf\r
  79   WScript.Quit 1\r
  80 End If\r
  81 \r
  82 ' Don't use OpenSSL if it's not present.\r
  83 If (myUseOpenSSL = TRUE) Then\r
  84   Dim errnum\r
  85 \r
  86   On Error Resume Next\r
  87   Call objShell.Run("""" & myOpenSSL & """ version", 0, TRUE)\r
  88   errnum = Err.Number\r
  89   On Error GoTo 0\r
  90 \r
  91   If Not (errnum = 0) Then\r
  92     myUseOpenSSL = FALSE\r
  93     MsgBox("OpenSSL was not found so the certificate bundle will not " & _\r
  94            "include the SHA256 hash of the raw certificate data file " & _\r
  95            "that was used to generate the certificates in the bundle. " & _\r
  96            vbLf & vbLf & _\r
  97            "This does not have any effect on the certificate output, " & _\r
  98            "so this script will continue." & _\r
  99            vbLf & vbLf & _\r
 100            "If you want to set a custom location for OpenSSL or disable " & _\r
 101            "this message then edit the variables at the start of the " & _\r
 102            "script."), vbInformation, mySelf\r
 103   End If\r
 104 End If\r
 105 \r
 106 If (myAskTiF = TRUE) And (myUseOpenSSL = TRUE) Then\r
 107   If (6 = objShell.PopUp("Do you want to include text information about " & _\r
 108                          "each certificate?" & vbLf & _\r
 109                          "(Requires OpenSSL.exe in the current directory " & _\r
 110                          "or search path)",, _\r
 111           mySelf, vbQuestion + vbYesNo + vbDefaultButton2)) Then\r
 112     myOptTxt = TRUE\r
 113   Else\r
 114     myOptTxt = FALSE\r
 115   End If\r
 116 End If\r
 117 \r
 118 ' Uncomment the line below to ignore SSL invalid cert errors\r
 119 ' objHttp.Option(4) = 256 + 512 + 4096 + 8192\r
 120 objHttp.SetTimeouts 0, 5000, 10000, 10000\r
 121 objHttp.Open "GET", myUrl, FALSE\r
 122 objHttp.setRequestHeader "User-Agent", WScript.ScriptName & "/" & myVersion\r
 123 objHttp.Send ""\r
 124 If Not (objHttp.Status = 200) Then\r
 125   MsgBox("Failed to download '" & myCdFile & "': " & objHttp.Status & " - " & objHttp.StatusText), vbCritical, mySelf\r
 126   WScript.Quit 1\r
 127 End If\r
 128 ' Write received data to file if enabled\r
 129 If (myCdSavF = TRUE) Then\r
 130   Call SaveBinaryData(myCdFile, objHttp.ResponseBody)\r
 131 End If\r
 132 ' Convert data from ResponseBody instead of using ResponseText because of UTF-8\r
 133 myCdData = ConvertBinaryToUTF8(objHttp.ResponseBody)\r
 134 Set objHttp = Nothing\r
 135 ' Backup exitsing ca-bundle certificate file\r
 136 If (myCaBakF = TRUE) Then\r
 137   If objFSO.FileExists(myCaFile) Then\r
 138     Dim myBakFile, b\r
 139     b = 1\r
 140     myBakFile = myCaFile & ".~" & b & "~"\r
 141     While objFSO.FileExists(myBakFile)\r
 142       b = b + 1\r
 143       myBakFile = myCaFile & ".~" & b & "~"\r
 144     Wend\r
 145     Set myTmpFh = objFSO.GetFile(myCaFile)\r
 146     myTmpFh.Move myBakFile\r
 147   End If\r
 148 End If\r
 149 \r
 150 ' Process the received data\r
 151 Dim myLines, myPattern, myInsideCert, myInsideLicense, myLicenseText, myNumCerts, myNumSkipped\r
 152 Dim myLabel, myOctets, myData, myPem, myRev, myUntrusted, j\r
 153 myNumSkipped = 0\r
 154 myNumCerts = 0\r
 155 myData = ""\r
 156 myLines = Split(myCdData, vbLf, -1)\r
 157 Set myStream = CreateObject("ADODB.Stream")\r
 158 myStream.Open\r
 159 myStream.Type = adTypeText\r
 160 myStream.Charset = "utf-8"\r
 161 myStream.WriteText "##" & vbLf & _\r
 162   "## Bundle of CA Root Certificates" & vbLf & _\r
 163   "##" & vbLf & _\r
 164   "## Certificate data from Mozilla as of: " & _\r
 165     ConvertDateToString(LocalDateToUTC(Now)) & " GMT" & vbLf & _\r
 166   "##" & vbLf & _\r
 167   "## This is a bundle of X.509 certificates of public Certificate Authorities" & vbLf & _\r
 168   "## (CA). These were automatically extracted from Mozilla's root certificates" & vbLf & _\r
 169   "## file (certdata.txt).  This file can be found in the mozilla source tree:" & vbLf & _\r
 170   "## " & myUrl & vbLf & _\r
 171   "##" & vbLf & _\r
 172   "## It contains the certificates in PEM format and therefore" & vbLf & _\r
 173   "## can be directly used with curl / libcurl / php_curl, or with" & vbLf & _\r
 174   "## an Apache+mod_ssl webserver for SSL client authentication." & vbLf & _\r
 175   "## Just configure this file as the SSLCACertificateFile." & vbLf & _\r
 176   "##" & vbLf & _\r
 177   "## Conversion done with mk-ca-bundle.vbs version " & myVersion & "." & vbLf\r
 178 If (myCdSavF = TRUE) And (myUseOpenSSL = TRUE) Then\r
 179   myStream.WriteText "## SHA256: " & FileSHA256(myCdFile) & vbLf\r
 180 End If\r
 181 myStream.WriteText "##" & vbLf & vbLf\r
 182 \r
 183 myStream.WriteText vbLf\r
 184 For i = 0 To UBound(myLines)\r
 185   If InstrRev(myLines(i), "CKA_LABEL ") Then\r
 186     myPattern = "^CKA_LABEL\s+[A-Z0-9]+\s+""(.+?)"""\r
 187     myLabel = RegExprFirst(myPattern, myLines(i))\r
 188   End If\r
 189   If (myInsideCert = TRUE) Then\r
 190     If InstrRev(myLines(i), "END") Then\r
 191       myInsideCert = FALSE\r
 192       While (i < UBound(myLines)) And Not (myLines(i) = "#")\r
 193         i = i + 1\r
 194         If InstrRev(myLines(i), "CKA_TRUST_SERVER_AUTH CK_TRUST CKT_NSS_TRUSTED_DELEGATOR") Then\r
 195           myUntrusted = FALSE\r
 196         End If\r
 197       Wend\r
 198       If (myUntrusted = TRUE) Then\r
 199         myNumSkipped = myNumSkipped + 1\r
 200       Else\r
 201         myStream.WriteText myLabel & vbLf\r
 202         myStream.WriteText String(Len(myLabel), "=") & vbLf\r
 203         myPem = "-----BEGIN CERTIFICATE-----" & vbLf & _\r
 204                 Base64Encode(myData) & vbLf & _\r
 205                 "-----END CERTIFICATE-----" & vbLf\r
 206         If (myOptTxt = FALSE) Then\r
 207           myStream.WriteText myPem & vbLf\r
 208         Else\r
 209           Dim myCmd, myRval, myTmpIn, myTmpOut\r
 210           myTmpIn = objFSO.GetSpecialFolder(2).Path & "\" & objFSO.GetTempName\r
 211           myTmpOut = objFSO.GetSpecialFolder(2).Path & "\" & objFSO.GetTempName\r
 212           Set myTmpFh = objFSO.OpenTextFile(myTmpIn, 2, TRUE)\r
 213           myTmpFh.Write myPem\r
 214           myTmpFh.Close\r
 215           myCmd = """" & myOpenSSL & """ x509 -md5 -fingerprint -text " & _\r
 216                   "-inform PEM -in " & myTmpIn & " -out " & myTmpOut\r
 217           myRval = objShell.Run (myCmd, 0, TRUE)\r
 218           objFSO.DeleteFile myTmpIn, TRUE\r
 219           If Not (myRval = 0) Then\r
 220             MsgBox("Failed to process PEM cert with OpenSSL commandline!"), vbCritical, mySelf\r
 221             objFSO.DeleteFile myTmpOut, TRUE\r
 222             WScript.Quit 3\r
 223           End If\r
 224           Set myTmpFh = objFSO.OpenTextFile(myTmpOut, 1)\r
 225           myStream.WriteText myTmpFh.ReadAll & vbLf\r
 226           myTmpFh.Close\r
 227           objFSO.DeleteFile myTmpOut, TRUE\r
 228         End If\r
 229         myNumCerts = myNumCerts + 1\r
 230       End If\r
 231     Else\r
 232       myOctets = Split(myLines(i), "\")\r
 233       For j = 1 To UBound(myOctets)\r
 234         myData = myData & Chr(CByte("&o" & myOctets(j)))\r
 235       Next\r
 236     End If\r
 237   End If\r
 238   If InstrRev(myLines(i), "CVS_ID ") Then\r
 239     myPattern = "^CVS_ID\s+""(.+?)"""\r
 240     myRev = RegExprFirst(myPattern, myLines(i))\r
 241     myStream.WriteText "# " & myRev & vbLf & vbLf\r
 242   End If\r
 243   If InstrRev(myLines(i), "CKA_VALUE MULTILINE_OCTAL") Then\r
 244     myInsideCert = TRUE\r
 245     myUntrusted = TRUE\r
 246     myData = ""\r
 247   End If\r
 248   If InstrRev(myLines(i), "***** BEGIN LICENSE BLOCK *****") Then\r
 249     myInsideLicense = TRUE\r
 250   End If\r
 251   If (myInsideLicense = TRUE) Then\r
 252     myStream.WriteText myLines(i) & vbLf\r
 253     myLicenseText = myLicenseText & Mid(myLines(i), 2) & vbLf\r
 254   End If\r
 255   If InstrRev(myLines(i), "***** END LICENSE BLOCK *****") Then\r
 256     myInsideLicense = FALSE\r
 257     If (myAskLiF = TRUE) Then\r
 258       If Not (6 = objShell.PopUp(myLicenseText & vbLf & _\r
 259               "Do you agree to the license shown above (required to proceed) ?",, _\r
 260               mySelf, vbQuestion + vbYesNo + vbDefaultButton1)) Then\r
 261         myStream.Close\r
 262         objFSO.DeleteFile myCaFile, TRUE\r
 263         WScript.Quit 2\r
 264       End If\r
 265     End If\r
 266   End If\r
 267 Next\r
 268 \r
 269 ' To stop the UTF-8 BOM from being written the stream has to be copied and\r
 270 ' then saved as binary.\r
 271 Dim myCopy\r
 272 Set myCopy = CreateObject("ADODB.Stream")\r
 273 myCopy.Type = adTypeBinary\r
 274 myCopy.Open\r
 275 myStream.Position = 3 ' Skip UTF-8 BOM\r
 276 myStream.CopyTo myCopy\r
 277 myCopy.SaveToFile myCaFile, adSaveCreateOverWrite\r
 278 myCopy.Close\r
 279 myStream.Close\r
 280 Set myCopy = Nothing\r
 281 Set myStream = Nothing\r
 282 \r
 283 ' Done\r
 284 objShell.PopUp "Done (" & myNumCerts & " CA certs processed, " & myNumSkipped & _\r
 285                " untrusted skipped).", 20, mySelf, vbInformation\r
 286 WScript.Quit 0\r
 287 \r
 288 Function ConvertBinaryToUTF8(arrBytes)\r
 289   Dim objStream\r
 290   Set objStream = CreateObject("ADODB.Stream")\r
 291   objStream.Open\r
 292   objStream.Type = adTypeBinary\r
 293   objStream.Write arrBytes\r
 294   objStream.Position = 0\r
 295   objStream.Type = adTypeText\r
 296   objStream.Charset = "utf-8"\r
 297   ConvertBinaryToUTF8 = objStream.ReadText\r
 298   Set objStream = Nothing\r
 299 End Function\r
 300 \r
 301 Function SaveBinaryData(filename, data)\r
 302   Dim objStream\r
 303   Set objStream = CreateObject("ADODB.Stream")\r
 304   objStream.Type = adTypeBinary\r
 305   objStream.Open\r
 306   objStream.Write data\r
 307   objStream.SaveToFile filename, adSaveCreateOverWrite\r
 308   objStream.Close\r
 309   Set objStream = Nothing\r
 310 End Function\r
 311 \r
 312 Function RegExprFirst(SearchPattern, TheString)\r
 313   Dim objRegExp, Matches                        ' create variables.\r
 314   Set objRegExp = New RegExp                    ' create a regular expression.\r
 315   objRegExp.Pattern = SearchPattern             ' sets the search pattern.\r
 316   objRegExp.IgnoreCase = TRUE                   ' set to ignores case.\r
 317   objRegExp.Global = TRUE                       ' set to gloabal search.\r
 318   Set Matches = objRegExp.Execute(TheString)    ' do the search.\r
 319   If (Matches.Count) Then\r
 320     RegExprFirst = Matches(0).SubMatches(0)     ' return first match.\r
 321   Else\r
 322     RegExprFirst = ""\r
 323   End If\r
 324   Set objRegExp = Nothing\r
 325 End Function\r
 326 \r
 327 Function Base64Encode(inData)\r
 328   Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"\r
 329   Dim cOut, sOut, lWrap, I\r
 330   lWrap = Int(myWrapLe * 3 / 4)\r
 331 \r
 332   'For each group of 3 bytes\r
 333   For I = 1 To Len(inData) Step 3\r
 334     Dim nGroup, pOut, sGroup\r
 335 \r
 336     'Create one long from this 3 bytes.\r
 337     nGroup = &H10000 * Asc(Mid(inData, I, 1)) + _\r
 338              &H100 * MyASC(Mid(inData, I + 1, 1)) + _\r
 339              MyASC(Mid(inData, I + 2, 1))\r
 340 \r
 341     'Oct splits the long To 8 groups with 3 bits\r
 342     nGroup = Oct(nGroup)\r
 343 \r
 344     'Add leading zeros\r
 345     nGroup = String(8 - Len(nGroup), "0") & nGroup\r
 346 \r
 347     'Convert To base64\r
 348     pOut = Mid(Base64, CLng("&o" & Mid(nGroup, 1, 2)) + 1, 1) & _\r
 349            Mid(Base64, CLng("&o" & Mid(nGroup, 3, 2)) + 1, 1) & _\r
 350            Mid(Base64, CLng("&o" & Mid(nGroup, 5, 2)) + 1, 1) & _\r
 351            Mid(Base64, CLng("&o" & Mid(nGroup, 7, 2)) + 1, 1)\r
 352 \r
 353     'Add the part To OutPut string\r
 354     sOut = sOut + pOut\r
 355 \r
 356     'Add a new line For Each myWrapLe chars In dest\r
 357     If (I < Len(inData) - 2) Then\r
 358       If (I + 2) Mod lWrap = 0 Then sOut = sOut & vbLf\r
 359     End If\r
 360   Next\r
 361   Select Case Len(inData) Mod 3\r
 362     Case 1: '8 bit final\r
 363       sOut = Left(sOut, Len(sOut) - 2) & "=="\r
 364     Case 2: '16 bit final\r
 365       sOut = Left(sOut, Len(sOut) - 1) & "="\r
 366   End Select\r
 367   Base64Encode = sOut\r
 368 End Function\r
 369 \r
 370 Function MyASC(OneChar)\r
 371   If OneChar = "" Then MyASC = 0 Else MyASC = Asc(OneChar)\r
 372 End Function\r
 373 \r
 374 ' Return the date in the same format as perl to match mk-ca-bundle.pl output:\r
 375 ' Wed Sep  7 03:12:05 2016\r
 376 Function ConvertDateToString(input)\r
 377   Dim output\r
 378   output = WeekDayName(WeekDay(input), TRUE) & " " & _\r
 379            MonthName(Month(input), TRUE) & " "\r
 380   If (Len(Day(input)) = 1) Then\r
 381     output = output & " "\r
 382   End If\r
 383   output = output & _\r
 384            Day(input) & " " & _\r
 385            FormatDateTime(input, vbShortTime) & ":"\r
 386   If (Len(Second(input)) = 1) Then\r
 387     output = output & "0"\r
 388   End If\r
 389   output = output & _\r
 390            Second(input) & " " & _\r
 391            Year(input)\r
 392   ConvertDateToString = output\r
 393 End Function\r
 394 \r
 395 ' Convert local Date to UTC. Microsoft says:\r
 396 ' Use Win32_ComputerSystem CurrentTimeZone property, because it automatically\r
 397 ' adjusts the Time Zone bias for daylight saving time; Win32_Time Zone Bias\r
 398 ' property does not.\r
 399 ' https://msdn.microsoft.com/en-us/library/windows/desktop/ms696015.aspx\r
 400 Function LocalDateToUTC(localdate)\r
 401   Dim item, offset\r
 402   For Each item In GetObject("winmgmts:").InstancesOf("Win32_ComputerSystem")\r
 403     offset = item.CurrentTimeZone ' the offset in minutes\r
 404   Next\r
 405   If (offset < 0) Then\r
 406     LocalDateToUTC = DateAdd("n",  ABS(offset), localdate)\r
 407   Else\r
 408     LocalDateToUTC = DateAdd("n", -ABS(offset), localdate)\r
 409   End If\r
 410   'objShell.PopUp LocalDateToUTC\r
 411 End Function\r
 412 \r
 413 Function FileSHA256(filename)\r
 414   Dim cmd, rval, tmpOut, tmpFh\r
 415   if (myUseOpenSSL = TRUE) Then\r
 416     tmpOut = objFSO.GetSpecialFolder(2).Path & "\" & objFSO.GetTempName\r
 417     cmd = """" & myOpenSSL & """ dgst -r -sha256 -out """ & tmpOut & """ """ & filename & """"\r
 418     rval = objShell.Run(cmd, 0, TRUE)\r
 419     If Not (rval = 0) Then\r
 420       MsgBox("Failed to get sha256 of """ & filename & """ with OpenSSL commandline!"), vbCritical, mySelf\r
 421       objFSO.DeleteFile tmpOut, TRUE\r
 422       WScript.Quit 3\r
 423     End If\r
 424     Set tmpFh = objFSO.OpenTextFile(tmpOut, 1)\r
 425     FileSHA256 = RegExprFirst("^([0-9a-f]{64}) .+", tmpFh.ReadAll)\r
 426     tmpFh.Close\r
 427     objFSO.DeleteFile tmpOut, TRUE\r
 428   Else\r
 429     FileSHA256 = ""\r
 430   End If\r
 431 End Function\r