VBA - Parse JSON safer with JSON.Parse and not Eval

Advert: Come to the Foo Bar! See a whole working application based on Excel VBA, JSON, JavaScript, Angular with help of a beauty of C# COM Addin. The Foo Bar where the beers are easily replenished with Angular.

A popular post on this blog is about parsing JSON in VBA. I talk about the ScriptControl and using Eval but giving a security warning about how only to run it on JSON from trusted sources. Well, today I can give a safer code sample that avoids Eval and uses a recommended library from Douglas Crockford no less. This post focuses on the security loophole not for exploitation but for defence. I AM WARNING ABOUT AND NOT RECOMMENDING EVAL.

The following code has two subs Proof_That_ScriptControl_Eval_Executes_Injected_Javascript() which proves the security loophole by using code injected JSON to write a temp file to the user's temp directory. The other sub Attempt_To_Parse_Injected_Code_With_JSON_Parse_Throws_Error() demonstrates how an attempt to inject code into JSON through JSON.Parse throws an error.

The recommended library is now standard for modern browsers. To get the library into the ScriptControl we need to download from https://raw.githubusercontent.com/douglascrockford/JSON-js/master/json2.js. The code below does this and we an extra shim JSON_parse() to make it callable from VBA.

For more information one can consult the following links

• Wikipedia - Douglas Crockford
• GitHub - douglascrockford - json2.js
• StackOverflow - Safely turning a JSON string into an object

Option Explicit

'* Tools->References
' MSScriptControl      Microsoft Script Control 1.0    C:\Windows\SysWOW64\msscript.ocx
' Scripting            Microsoft Scripting Runtime     C:\Windows\SysWOW64\scrrun.dll
' MSXML2               Microsoft XML, v6.0             C:\Windows\SysWOW64\msxml6.dll


Function CodeInjectingJson() As String
    CodeInjectingJson = "{""foo"":""bar"", a:(function(){(new ActiveXObject('Scripting.FileSystemObject'))." & _
                        "GetSpecialFolder(2).CreateTextFile('random.txt')." & _
                        "Write('Use JSON.parse instead');})()}"
End Function

Private Sub Proof_That_ScriptControl_Eval_Executes_Injected_Javascript()

    Dim fso As Scripting.FileSystemObject
    Set fso = New Scripting.FileSystemObject
    
    If fso.FileExists(Environ$("USERPROFILE") & "\AppData\Local\Temp\random.txt") Then
        fso.DeleteFile Environ$("USERPROFILE") & "\AppData\Local\Temp\random.txt"
    End If
    
    Debug.Assert Not fso.FileExists(Environ$("USERPROFILE") & "\AppData\Local\Temp\random.txt")
    
    Dim oSC As ScriptControl
    Set oSC = SC
    
    Stop
    Dim obj As Object
    Set obj = oSC.Eval("(" & CodeInjectingJson & ")")
    Stop
    
    Debug.Assert fso.FileExists(Environ$("USERPROFILE") & "\AppData\Local\Temp\random.txt")
    End ' <- need this to kill references and garbage collect
End Sub

Private Sub Attempt_To_Parse_Injected_Code_With_JSON_Parse_Throws_Error()

    Dim fso As Scripting.FileSystemObject
    Set fso = New Scripting.FileSystemObject
    
    If fso.FileExists(Environ$("USERPROFILE") & "\AppData\Local\Temp\random.txt") Then
        fso.DeleteFile Environ$("USERPROFILE") & "\AppData\Local\Temp\random.txt"
    End If


    Debug.Assert Not fso.FileExists(Environ$("USERPROFILE") & "\AppData\Local\Temp\random.txt")
    
    Dim oSC As ScriptControl
    Set oSC = SC
    
    'Stop
    Dim objSafelyParsed As Object
    Set objSafelyParsed = SC.Run("JSON_parse", CodeInjectingJson)
   
    
    'Details of error thrown {
    ' Err.Number=5022,
    ' Err.Description="Exception thrown and not caught",
    ' Err.Source="Microsoft JScript runtime error"
    ' }
    
    '* search for '5022' on https://docs.microsoft.com/en-us/scripting/javascript/reference/javascript-run-time-errors
    '* links to  https://docs.microsoft.com/en-us/scripting/javascript/misc/exception-thrown-and-not-caught
    '* also https://referencesource.microsoft.com/#Microsoft.JScript/Microsoft/JScript/JSError.cs,a0c5ae7e7c2dd23c,references
    Stop
End Sub

Private Function SC() As ScriptControl
    Static soSC As ScriptControl
    If soSC Is Nothing Then

        Set soSC = New ScriptControl
        soSC.Language = "JScript"
        
        '* https://stackoverflow.com/questions/45015/safely-turning-a-json-string-into-an-object
        soSC.AddCode GetJavaScriptLibrary("https://raw.githubusercontent.com/douglascrockford/JSON-js/master/json2.js")
        soSC.AddCode "function JSON_parse(sJson) { return JSON.parse(sJson); } "

    End If
    Set SC = soSC
End Function

Private Function GetJavaScriptLibrary(ByVal sURL As String) As String

    Dim xHTTPRequest As MSXML2.XMLHTTP60
    Set xHTTPRequest = New MSXML2.XMLHTTP60
    xHTTPRequest.Open "GET", sURL, False
    xHTTPRequest.send
    GetJavaScriptLibrary = xHTTPRequest.responseText

End Function