Commit f37d1a62 authored by Dave Griffiths's avatar Dave Griffiths

testing tweaks

parent d233c023
......@@ -123,7 +123,7 @@
(define (entity-create! db table entity-type ktv-list)
(msg "creating:" entity-type ktv-list)
;;(msg "creating:" entity-type ktv-list)
(let ((values
(append
(list
......@@ -144,7 +144,7 @@
(let ((db (get-current 'db #f))
(table (get-current 'table #f)))
;; standard bits
(let ((values (dbg (get-current 'entity-values '())))
(let ((values (get-current 'entity-values '()))
(unique-id (ktv-get (get-current 'entity-values '()) "unique_id")))
(cond
((and unique-id (not (null? values)))
......@@ -200,13 +200,10 @@
;; todo fix all hardcoded paths here
(define (send-files ktvlist)
(msg "send-files" ktvlist)
(foldl
(lambda (ktv r)
(msg (ktv-type ktv))
(if (equal? (ktv-type ktv) "file")
(begin
(msg "sending" (ktv-value ktv))
(cons (http-upload
(string-append "upload-" (ktv-value ktv))
"http://192.168.2.1:8889/symbai?fn=upload"
......@@ -217,7 +214,6 @@
;; spit all dirty entities to server
(define (spit db table entities)
(msg "running spit")
(foldl
(lambda (e r)
;;(msg (car (car e)))
......@@ -257,12 +253,10 @@
;; todo fix all hardcoded paths here
(define (request-files ktvlist)
(msg "request-files")
(foldl
(lambda (ktv r)
(if (equal? (ktv-type ktv) "file")
(begin
(msg "requesting" (ktv-value ktv))
(cons (http-download
(string-append "download-" (ktv-value ktv))
(string-append "http://192.168.2.1:8889/files/" (ktv-value ktv))
......@@ -284,8 +278,6 @@
(ktvlist (list-ref data 1))
(unique-id (list-ref entity 1))
(exists (entity-exists? db table unique-id)))
(msg "from server...:")
(msg ktvlist)
;; need to check exists again here, due to delays back and forth
(if (not exists)
(insert-entity-wholesale
......@@ -327,17 +319,15 @@
;; repeatedly read version and request updates
(define (suck-new db table)
(msg "suck-new")
(debug! "Requesting new entities")
(list
(http-request
"new-entities-req"
(string-append url "fn=entity-versions&table=" table)
(lambda (data)
(msg "entity-versions:" data)
(let ((new-entity-requests (build-entity-requests db table data)))
(cond
((null? new-entities)
((null? new-entity-requests)
(debug! "No new data to download")
(set-current! 'download 1)
(append
......@@ -348,10 +338,10 @@
(else
(debug! (string-append
"Requesting "
(number->string (length new-entities)) " entities"))
(number->string (length new-entity-requests)) " entities"))
(cons
(play-sound "active")
new-entities))))))))
new-entity-requests))))))))
(msg "build-dirty defined...")
......@@ -363,7 +353,6 @@
"Stream data: " (number->string (car stream)) "/" (number->string (cadr stream)))))
(define (upload-dirty db)
(msg "upload-dirty")
(let ((r (append
(spit db "sync" (dirty-entities db "sync"))
(spit db "stream" (dirty-entities db "stream")))))
......@@ -760,18 +749,6 @@
(else (_ (cdr l) (+ i 1)))))
(_ arr 0))
(define vowel (map symbol->string (list 'a 'e 'i 'o 'u)))
(define consonant (map symbol->string (list 'b 'c 'd 'f 'g 'h 'j 'k 'l 'm 'n 'p 'q 'r 's 't 'v 'w 'x 'y 'z)))
(define (word-gen)
(define (_ s vowel-prob)
(cond
((zero? s) '())
((< (random) vowel-prob)
(cons (choose vowel) (_ (- s 1) (/ vowel-prob 2))))
(else
(cons (choose consonant) (_ (- s 1) (* vowel-prob 2))))))
(apply string-append (_ (+ 3 (random-int 8)) 0.5)))
......@@ -780,22 +757,22 @@
(ktvlist-merge
default-ktvlist
(list
(ktv "name" "varchar" (string-append "Village-" (number->string (random-int 1000))))
(ktv "name" "varchar" (string-append "Village-" (number->string (random 1000))))
(ktv "block" "varchar" (word-gen))
(ktv "district" "varchar" (word-gen))
(ktv "car" "int" (random-int 2))))))
(ktv "car" "int" (random 2))))))
(define (simpsons-household db table parent default-ktvlist)
(entity-create! db table "household"
(ktvlist-merge
default-ktvlist
(list
(ktv "name" "varchar" (string-append "Household-" (number->string (random-int 1000))))
(ktv "num-pots" "int" (random-int 10))
(ktv "name" "varchar" (string-append "Household-" (number->string (random 1000))))
(ktv "num-pots" "int" (random 10))
(ktv "parent" "varchar" parent)))))
(define (simpsons-individual db table parent default-ktvlist)
(let ((n (random-int 1000)))
(let ((n (random 1000)))
(entity-create! db table "individual"
(ktvlist-merge
default-ktvlist
......@@ -947,7 +924,42 @@
(msg "making household" i)
(let ((household (simpsons-household db table village household-ktvlist)))
(looper!
(random-int 10)
(random 10)
(lambda (i)
(msg "making individual" i)
(simpsons-individual db table household individual-ktvlist))))))))))
(define (mangle-test! db table entities)
(define (_ n)
(when (not (zero? n))
(let ((type (choose entities)))
(msg type)
(let ((entities (all-entities db table type)))
(msg "entities:" entities)
(when (not (null? entities))
(let ((id (choose entities)))
(msg "entity id:" id)
(let ((ktv-list (get-entity db table id)))
(when (not (null? ktv-list))
(entity-init! db table type ktv-list)
(for-each
(lambda (ktv)
(when (and
(not (equal? (ktv-key ktv) "deleted"))
(not (equal? (ktv-key ktv) "unique_id"))
(not (equal? (ktv-key ktv) "parent"))
(eqv? (random 10) 0))
(if (equal? (ktv-type ktv) "varchar")
(entity-set-value! (ktv-key ktv) (ktv-type ktv)
(string-append
(get-current 'user-id "noid")
(random-value-for-type (ktv-type ktv))))
(entity-set-value! (ktv-key ktv) (ktv-type ktv)
(random-value-for-type (ktv-type ktv))))))
ktv-list)
(msg "modifying" type id)
(entity-update-values!))
)))))
(_ (- n 1))))
(_ (random 10)))
......@@ -181,7 +181,7 @@
(insert elt fn (cdr sorted-lst))))))
(define (choose l)
(list-ref l (abs (random (- (length l) 1)))))
(list-ref l (random (length l))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; time
......@@ -266,13 +266,13 @@
(display "random: unrecognized message")
(newline))))))))
(define random
(define rand
(random-maker 19781116)) ;; another arbitrarily chosen birthday
(define (random-int n)
(abs (random n)))
(define (random n)
(abs (modulo (rand n) n)))
(define rndf random)
(define rndf rand)
(define (rndvec) (vector (rndf) (rndf) (rndf)))
......
......@@ -9,7 +9,7 @@
(define (make-semaphore n) #f)
(define (semaphore-wait n) #f)
(define (semaphore-post n) #f)
;; tinyscheme
(define db-select db-exec)
......@@ -23,6 +23,6 @@
;; get a unique hash for this user (used for all the unique-ids)
(define (get-unique user)
(let ((t (time)))
(let ((t (time-of-day)))
(string-append
user "-" (number->string (car t)) ":" (number->string (cadr t)))))
......@@ -19,6 +19,7 @@
;; colours
(msg "starting up....")
(define entity-types (list "village" "household" "individual"))
(define trans-col (list 0 0 0 0))
(define colour-one (list 0 0 255 100))
......@@ -59,8 +60,6 @@
(set-current! 'user-id (get-setting-value "user-id"))
(set! i18n-lang (get-setting-value "language"))
(define entity-types (list "village" "household" "individual"))
;;(display (db-all db "local" "app-settings"))(newline)
(define tribes-list '(khasi other))
......@@ -167,6 +166,10 @@
(append
(cond
((get-current 'sync-on #f)
(when (zero? (random 10))
(msg "mangling...")
(mangle-test! db "sync" entity-types))
(msg "one")
(set-current! 'upload 0)
(set-current! 'download 0)
(connect-to-net
......@@ -178,10 +181,9 @@
(if (have-dirty? db "sync") '() (suck-new db "sync"))))))
(else '()))
(list
(delayed "debug-timer" (+ 30000 (random 5000)) debug-timer-cb)
(delayed "debug-timer" (+ 10000 (random 5000)) debug-timer-cb)
(update-debug))))
(define pf-length 20) ;; minutes...
(define (timer-cb)
......@@ -191,6 +193,7 @@
(append
(cond
((< (get-current 'timer-seconds 59) 0)
(set-current! 'timer-minutes (- (get-current 'timer-minutes pf-length) 1))
(set-current! 'timer-seconds 59)
(cond ((< (get-current 'timer-minutes pf-length) 1)
......@@ -296,8 +299,6 @@
(let ((village (get-entity-name db "sync" (get-current 'village #f)))
(household (get-entity-name db "sync" (get-current 'household #f)))
(individual (get-entity-name db "sync" (get-current 'individual #f))))
(msg (get-current 'village "no village"))
(msg "top bar update--->" village household individual)
(list
(update-widget 'text-view (get-id "title") 'text
(get-current 'activity-title "Title not set"))
......@@ -494,7 +495,7 @@
(text-view 0 (mtext-lookup 'social-strength)
30 (layout 'wrap-content 'wrap-content 1 'centre 10))
(spinner
(make-id (dbg (string-append id-text "-strength-spinner")))
(make-id (string-append id-text "-strength-spinner"))
(map mtext-lookup social-strength-list)
(layout 'wrap-content 'wrap-content 1 'centre 0)
(lambda (v)
......@@ -506,7 +507,6 @@
(entity-set-value! key "varchar" (get-current 'choose-result "not set"))))
(define (update-social-connection db table id key type request-code)
(msg "update-social-connection")
(let ((id-text (string-append (symbol->string id))))
(append
(update-person-selector db table id key)
......@@ -520,7 +520,7 @@
social-residence-list)
(list
(mupdate-spinner
(string->symbol (dbg (string-append id-text "-strength")))
(string->symbol (string-append id-text "-strength"))
(string-append key "-strength")
social-strength-list))
)))
......@@ -637,7 +637,7 @@
(number->string (car loc)) ", "
(number->string (cadr loc)))))))
(update-list-widget
db "sync" "household" "household" (dbg (get-setting-value "current-village"))))))
db "sync" "household" "household" (get-setting-value "current-village")))))
(lambda (activity) '())
(lambda (activity) '())
(lambda (activity) '())
......@@ -647,7 +647,6 @@
((eqv? requestcode choose-code)
(list (start-activity "individual" 0 (get-current 'choose-result 0))))
((eqv? requestcode photo-code)
(msg "camera returned" resultcode)
(list (update-widget
'image-view (get-id "image")
'external-image (string-append dirname "photo.jpg"))))
......@@ -932,7 +931,6 @@
(lambda (activity) '())
(lambda (activity) '())
(lambda (activity requestcode resultcode)
(msg "back from camera")
(cond
((eqv? requestcode photo-code)
;; todo: means we save when the camera happens
......@@ -1327,7 +1325,7 @@
individual-ktvlist
(list
(ktv "name" "varchar" (get-current 'chooser-quick-name (mtext-lookup 'no-name)))
(ktv "parent" "varchar" (dbg (get-current 'household #f)))))))
(ktv "parent" "varchar" (get-current 'household #f))))))
(list (finish-activity 0)))
(else
(list)))))))))
......
......@@ -50,6 +50,11 @@
;;(msg "cleaning values")
(clean-entity-values db table (entity-id-from-unique db table unique-id)) )
(define (have-dirty? db table)
(not (zero?
(select-first
db (string-append "select count(entity_id) from " table "_entity where dirty=1")))))
(define (get-dirty-stats db table)
(list
(select-first
......@@ -70,7 +75,7 @@
;; build according to url ([table] entity-type unique-id dirty version)
(cdr (vector->list i))
;; data entries (todo - only dirty values!)
(dbg (get-entity-plain-for-sync db table (vector-ref i 0)))))
(get-entity-plain-for-sync db table (vector-ref i 0))))
(cdr de)))))
;; todo: BROKEN...
......
......@@ -37,6 +37,27 @@
((equal? type "real") 0)
((equal? type "file") "not set")))
;; regression testing
(define vowel (map symbol->string (list 'a 'e 'i 'o 'u)))
(define consonant (map symbol->string (list 'b 'c 'd 'f 'g 'h 'j 'k 'l 'm 'n 'p 'q 'r 's 't 'v 'w 'x 'y 'z)))
(define (word-gen)
(define (_ s vowel-prob)
(cond
((zero? s) '())
((< (rndf) vowel-prob)
(cons (choose vowel) (_ (- s 1) (/ vowel-prob 2))))
(else
(cons (choose consonant) (_ (- s 1) (* vowel-prob 2))))))
(apply string-append (_ (+ 3 (random 8)) 0.5)))
(define (random-value-for-type type)
(cond
((equal? type "varchar") (word-gen))
((equal? type "int") (random 100))
((equal? type "real") (rndf))
((equal? type "file") (word-gen))))
;; stringify based on type (for url)
(define (stringify-value ktv)
(cond
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment