VBA API for parse.com

cParseCom.cls

Option Explicit
' a VBA class for parse.com
' v1.2
Private pBrowser As cBrowser
Private pPackage As cJobject
Private pClass As String
Private pApplicationHeaders As cJobject
Private pSalt As String
Private pBatch As cJobject
Private pBatchPoint As String
Private pBatchMode As Boolean
Private pEndPoint As String
Private pClassPoint As String
Private pBatchMax As Long

Public Property Get parseClass() As String
    parseClass = pClass
End Property
Public Property Let parseClass(p As String)
    pClass = p
End Property
Public Function resultsLength(Optional job As cJobject = Nothing) As Long
    Dim j As cJobject
    Set j = job
    If j Is Nothing Then
        Set j = jObject
    End If
    resultsLength = j.child("results").children.count
    If job Is Nothing Then
        j.tearDown
    End If
End Function
Public Function count(Optional queryJob As cJobject = Nothing, Optional queryParams As cJobject = Nothing) As Long
    count = 0
    With getCount(queryJob, queryParams)
        If .isOk Then
            With .jObject
                count = .child("count").value
                .tearDown
            End With
        End If
    End With

End Function
Public Property Get self() As cParseCom
    Set self = Me
End Property
Public Property Get jObject()
    Set jObject = JSONParse(browser.Text)
End Property
Public Property Get browser()
    Set browser = pBrowser
End Property
Public Property Get isOk() As Boolean
    
    isOk = False
    If pBrowser.isOk Or (pBrowser.status = 0 And pBatchMode) Then
        If Not pBatchMode Then
            isOk = True
        Else
            ' need to check for errors in all the flushed batch
            With jObject
                isOk = .find("error") Is Nothing
                .tearDown
            End With
        End If
    End If
End Property
Public Function init(whichClass As String, _
        Optional credentialsEntry As String = "parse", _
        Optional scopeEntry As String = "rest", _
        Optional restAPIKey As String = vbNullString, _
        Optional clientKey As String = vbNullString) As cParseCom

    Set pPackage = getParseCredentials(credentialsEntry, scopeEntry, restAPIKey, clientKey)
    If pPackage Is Nothing Then
        Exit Function
    End If
    
    Set pApplicationHeaders = getApplicationHeaders
    pClass = whichClass
    Set init = Me
    
End Function
Public Function getObjectById(id As String) As cParseCom
    Set getObjectById = getStuff("/" & id)
End Function
Public Function getObjectsByQuery(Optional queryJob As cJobject = Nothing, _
        Optional queryParams As cJobject = Nothing) As cParseCom

    Set getObjectsByQuery = getStuff(vbNullString, constructQueryString(queryJob, queryParams))
End Function
Private Function constructQueryString(Optional queryJob As cJobject = Nothing, _
        Optional queryParams As cJobject = Nothing) As String
    Dim qString As String, t As cStringChunker, job As cJobject
    
    ' set up parameters
    Set t = New cStringChunker
    
    If Not queryParams Is Nothing Then
        For Each job In queryParams.children
            t.add(job.key).add("=").add(job.toString).add ("&")
        Next job
    End If
    ' set up query string
    If Not queryJob Is Nothing Then
        t.add URLEncode("where=" & JSONStringify(queryJob))
    End If
    qString = vbNullString
    t.chopIf "&"
    If t.size > 0 Then
        qString = "?" & t.content
    End If
    Set t = Nothing
    constructQueryString = qString
End Function
Private Function mergeParameters(Optional queryParams As cJobject = Nothing, Optional addParams As cJobject = Nothing) As cJobject
    Dim job As cJobject
    
    ' start with the given params
    If Not queryParams Is Nothing Then
        ' take a copy
        Set job = JSONParse(queryParams.stringify)
    End If
    
    ' add some more
    If Not addParams Is Nothing Then
        If job Is Nothing Then
            Set job = New cJobject
            job.init Nothing
        End If
        job.merge addParams
    End If
    
    Set mergeParameters = job
End Function
Public Function getCount(Optional queryJob As cJobject = Nothing, Optional queryParams As cJobject = Nothing) As cParseCom
        
    Set getCount = getStuff(vbNullString, _
        constructQueryString(queryJob, mergeParameters(queryParams, JSONParse("{'count':1,'limit':0}"))))
    
End Function
Public Function createObject(addJob As cJobject) As cParseCom
    Set createObject = postStuff(vbNullString, addJob)
End Function

Public Function updateObjects(Optional queryJob As cJobject = Nothing, _
        Optional updateJob As cJobject = Nothing, Optional queryParameters As cJobject = Nothing) As cParseCom
    ' does a query, then update all matching
    
    Dim queryResponse As cJobject, skip As Long, jobSkip As cJobject, number As Long
    skip = 0
    Set jobSkip = JSONParse("{'skip':0}")
    ' we'll just use the default limit
    Do
        With getObjectsByQuery(queryJob, mergeParameters(queryParameters, jobSkip)).jObject
            ' this is how many were returned this time
            number = resultsLength(.self)
            ' if there were any then do soemthing with it
            If number > 0 Then
                
                ' skip what we've already had
                skip = skip + number
                jobSkip.child("skip").value = skip
                
                ' update the contents of the query we just did
                updateObjectsPart .self, updateJob
            End If
            ' clear out these results
            .tearDown
        End With
        
        ' if there were any errors or there's no more to do then exit
    Loop While isOk And number > 0

    Set updateObjects = Me
End Function
Private Function updateObjectsPart(queryResponse As cJobject, updateJob As cJobject) As cParseCom

    Dim job As cJobject
    ' any matching get the same update
    If isOk And Not queryResponse Is Nothing Then
        With queryResponse
            For Each job In .child("results").children
                postStuff job.child("objectId").value, updateJob, "PUT"
            Next job
            .tearDown
        End With
    End If

    Set updateObjectsPart = Me
End Function
Public Function deleteObjects(Optional queryJob As cJobject = Nothing) As cParseCom
    Dim queryResponse As cJobject
    
    ' query is limited, so we need to keep going until no results
    While self.count > 0
        Set queryResponse = getObjectsByQuery(queryJob).jObject
        deleteObjectsPart queryResponse
        If Not isOk Then
            MsgBox "failed to flush:" & browser.status & ":" & browser.Text
            Exit Function
        End If
        queryResponse.tearDown
    Wend
    Set deleteObjects = Me
End Function
Private Function deleteObjectsPart(queryResponse As cJobject) As cParseCom
    ' does a query, then update all matching
    Dim job As cJobject

    ' any matching get deleted
    If isOk Then
        For Each job In queryResponse.child("results").children
            deleteObject job.child("objectId").value
        Next job
    End If
    Set deleteObjectsPart = Me
End Function
Public Function deleteObject(id As String) As cParseCom
    If pBatchMode Then
        postStuff id, , "DELETE"
    Else
        Set deleteObject = getStuff("/" & id, , "DELETE")
    End If
End Function
Public Function postStuff(what As String, Optional data As cJobject = Nothing, _
                                Optional method As String = "POST") As cParseCom
    
    If pBatchMode Then
        If isEmptyBatchNeeded Then flush
        addToBatch method, pClassPoint & parseClass & "/" & what, data
    Else
       doPost pEndPoint & pClassPoint & parseClass & "/" & what, data, method
    End If
    Set postStuff = Me
End Function
Public Function getStuff(what As String, Optional params As String = vbNullString, Optional method As String = "GET") As cParseCom
    Dim post As String
    
    'always need to flush before a get
    flush
    
    pBrowser.httpGET pEndPoint & pClassPoint & parseClass & what & params, , , , , , pApplicationHeaders, method
    Set getStuff = Me
End Function
Private Function doPost(url As String, Optional data As cJobject = Nothing, Optional method As String = "POST") As cParseCom
    ' called when we need to issue a get
    Dim dString As String
    If Not data Is Nothing Then dString = data.stringify
    pBrowser.httpPost url, dString, True, , pApplicationHeaders, method
    Set doPost = Me
End Function
Private Function clearDown(o As Object) As cParseCom
    If Not o Is Nothing Then
        o.tearDown
        Set o = Nothing
    End If
    Set clearDown = Me
End Function
Private Function isEmptyBatchNeeded() As Boolean

    ' there's a maximum to how many we can batch at once
    isEmptyBatchNeeded = False
    If Not pBatch Is Nothing Then isEmptyBatchNeeded = (pBatch.child("requests").children.count >= pBatchMax)
    
End Function
Private Function addToBatch(method As String, path As String, Optional body As cJobject = Nothing)
    If pBatch Is Nothing Then
        Set pBatch = New cJobject
        pBatch.init Nothing
    End If
    ' first in?
    If Not pBatch.hasChildren Then
        pBatch.add("requests").addArray
    End If
    With pBatch.child("requests").add
        If Right(path, 1) = "/" Then path = left(path, Len(path) - 1)
        .add "method", method
        .add "path", path
        If Not body Is Nothing Then
            With .add("body")
                .append body
            End With
        End If
    End With
    Set addToBatch = Me
End Function
Public Function batch(Optional batchItUp As Boolean = True) As cParseCom

    ' use this to set up batching. if any outstanding it will clear it if changing batching mode
    If Not batchItUp Then
        flush
    End If

    pBatchMode = batchItUp
    Set batch = Me
    
End Function
Public Property Get batchMode() As Boolean
    batchMode = pBatchMode
End Property
Public Function flush()
    ' been storing stuff up
    If Not pBatch Is Nothing Then
        If (pBatch.hasChildren) Then
            doPost pEndPoint & pBatchPoint, pBatch, "POST"
            If Not isOk Then
                MsgBox "failed to flush:" & browser.status & ":" & browser.Text
            End If
            pBatch.tearDown
        End If
        Set pBatch = Nothing
    End If
    Set flush = Me
End Function
Public Sub tearDown()
    clearDown pBrowser
    clearDown pPackage
    clearDown pApplicationHeaders
    clearDown pBatch
End Sub
Private Sub Class_Initialize()
    Set pBrowser = New cBrowser
    pEndPoint = "https://api.parse.com"
    pClassPoint = "/1/classes/"
    pBatchPoint = "/1/batch"
    pSalt = "xLiberation"
    pBatchMode = False
    pBatchMax = 50
End Sub
Private Function getParseCredentials(entry As String, scope As String, _
        Optional restAPIKey As String = vbNullString, _
        Optional clientKey As String = vbNullString) As cJobject

    Set pPackage = getRegistryPackage(entry, scope)
    
    If pPackage Is Nothing Then
        If (restAPIKey = vbNullString Or clientKey = vbNullString) Then
            MsgBox ("First time you need to provide keys")
            Exit Function
        End If
        Set pPackage = New cJobject
        With pPackage.init(Nothing)
            .add "scopeEntry", scope
            .add "authFlavor", entry
            .add "restAPIKey", restAPIKey
            .add "applicationID", clientKey
        End With
        setRegistryPackage
    End If
    
    Set getParseCredentials = pPackage
    
End Function
Private Function getApplicationHeaders() As cJobject
    Dim job As cJobject, a As cJobject
    Set job = New cJobject
    
    With job.init(Nothing)
        .add "X-Parse-Application-Id", pPackage.child("applicationID").value
        .add "X-Parse-REST-API-Key", pPackage.child("restAPIKey").value
    End With
    Set getApplicationHeaders = job
End Function
'" ---- registry -----
'" in registry entries, the values are encrypted useing the salt
'" the structure is
'" xLiberation/parseAuth/scope - json pPackage values
Private Function getRegistryPackage(authFlavor As String, scopeEntry As String) As cJobject
    Dim s As String
    s = GetSetting("xLiberation", _
            authFlavor, _
            scopeEntry)
    
    If (s <> vbNullString) Then Set getRegistryPackage = JSONParse(decrypt(s))
End Function
Private Function setRegistryPackage() As cJobject
    Dim s As String
    s = JSONStringify(pPackage)
    SaveSetting "xLiberation", _
            pPackage.child("authFlavor").value, _
            pPackage.child("scopeEntry").value, _
            encrypt(s)
            
End Function

Private Function encrypt(s As String) As String
'    " uses capicom
    encrypt = encryptMessage(s, pSalt)
End Function
Private Function decrypt(s As String) As String
'    " uses capicom
    decrypt = decryptMessage(s, pSalt)
End Function

parseCom.vba

Option Explicit
'v1.2
Private Sub firstTimeParseCom()
    Dim parseCom As cParseCom
    Set parseCom = New cParseCom
    With parseCom.init("ColorTable", , , "your app id", _
                "your restapikey")
        .tearDown
    End With
End Sub

Private Sub populates()
    ' copy two sheets to parse.com
    populateFromSheet "VBAParseCustomers"
    populateFromSheet "VBAParseData"
    
End Sub
Private Sub populateFromSheet(sheetName As String)
    Dim parseCom As cParseCom, job As cJobject, dset As cDataSet
    
    ' this will clear out an existing parse class, and create a new one from a worksheet
    ' we'll use batch mode throughout
    
    Set parseCom = getParsed(sheetName).batch
    
    ' clear out existing any existing data
    parseCom.deleteObjects

    'get the data from the sheet and populate database
    Set dset = New cDataSet
    With dset.populateData(wholeSheet(sheetName), , , , , , True).jObject(, True, True)
        For Each job In .children
            With parseCom.createObject(job)
                ' clear this error handling up
                Debug.Assert .isOk
            End With
        Next job
        ' clear up
        .tearDown
    End With
    
    ' commit any outstanding  and clean up
    With parseCom.flush.batch(False)
        Debug.Assert .isOk
        ' show how many are there now
        Debug.Print .count & " in class" & sheetName
        .tearDown
    End With

End Sub

Private Sub testGetItemByUniqueId()

    ' get an item by unique object ID
    With getParsed("VBAParseCustomers")
        .getObjectById ("SmnyjZKs9m")
        ' test if it worked, and do something with the results
        If .isOk Then
            Debug.Print .jObject.stringify(True)
        Else
            Debug.Print "failed to get object:" & .browser.url & ":" & .browser.status & ":" & .browser.Text
        End If
        .tearDown
    End With

End Sub
Private Sub testparseUpdate()

    ' get some items by query and change the scheme name to something else
    With getParsed("VBAParseData").batch
        With .updateObjects(JSONParse("{'customerid':39}"), JSONParse("{'customerid':1}"))
            ' test if it worked, and do something with the results
            If .isOk Then
                Debug.Print "all is good", .jObject.stringify
            Else
                Debug.Print "failed to update:" & .browser.url & ":" & .browser.status & ":" & .browser.Text
            End If
        End With
        .flush.tearDown
    End With

End Sub

Private Sub testparsequery()
    
    ' get a number of items that match a query by example
    With getParsed("VBAParseData")
        With .getObjectsByQuery(JSONParse("{'customerid':1}"), JSONParse("{'limit':2}"))
            'test if it worked, and do something with the results
            If .isOk Then
                Debug.Print "all is ok", .jObject.stringify(True)
            Else
                Debug.Print "failed to do query:" & .browser.url & ":" & .browser.status & ":" & .browser.Text
            End If
        End With
        .tearDown
    End With
    
End Sub
Private Sub testparseCount()
    
    ' get a number of items that match a query by example
    Debug.Print getParsed("VBAParseData").count(JSONParse("{'customerid':1}"))
    
End Sub

Private Sub parseMatch()
    Dim pCustomer As New cParseCom, pData As cParseCom, job As cJobject, joc As cJobject, queryJob As cJobject
    ' look up data in another table based on data in another
    
    ' data abot the pantone colors of the year
    Set pCustomer = getParsed("VBAParseCustomers")
    Set pData = getParsed("VBAParseData")
    
    ' set up a query by example, restricting to a particular customer
    Set queryJob = New cJobject
    queryJob.init(Nothing).add "country", "United States"
        
    ' go through all matching customers
    With pCustomer.getObjectsByQuery(queryJob)
        If .isOk Then
            With .jObject.child("results")
                For Each job In .children
                    With pData.getObjectsByQuery(job.child("customerid"))
                        If .isOk Then
                            With .jObject.child("results")
                                For Each joc In .children
                                    Debug.Print job.toString("country"), job.toString("name"), job.child("customerid").value, joc.child("invoiceid").value
                                Next joc
                            End With
                        End If
                    End With
                Next
            End With
        End If
    End With

    
    ' clean up
    queryJob.tearDown
    pCustomer.tearDown
    pData.tearDown
    
End Sub
Public Function getParsed(parseClass As String) As cParseCom
    Dim p As cParseCom
    Set p = New cParseCom
    Set getParsed = p.init(parseClass)
    
End Function