Skip to content

Instantly share code, notes, and snippets.

@brucemcpherson

brucemcpherson/cDeadDrop.cls

Last active December 31, 2015 05:49
Show Gist options
  • Save brucemcpherson/7943765 to your computer and use it in GitHub Desktop.
Save brucemcpherson/7943765 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
cDeadDrop.cls
'[email protected] :do not modify this line - see ramblings.mcpher.com for details: updated on 2/3/2014 6:52:09 PM : from manifest:8767201 gist https://gist.github.com/brucemcpherson/7943765/raw/cDeadDrop.cls
Option Explicit
' v1.2
Private pScriptDb As cScriptDbCom
Private pPackage As cJobject
Private Const deadDropKey = "xLiberationConversations"
Public Property Get willExpireAt() As Date
willExpireAt = DateAdd("n", 24 * 60, Now())
End Property
Public Property Get key() As String
key = pPackage.toString("key")
End Property
Public Property Get entry() As String
entry = pPackage.toString("entry")
End Property
Public Property Get scriptDbClass() As String
scriptDbClass = pPackage.toString("class")
End Property
Public Property Get scriptDb() As cScriptDbCom
Set scriptDb = pScriptDb
End Property
Public Property Get self() As cDeadDrop
Set self = Me
End Property
Public Function init(yourClass As String, _
Optional yourScriptDbEntry As String = vbNullString, _
Optional initial As Boolean = False, _
Optional specificKey As String = vbNullString) As cDeadDrop
' will set up a scriptDB class and give it a unique key
' this is self cleansing - will clean registry every time it is called
cleanExpired yourClass
' firstly we'll try to get it from registry
Set pPackage = getRegistryPackage(yourClass, specificKey)
' if we got a specific key, then we should have found it, so return null to fail
If pPackage Is Nothing And specificKey <> vbNullString Then Exit Function
If Not pPackage Is Nothing And Not initial Then
' we found it, by default the entry is to be found in the package, but if one is specified,we override
If (yourScriptDbEntry <> vbNullString) Then
pPackage.add "entry", yourScriptDbEntry
setRegistryPackage
End If
Else
' this is a first time for this conversation
If (yourScriptDbEntry = vbNullString) Then yourScriptDbEntry = "scriptDb"
Set pPackage = JSONParse( _
"{'key':'" & yourClass & Replace(CStr(tinyTime), ".", "") _
& "','class':'" & yourClass & "','entry':'" & yourScriptDbEntry & "'}")
setRegistryPackage
End If
' assumes you have already set up their pc for scriptDb access (run firsttimescriptdbmessages)
Set pScriptDb = getScriptDb(self.key, self.entry)
Set init = self
End Function
Public Sub tearDown()
If Not pPackage Is Nothing Then
pPackage.tearDown
End If
If Not pScriptDb Is Nothing Then
pScriptDb.tearDown
End If
End Sub
'" ---- registry -----
'" in registry entries, the values are encrypted useing the salt
'" the structure is
'" xLiberation/conversations/key
Private Function getRegistryPackage(yourClass As String, _
Optional specificKey As String = vbNullString) As cJobject
Dim s As String, t As String, job As cJobject
If specificKey = vbNullString Then
Set job = getLatest(yourClass)
If Not job Is Nothing Then t = job.toString("key")
Else
t = specificKey
End If
If (t <> vbNullString) Then
s = GetSetting(deadDropKey, _
yourClass, _
t)
End If
If (s <> vbNullString) Then Set getRegistryPackage = JSONParse(decryptMessage(s, yourClass))
End Function
Private Sub setRegistryPackage()
Dim s As String
pPackage.add "expires", self.willExpireAt
s = JSONStringify(pPackage)
SaveSetting deadDropKey, _
scriptDbClass(), _
self.key, _
encryptMessage(s, scriptDbClass())
End Sub
Private Function getLatest(yourClass) As cJobject
' find the latest conversation for this class
Dim a As Variant, i As Long, latestJob As cJobject, job As cJobject
a = GetAllSettings(deadDropKey, yourClass)
If Not IsEmpty(a) Then
For i = LBound(a, 1) To UBound(a, 1)
Set job = JSONParse(decryptMessage(CStr(a(i, 1)), yourClass))
If latestJob Is Nothing Then
Set latestJob = job
Else
If (isSomething(job.childExists("expires"))) Then
If job.child("expires").value > job.child("expires").value Then
Set latestJob = job
End If
End If
End If
Next i
End If
Set getLatest = latestJob
End Function
Private Sub cleanExpired(yourClass As String)
' this can be called to clean out old conversations from the registry
Dim a As Variant, latest As Variant, job As cJobject, i As Long
' get all the entries for this class
a = GetAllSettings(deadDropKey, yourClass)
' delete all expired
If Not IsEmpty(a) Then
For i = LBound(a, 1) To UBound(a, 1)
Set job = JSONParse(decryptMessage(CStr(a(i, 1)), yourClass))
If (isSomething(job.childExists("expires"))) Then
If job.child("expires").value < Now() Then
DeleteSetting deadDropKey, yourClass, job.toString("key")
End If
Else
DeleteSetting deadDropKey, yourClass, job.toString("key")
End If
Next i
End If
End Sub
Raw
cScriptDbCom.cls
'[email protected] :do not modify this line - see ramblings.mcpher.com for details: updated on 2/3/2014 6:52:09 PM : from manifest:8767201 gist https://gist.github.com/brucemcpherson/7943765/raw/cScriptDbCom.cls
Option Explicit
' a VBA class for scriptDb
' v1.5
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 pBatchMode As Boolean
Private pClassPoint As String
Private pBatchMax As Long
Private poAuth2 As cOauth2
Private pDebug As Boolean
Public Property Get scriptDbClass() As String
scriptDbClass = pClass
End Property
Public Property Let scriptDbClass(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
If isSomething(j.childExists("results")) Then
resultsLength = j.child("results").children.count
End If
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 cScriptDbCom
Set self = Me
End Property
Public Property Get jObject() As cJobject
Set jObject = JSONParse(browser.Text, , False)
End Property
Public Property Get browser() As cBrowser
Set browser = pBrowser
End Property
Public Property Get isOk() As Boolean
isOk = False
If pBrowser.isOk Or (pBrowser.status = 0 And pBatchMode) Then
With jObject
If Not .childExists("status") Is Nothing Then
isOk = .isValid And .toString("status") = "good"
Else
isOk = False
End If
.tearDown
End With
End If
End Property
Public Function init(Optional whichClass As String = "defaultClass", _
Optional credentialsEntry As String = "scriptDb", _
Optional scopeEntry As String = "rest", _
Optional restAPIKey As String = vbNullString, _
Optional clientKey As String = vbNullString, _
Optional needDebug As Boolean = False, _
Optional library As String = vbNullString, _
Optional needOauth As Variant, _
Optional newEndPoint As String = vbNullString) As cScriptDbCom
getScriptDbCredentials credentialsEntry, scopeEntry, restAPIKey, clientKey, newEndPoint, needOauth, library
If pPackage Is Nothing Then
Exit Function
End If
' get oauth detail
If getNeedOAuth Then
Set poAuth2 = getGoogled("drive")
End If
Set pApplicationHeaders = getApplicationHeaders
pClass = whichClass
pDebug = needDebug
Set init = Me
End Function
Private Function getEndPoint() As String
getEndPoint = pPackage.child("endPoint").value
End Function
Private Function getNeedOAuth() As String
getNeedOAuth = pPackage.child("needAuth").value
End Function
Private Function getLibrary() As String
If isSomething(pPackage.childExists("library")) Then
getLibrary = pPackage.child("library").value
Else
getLibrary = vbNullString
End If
End Function
Public Function getObjectById(id As String) As cScriptDbCom
Set getObjectById = getStuff("&objectid=" & id)
End Function
Public Function getObjectsByQuery(Optional queryJob As cJobject = Nothing, _
Optional queryParams As cJobject = Nothing) As cScriptDbCom
Set getObjectsByQuery = getStuff(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 "where=" & URLEncode(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 cScriptDbCom
Set getCount = getStuff( _
constructQueryString(queryJob, mergeParameters(queryParams, JSONParse("{'count':1}"))))
End Function
Public Function createObject(addJob As cJobject) As cScriptDbCom
Set createObject = postStuff(addJob)
End Function
Public Function updateObjectById(id As String, Optional updateJob As cJobject = Nothing) As cScriptDbCom
With getObjectById(id)
If .isOk Then
updateJob.add "objectId", id
postStuff updateJob, "PUT"
End If
End With
Set updateObjectById = Me
End Function
Public Function updateObjects(Optional queryJob As cJobject = Nothing, _
Optional updateJob As cJobject = Nothing, Optional queryParameters As cJobject = Nothing) As cScriptDbCom
' 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 cScriptDbCom
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
updateJob.add "objectId", job.child("objectId").value
postStuff updateJob, "PUT"
Next job
.tearDown
End With
End If
Set updateObjectsPart = Me
End Function
Public Function deleteObjects(Optional queryJob As cJobject = Nothing) As cScriptDbCom
Dim queryResponse As cJobject
Dim previousCount As Long, thisCount As Long
' query is limited, so we need to keep going until no results
thisCount = self.count
previousCount = 0
While thisCount <> previousCount
previousCount = thisCount
Set queryResponse = getObjectsByQuery(queryJob).jObject
deleteObjectsPart queryResponse
If Not isOk Then Exit Function
queryResponse.tearDown
thisCount = self.count
Wend
Set deleteObjects = Me
End Function
Private Function deleteObjectsPart(queryResponse As cJobject) As cScriptDbCom
' 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
If Not deleteObject(job.child("objectId")).isOk Then Exit For
Next job
End If
Set deleteObjectsPart = Me
End Function
Public Function deleteObject(jid As cJobject) As cScriptDbCom
If pBatchMode Then
postStuff jid, "DELETE"
Else
batch(True).deleteObject(jid).batch False
End If
Set deleteObject = Me
End Function
Public Function postStuff(Optional data As cJobject = Nothing, _
Optional method As String = "POST") As cScriptDbCom
' always batched, even if only one.
If pBatchMode Then
If isEmptyBatchNeeded Then flush
addToBatch method, scriptDbClass, data
Else
batch(True).postStuff(data, method).batch False
End If
Set postStuff = Me
End Function
Private Function getOauthHeader() As String
If poAuth2 Is Nothing Then
getOauthHeader = vbNullString
Else
getOauthHeader = poAuth2.authHeader
End If
End Function
Public Function getStuff(Optional params As String = vbNullString, Optional method As String = "GET") As cScriptDbCom
Dim post As String
'always need to flush before a get
flush
pBrowser.httpGET getEndPoint & "?db=scriptdb&" & pClassPoint & scriptDbClass & debugParam & libraryParam & params & getApiVersion, _
, , , , getOauthHeader, pApplicationHeaders, method
Set getStuff = Me
End Function
Private Function getApiVersion() As String
getApiVersion = "&api=VBAv0103"
End Function
Private Function doPost(url As String, Optional data As cJobject = Nothing, Optional method As String = "POST") As cScriptDbCom
' called when we need to issue a get
Dim dString As String
If Not data Is Nothing Then dString = data.stringify
pBrowser.httpPost url & "?db=scriptdb" & debugParam & libraryParam & getApiVersion, dString, True, getOauthHeader, pApplicationHeaders, method
Set doPost = Me
End Function
Private Function debugParam(Optional argJoin As String = "&") As String
If pDebug Then
debugParam = argJoin & "debug=1"
Else
debugParam = vbNullString
End If
End Function
Private Function libraryParam(Optional argJoin As String = "&") As String
If getLibrary = vbNullString Then
libraryParam = vbNullString
Else
libraryParam = argJoin & "library=" & getLibrary
End If
End Function
Private Function clearDown(o As Object) As cScriptDbCom
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
.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 cScriptDbCom
' use this to set up batching. if any outstanding it will clear it if changing batching mode
If pBatchMode <> 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() As cScriptDbCom
' been storing stuff up
If Not pBatch Is Nothing Then
If (pBatch.hasChildren) Then
doPost getEndPoint, 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
pClassPoint = "class="
pSalt = "xLiberation"
pBatchMode = False
pBatchMax = 50
End Sub
Private Function getScriptDbCredentials(entry As String, scope As String, _
Optional restAPIKey As String = vbNullString, _
Optional clientKey As String = vbNullString, _
Optional endPoint As String = vbNullString, _
Optional needAuth As Variant, _
Optional library As String = vbNullString) As cScriptDbCom
Set pPackage = getRegistryPackage(entry, scope)
Dim b As Boolean
If IsMissing(needAuth) Then b = True
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
.add "endPoint", endPoint
.add "needauth", b
.add "library", library
End With
End If
' in case anything changed
If restAPIKey <> vbNullString Then
pPackage.add "restAPIKey", restAPIKey
End If
If clientKey <> vbNullString Then
pPackage.add "applicationID", clientKey
End If
If endPoint <> vbNullString Then
pPackage.add "endPoint", endPoint
End If
If library <> vbNullString Then
pPackage.add "library", library
End If
If Not IsMissing(needAuth) Then
pPackage.add "needAuth", needAuth
End If
' update registry in case any changes
setRegistryPackage
End Function
Private Function getApplicationHeaders() As cJobject
Dim job As cJobject, a As cJobject
Set job = New cJobject
With job.init(Nothing)
.add "X-scriptDb-Application-Id", pPackage.child("applicationID").value
.add "X-scriptDb-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/scriptDbAuth/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 Sub setRegistryPackage()
Dim s As String
s = JSONStringify(pPackage)
SaveSetting "xLiberation", _
pPackage.child("authFlavor").value, _
pPackage.child("scopeEntry").value, _
encrypt(s)
End Sub
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
Raw
scriptDbCom.vba
'[email protected] :do not modify this line - see ramblings.mcpher.com for details: updated on 2/3/2014 6:52:09 PM : from manifest:8767201 gist https://gist.github.com/brucemcpherson/7943765/raw/scriptDbCom.vba
Option Explicit
'v1.4
' examples for cScriptDbCom
' see http://ramblings.mcpher.com/Home/excelquirks/scriptdb/scriptdbapi
Private Sub firstTimescriptdbComdbTest()
Dim scriptdbCom As cScriptDbCom, url As String
Set scriptdbCom = New cScriptDbCom
' you only need to run this once per PC. Once you've done it, delete it from here and keep a safe private copy somewhere
' this url is for the dbHandler google apps script webapp
url = "https://script.google.com/a/macros/mcpher.com/s/AKfycbyro1-9LNOnaykvBJ4_6pRZJwNkgf-VFpeQ8drJBqzOK3QZIhU/exec"
'substitute in your google oauth2 credentials (clientid/secret) from the google cloud console
getGoogled("drive", , "xxx.apps.googleusercontent.com", "xxx").tearDown
' get full access to the test environment
With scriptdbCom.init(, "dbTest", , _
"yourApp", _
"yourKey", , , True, _
"https://script.google.com/a/macros/mcpher.com/s/AKfycbyro1-9LNOnaykvBJ4_6pRZJwNkgf-VFpeQ8drJBqzOK3QZIhU/exec")
.tearDown
End With
' and full access to the production environment
With scriptdbCom.init(, "dbProduction", , _
"yourApp", _
"yourKey", , "dbProduction", True, _
"https://script.google.com/a/macros/mcpher.com/s/AKfycbyro1-9LNOnaykvBJ4_6pRZJwNkgf-VFpeQ8drJBqzOK3QZIhU/exec")
.tearDown
End With
End Sub
Private Sub firstTimescriptdbComPrimer()
Dim scriptdbCom As cScriptDbCom
Set scriptdbCom = New cScriptDbCom
With scriptdbCom.init(, _
"prepareStart", _
, _
"xliberationApp", _
"xliberation", _
False, _
"scriptDBPrimer", _
True, _
"https://script.google.com/macros/s/AKfycbzvnq2IZu3JpngnuVxfnPAZYPooVBTULkUyiLFnItfvRxY0NrI/exec")
.tearDown
End With
End Sub
Private Sub firstTimescriptdbComReadonly()
Dim scriptdbCom As cScriptDbCom
Set scriptdbCom = New cScriptDbCom
With scriptdbCom.init(, _
"getStarted", _
, _
"primerApp", _
"xliberation", _
False, _
"scriptDBPrimer", _
False, _
"https://script.google.com/macros/s/AKfycbx7_gPpc38Map4QqHOQrzx_kvIX00nfYGO9OLq8_cMD486Va6M/exec")
.tearDown
End With
End Sub
Private Sub firstTimescriptdbMessages()
Dim scriptdbCom As cScriptDbCom
Set scriptdbCom = New cScriptDbCom
With scriptdbCom.init(, _
"messages", _
, _
"messagesKey", _
"xliberation", _
False, _
"scriptDBMessages", _
False, _
"https://script.google.com/macros/s/AKfycbzvnq2IZu3JpngnuVxfnPAZYPooVBTULkUyiLFnItfvRxY0NrI/exec")
.tearDown
End With
End Sub
Public Sub testdbCount()
Debug.Print getScriptDb("VBAParseCustomers", "dbProduction").count(); " objects in customers class: production DB"
Debug.Print getScriptDb("VBAParseData", "dbProduction").count(); " objects in data class: production DB"
Debug.Print getScriptDb("VBAParseCustomers", "dbTest").count(); " objects in customers class: test DB"
Debug.Print getScriptDb("VBAParseData", "dbTest").count(); " objects in data class: test DB"
End Sub
Private Sub scriptDBandParseCopy()
' copy from scriptDB to Parse
Dim dbParse As cParseCom, dbScriptDb As cScriptDbCom, Class As String
Class = "VBAParseCustomers"
Set dbParse = getParsed(Class)
Set dbScriptDb = getScriptDb(Class, "dbTest")
' copy from scriptdb to parse
dbCopyAny dbScriptDb, dbParse
' see what we have
Debug.Print dbParse.count
Debug.Print dbParse.getObjectsByQuery(JSONParse("{'country':'Turkey'}")).jObject.stringify(True)
' copy back again
dbCopyAny dbParse, dbScriptDb
' see what we have
Debug.Print dbScriptDb.count
Debug.Print dbScriptDb.getObjectsByQuery(JSONParse("{'country':'Turkey'}")).jObject.stringify(True)
' clean up
dbParse.tearDown
dbScriptDb.tearDown
End Sub
Private Sub dbCopyAny(dbSource As Object, dbTarget As Object)
Dim jobSkip As cJobject, job As cJobject
' delete everything in target db of this class
dbTarget.batch.deleteObjects
'we have to do it in chunks because of potential query limits
Set jobSkip = JSONParse("{'skip':0}")
' we'll just use the default limit for a big query
Do
With dbSource.getObjectsByQuery(Nothing, jobSkip).jObject.child("results")
If .children.count = 0 Or Not dbSource.isOk Or Not dbTarget.isOk Then Exit Do
' There are special reserved fields we need to delete between databases
For Each job In .children
dbTarget.createObject _
job.deleteChild("objectId").deleteChild("updatedAt").deleteChild("createdAt").deleteChild("siloId")
Next job
jobSkip.child("skip").value = jobSkip.child("skip").value + .children.count
End With
Loop
' clean up
dbTarget.batch (False)
End Sub
Private Sub dbTestPopulates()
' copy two sheets to scriptdb.com
populateFromSheet "VBAParseData", "dbTest"
populateFromSheet "VBAParseCustomers", "dbTest"
End Sub
Private Sub dbTestCopy()
dbCopy "dbProduction", "dbTest", "VBAParseData"
dbCopy "dbProduction", "dbTest", "VBAParseCustomers"
End Sub
Public Sub dbCopy(source As String, target As String, Class As String)
Dim dbSource As cScriptDbCom, dbTarget As cScriptDbCom, _
jobSkip As cJobject, job As cJobject
' copying class from one database to another
Set dbSource = getScriptDb(Class, source)
Set dbTarget = getScriptDb(Class, target).batch(True)
' delete everything in source db of this class
dbTarget.deleteObjects
'we have to do it in chunks because of potential query limits
Set jobSkip = JSONParse("{'skip':0}")
' we'll just use the default limit for a big query
Do
With dbSource.getObjectsByQuery(Nothing, jobSkip).jObject.child("results")
If .children.count = 0 Or Not dbSource.isOk Or Not dbTarget.isOk Then Exit Do
For Each job In .children
dbTarget.createObject job
Next job
jobSkip.child("skip").value = jobSkip.child("skip").value + .children.count
End With
Loop
' clean up
dbTarget.batch(False).tearDown
dbSource.tearDown
End Sub
Private Sub primerCount()
Debug.Print getScriptDb("VBAParseCustomers", "getStarted").count(JSONParse("{'country':'United States'}"))
End Sub
Private Sub primerQueries()
With getScriptDb("VBAParseCustomers", "getStarted")
Debug.Print .getObjectsByQuery(JSONParse("{'country':'United States'}")).jObject.stringify(True)
End With
End Sub
Private Sub primerQueries2()
With getScriptDb("VBAParseData", "getStarted")
Debug.Print .getObjectsByQuery(JSONParse("{'customerid':1}")).jObject.stringify(True)
End With
End Sub
Private Sub primerUnique()
Debug.Print getScriptDb("VBAParseData", "getStarted").getObjectById("S321104310680").jObject.stringify(True)
End Sub
Private Sub primerShouldFail()
getScriptDb("VBAParseData", "getStarted").deleteObjects
End Sub
Private Sub primerDate()
With getScriptDb("VBAParseData", "getStarted").getObjectById("S321104310680").jObject.child("results.1")
Debug.Print getAnIsoDate(.child("date"))
End With
End Sub
Private Sub populates()
' copy two sheets to scriptdb.com
populateFromSheet "VBAParseData", "prepareStart"
populateFromSheet "VBAParseCustomers", "prepareStart"
End Sub
Private Sub populateFromSheet(sheetName As String, Optional authEntry As String = vbNullString)
Dim scriptdbCom As cScriptDbCom, job As cJobject, dset As cDataSet
' this will clear out an existing scriptdb class, and create a new one from a worksheet
' we'll use batch mode throughout
Set scriptdbCom = getScriptDb(sheetName, authEntry).batch
' clear out existing any existing data
scriptdbCom.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
Debug.Assert scriptdbCom.createObject(job).isOk
Next job
.tearDown
End With
' commit any outstanding and clean up
With scriptdbCom.flush.batch(False)
Debug.Assert .isOk
' show how many are there now
Debug.Print .count & " in class" & sheetName
.tearDown
End With
End Sub
Private Function getAnIsoDate(job As cJobject) As Date
getAnIsoDate = 0
If Not job Is Nothing Then
If Not job.childExists("__type") Is Nothing Then
If job.toString("__type") = "Date" Then
getAnIsoDate = fromISODateTime(job.child("iso").value)
End If
End If
End If
End Function
Private Sub testGetItemByUniqueId()
Dim d As Date, job As cJobject, jor As cJobject
' get an item by unique object ID
With getScriptDb("VBAParseData", "readonly")
Debug.Print .getObjectsByQuery().jObject.stringify
.getObjectById ("S320996777097")
' test if it worked, and do something with the results
If .isOk Then
Debug.Print .jObject.stringify(True)
' how to do something with parse.com like dates & times
' look through each row in the results
For Each jor In .jObject.child("results").children
' look through each field in each row
For Each job In jor.children
d = getAnIsoDate(job)
If d <> 0 Then Debug.Print "date detected", d, "from", job.stringify
Next job
' how to get a specifc date/time
Debug.Print "date converted", getAnIsoDate(jor.child("date"))
Next jor
Else
Debug.Print "failed to get object:" & .browser.url & ":" & .browser.status & ":" & .browser.Text
End If
.tearDown
End With
End Sub
Private Sub testdbtest()
Dim d As Date, job As cJobject, jor As cJobject
' get an item by unique object ID
With getScriptDb("VBAParseData", "dbtest")
''Debug.Print .updateObjectById("S342112900210", JSONParse("{'value':9999}")).flush.jObject.stringify
Debug.Print .getObjectById("S342112900210").jObject.stringify
'Debug.Print .updateObjects(JSONParse("{'customerid':22}"), JSONParse("{'value':9999}")).jObject.stringify
' test if it worked, and do something with the results
If .isOk Then
''Debug.Print .jObject.stringify
''Debug.Print .updateObjects(JSONParse("{'customerid':22}"), JSONParse("{'value':9999}")).jObject.stringify
''Debug.Print .getObjectsByQuery(JSONParse("{'customerid':22}")).jObject.stringify(True)
Else
Debug.Print "failed to get object:" & .browser.url & ":" & .browser.status & ":" & .browser.Text
End If
'Debug.Print .getObjectsByQuery().jObject.stringify
.tearDown
End With
End Sub
Private Sub testscriptdbUpdate()
' get some items by query and change the scheme name to something else
With getScriptDb("somesilo").batch
With .updateObjects(JSONParse("{'customerid':1}"), JSONParse("{'name':'john'}"))
' 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
Debug.Print .getObjectsByQuery().jObject.stringify
.tearDown
End With
End Sub
Private Sub testbigquery()
Dim jobStore As cJobject, jobSkip As cJobject, sdb As cScriptDbCom, job As cJobject
Set jobSkip = JSONParse("{'skip':0}")
Set jobStore = New cJobject
Set jobStore = jobStore.init(Nothing).add("results").addArray
Set sdb = getScriptDb("VBAParseData")
' we'll just use the default limit for a big query, and make a list of objectIds
Do
With sdb.getObjectsByQuery(Nothing, jobSkip).jObject.child("results")
If .children.count = 0 Or Not sdb.isOk Then Exit Do
jobSkip.child("skip").value = jobSkip.child("skip").value + .children.count
For Each job In .children
jobStore.add , job.toString("objectId")
Next job
End With
Loop
Debug.Print jobStore.stringify
sdb.tearDown
End Sub
Private Sub testscriptdbDelete()
' get some items by query and change the scheme name to something else
With getScriptDb("VBAParseData").batch
With .deleteObjects()
' 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 delete:" & .browser.url & ":" & .browser.status & ":" & .browser.Text
End If
End With
.flush.tearDown
End With
End Sub
Private Sub testscriptdbquery()
' get a number of items that match a query by example
With getScriptDb("VBAParseData")
With .getObjectsByQuery(JSONParse("{'customerid':1}"), JSONParse("{'limit':10}"))
'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 testscriptdbCount()
' get a number of items that match a query by example
With getScriptDb("VBAParseData")
Debug.Print .count()
If Not .isOk Then
Debug.Print "fail count", .browser.status, .browser.Text
End If
.tearDown
End With
End Sub
Private Sub testscriptdbCreate()
' create a new object with the given contents
With getScriptDb("somesilo").createObject(JSONParse("{'customerid':1}"))
If Not .isOk Then
Debug.Print "fail creation", .browser.status, .browser.Text
Else
Debug.Print .jObject.serialize(True)
End If
.tearDown
End With
End Sub
Private Sub scriptdbMatch()
Dim pCustomer As New cScriptDbCom, pData As cScriptDbCom, 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 = getScriptDb("VBAParseCustomers")
Set pData = getScriptDb("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 getScriptDb(scriptDbClass As String, Optional entry As String = "scriptDb") As cScriptDbCom
Dim p As cScriptDbCom
Set p = New cScriptDbCom
Set getScriptDb = p.init(scriptDbClass, entry)
End Function
Private Sub feedbackTest()
' create a conversation conection
With getdeaddrop("webpagexyz", "messages", , "webpagexyz336262847563596")
' now we have a scriptDb we can use to read/write stuff to this unique conversation
With .scriptDb
Debug.Print .scriptDbClass, .getObjectsByQuery().jObject.stringify(True)
End With
.tearDown
End With
End Sub
Public Sub testDeleteConversation()
testConversation "webpagexyz"
deleteConversation "webpagexyz"
testConversation "webpagexyz"
deleteConversation "webpagexyz", "webpagexyz336312618855121"
testConversation "webpagexyz", "webpagexyz336312618855121"
End Sub
Public Sub deleteConversation(yourClass As String, Optional specific As String = vbNullString)
Dim c As cDeadDrop
' create a conversation conection
With getdeaddrop(yourClass, "messages", , specific)
' now we have a scriptDb we can use to read/write stuff to this unique conversation
With .scriptDb
' delete any existing objects in this conversation
.batch.deleteObjects.flush
End With
.tearDown
End With
End Sub
Public Sub makeConversation()
Dim c As cDeadDrop
'
' create a conversation conection
With getdeaddrop("webpagexyz", "messages")
' now we have a scriptDb we can use to read/write stuff to this unique conversation
With .scriptDb
' delete any existing objects in this conversation
.deleteObjects
' write some data to be accessed by some other application
.batch
.createObject JSONParse("{'id':1,'content':'content 1'}")
.createObject JSONParse("{'id':2,'content':'content 2'}")
.flush
End With
' see if it worked for the latest and a specific key
testConversation .scriptDbClass
testConversation .scriptDbClass, "webpagexyz336262847563596"
.tearDown
End With
End Sub
Public Sub testConversation(yourClass As String, Optional specific As String = vbNullString)
Dim c As cDeadDrop
' create a conversation conection
With getdeaddrop("webpagexyz", "messages", , specific)
' now we have a scriptDb we can use to read/write stuff to this unique conversation
With .scriptDb
Debug.Print .scriptDbClass, .getObjectsByQuery().jObject.stringify
End With
.tearDown
End With
End Sub
Public Function getdeaddrop(yourClass As String, _
Optional yourScriptDbEntry As String = vbNullString, _
Optional initial As Boolean = False, _
Optional specificKey As String = vbNullString) As cDeadDrop
Dim c As cDeadDrop
Set c = New cDeadDrop
Set getdeaddrop = c.init(yourClass, yourScriptDbEntry, initial, specificKey)
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment