dbsync.scm 38.1 KB
Newer Older
Dave Griffiths's avatar
Dave Griffiths committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
;; Starwisp Copyright (C) 2013 Dave Griffiths
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;; abstractions for synced databased

18
(msg "dbsync.scm")
Dave Griffiths's avatar
Dave Griffiths committed
19

20 21
(define unset-int 2147483647)

Dave Griffiths's avatar
Dave Griffiths committed
22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; stuff in memory

(define (store-set store key value)
  (cond
   ((null? store) (list (list key value)))
   ((eq? key (car (car store)))
    (cons (list key value) (cdr store)))
   (else
    (cons (car store) (store-set (cdr store) key value)))))

(define (store-get store key default)
  (cond
   ((null? store) default)
   ((eq? key (car (car store)))
    (cadr (car store)))
   (else
    (store-get (cdr store) key default))))

(define (store-exists? store key)
  (cond
   ((null? store) #f)
   ((eq? key (car (car store)))
    #t)
   (else
    (store-exists? (cdr store) key))))

(define store '())

(define (set-current! key value)
  (set! store (store-set store key value)))

(define (get-current key default)
  (store-get store key default))

(define (current-exists? key)
  (store-exists? store key))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; db abstraction

63
(define (entity-init! db table entity-type ktv-list)
Dave Griffiths's avatar
Dave Griffiths committed
64
  (entity-reset!)
65 66 67 68 69
  (entity-set! ktv-list)
  (set-current! 'db db)
  (set-current! 'table table)
  (set-current! 'entity-type entity-type))

Dave Griffiths's avatar
Dave Griffiths committed
70

Dave Griffiths's avatar
Dave Griffiths committed
71
;; store a ktv, replaces existing with same key
72 73 74 75 76 77
;;(define (entity-add-value! key type value)
;;  (set-current!
;;   'entity-values
;;   (ktv-set
;;    (get-current 'entity-values '())
;;    (ktv key type value))))
Dave Griffiths's avatar
Dave Griffiths committed
78

79
(define (entity-add-value-create! key type value)
80
  (msg "entity-add-value-create!" key type value)
81 82 83 84
  (set-current!
   'entity-values
   (ktv-set
    (get-current 'entity-values '())
Dave Griffiths's avatar
Dave Griffiths committed
85
    (ktv key type value))))
86

Dave Griffiths's avatar
Dave Griffiths committed
87 88 89
(define (entity-set! ktv-list)
  (set-current! 'entity-values ktv-list))

90 91 92
(define (entity-get-value key)
  (ktv-get (get-current 'entity-values '()) key))

Dave Griffiths's avatar
Dave Griffiths committed
93 94 95 96 97 98 99 100 101 102 103
(define (check-type type value)
  (cond
   ((equal? type "varchar")
    (string? value))
   ((equal? type "file")
    (string? value))
   ((equal? type "int")
    (number? value))
   ((equal? type "real")
    (number? value))))

104 105
;; version to check the entity has the key
(define (entity-set-value! key type value)
Dave Griffiths's avatar
Dave Griffiths committed
106 107 108
  (when (not (check-type type value))
        (msg "INCORRECT TYPE FOR" key ":" type ":" value))

109
  (let ((existing-type (ktv-get-type (get-current 'entity-values '()) key)))
110 111 112 113 114 115 116 117 118 119 120 121 122 123 124
    (cond
     ((equal? existing-type type)
      ;; save straight to local db every time (checks for modification)
      (entity-update-single-value! (list key type value))
      ;; then save to memory
      (set-current!
       'entity-values
       (ktv-set
        (get-current 'entity-values '())
        (ktv key type value))))
      ;;
     (else
      (msg "entity-set-value! - adding new " key "of type" type "to entity")
      (entity-add-value-create! key type value))
     )))
125

Dave Griffiths's avatar
Dave Griffiths committed
126 127 128 129 130 131 132 133 134 135 136 137 138
;; version to check the entity has the key
(define (entity-set-value-mem! key type value)
  (when (not (check-type type value))
        (msg "INCORRECT TYPE FOR" key ":" type ":" value))

  ;; then save to memory
  (set-current!
   'entity-values
   (ktv-set
    (get-current 'entity-values '())
    (ktv key type value))))


139

Dave Griffiths's avatar
Dave Griffiths committed
140 141 142
(define (date-time->string dt)
  (string-append
   (number->string (list-ref dt 0)) "-"
143 144 145 146 147
   (substring (number->string (+ (list-ref dt 1) 100)) 1 3) "-"
   (substring (number->string (+ (list-ref dt 2) 100)) 1 3) " "
   (substring (number->string (+ (list-ref dt 3) 100)) 1 3) ":"
   (substring (number->string (+ (list-ref dt 4) 100)) 1 3) ":"
   (substring (number->string (+ (list-ref dt 5) 100)) 1 3)))
Dave Griffiths's avatar
Dave Griffiths committed
148 149

;; build entity from all ktvs, insert to db, return unique_id
150 151 152 153 154
(define (entity-record-values!)
  (let ((db (get-current 'db #f))
        (table (get-current 'table #f))
        (type (get-current 'entity-type #f)))
    ;; standard bits
155 156 157 158 159
    (let ((r (entity-create! db table type (get-current 'entity-values '()))))
      (entity-reset!) r)))


(define (entity-create! db table entity-type ktv-list)
Dave Griffiths's avatar
Dave Griffiths committed
160
  ;;(msg "creating:" entity-type ktv-list)
161 162 163
  (let ((values
         (append
          (list
Dave Griffiths's avatar
Dave Griffiths committed
164 165 166 167 168
           (ktv "user" "varchar" (get-current 'user-id "none"))
           (ktv "time" "varchar" (date-time->string (date-time)))
           (ktv "lat" "real" (car (get-current 'location '(0 0))))
           (ktv "lon" "real" (cadr (get-current 'location '(0 0))))
           (ktv "deleted" "int" 0))
169 170 171 172 173 174 175
          ktv-list)))
    (let ((r (insert-entity/get-unique
              db table entity-type (get-current 'user-id "no id")
              values)))
      (msg "entity-create: " entity-type)
      r)))

176 177 178 179 180

(define (entity-update-values!)
  (let ((db (get-current 'db #f))
        (table (get-current 'table #f)))
    ;; standard bits
Dave Griffiths's avatar
Dave Griffiths committed
181
    (let ((values (get-current 'entity-values '()))
182 183 184 185
          (unique-id (ktv-get (get-current 'entity-values '()) "unique_id")))
      (cond
       ((and unique-id (not (null? values)))
        (update-entity db table (entity-id-from-unique db table unique-id) values)
186 187 188
        ;; removed due to save button no longer exiting activity - need to keep!
        ;;(entity-reset!)
        )
189 190
       (else
        (msg "no values or no id to update as entity:" unique-id "values:" values))))))
Dave Griffiths's avatar
Dave Griffiths committed
191

192 193 194 195 196
(define (entity-update-single-value! ktv)
  (let ((db (get-current 'db #f))
        (table (get-current 'table #f))
        (unique-id (ktv-get (get-current 'entity-values '()) "unique_id")))
    (cond
197 198
     ((ktv-eq? (ktv-get-whole (get-current 'entity-values '()) (ktv-key ktv)) ktv)
      (msg "eusv: no change for" (ktv-key ktv)))
199 200 201 202 203 204
     (unique-id
      (update-entity db table (entity-id-from-unique db table unique-id) (list ktv)))
     (else
      (msg "no values or no id to update as entity:" unique-id "values:" values)))))


Dave Griffiths's avatar
Dave Griffiths committed
205
(define (entity-reset!)
206 207 208 209
  (set-current! 'entity-values '())
  (set-current! 'db "reset")
  (set-current! 'table "reset")
  (set-current! 'entity-type "reset"))
Dave Griffiths's avatar
Dave Griffiths committed
210 211 212 213 214 215 216 217 218 219 220 221

(define (assemble-array entities)
  (foldl
   (lambda (i r)
     (if (equal? r "") (ktv-get i "unique_id")
         (string-append r "," (ktv-get i "unique_id"))))
   ""
   entities))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; syncing code

Dave Griffiths's avatar
docs  
Dave Griffiths committed
222 223 224
;; todo - separate logic from gui and stick this in common code
;; then we can unit test this stuff...

Dave Griffiths's avatar
Dave Griffiths committed
225
(define url "http://192.168.2.1:8889/symbai?")
Dave Griffiths's avatar
Dave Griffiths committed
226 227

(define (build-url-from-ktv ktv)
Dave Griffiths's avatar
Dave Griffiths committed
228
  (string-append "&" (ktv-key ktv) ":" (ktv-type ktv) "=" (stringify-value-url ktv)))
Dave Griffiths's avatar
Dave Griffiths committed
229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246

(define (build-url-from-ktvlist ktvlist)
  (foldl
   (lambda (ktv r)
     (string-append r (build-url-from-ktv ktv)))
   "" ktvlist))

(define (build-url-from-entity table e)
  (string-append
   url
   "fn=sync"
   "&table=" table
   "&entity-type=" (list-ref (car e) 0)
   "&unique-id=" (list-ref (car e) 1)
   "&dirty=" (number->string (list-ref (car e) 2))
   "&version=" (number->string (list-ref (car e) 3))
   (build-url-from-ktvlist (cadr e))))

Dave Griffiths's avatar
docs  
Dave Griffiths committed
247

Dave Griffiths's avatar
Dave Griffiths committed
248 249 250 251 252
;; todo fix all hardcoded paths here
(define (send-files ktvlist)
  (foldl
   (lambda (ktv r)
     (if (equal? (ktv-type ktv) "file")
Dave Griffiths's avatar
Dave Griffiths committed
253 254 255 256 257 258
         (begin
           (cons (http-upload
                  (string-append "upload-" (ktv-value ktv))
                  "http://192.168.2.1:8889/symbai?fn=upload"
                  (string-append "/sdcard/symbai/files/" (ktv-value ktv)))
                 r))
Dave Griffiths's avatar
Dave Griffiths committed
259 260 261
         r))
   '() ktvlist))

Dave Griffiths's avatar
Dave Griffiths committed
262 263 264
;; redundant second pass to syncronise files - independant of the
;; rest of the syncing system
(define (sync-files server-list)
Dave Griffiths's avatar
Dave Griffiths committed
265
  (let ((local-list (dir-list "/sdcard/symbai/files/")))
Dave Griffiths's avatar
Dave Griffiths committed
266
    ;; search for all local files in server list
Dave Griffiths's avatar
Dave Griffiths committed
267 268
    (crop
     (append
Dave Griffiths's avatar
Dave Griffiths committed
269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294
      (foldl
       (lambda (file r)
         ;; send files not present
         (if (or
              (eqv? (string-ref file 0) #\.)
              (in-list? file server-list))
             r (cons
                (http-upload
                 (string-append "upload-" file)
                 "http://192.168.2.1:8889/symbai?fn=upload"
                 (string-append "/sdcard/symbai/files/" file)) r)))
       '()
       local-list)
      ;; search for all server files in local list
      (foldl
       (lambda (file r)
         ;; request files not present
         (if (in-list? file local-list)
             r (cons
                (http-download
                 (string-append "download-" file)
                 (string-append "http://192.168.2.1:8889/files/" file)
                 (string-append "/sdcard/symbai/files/" file)) r)))
       '()
       server-list))
     ;; restrict the number of uploads each time round
Dave Griffiths's avatar
Dave Griffiths committed
295
     2)))
Dave Griffiths's avatar
Dave Griffiths committed
296 297

(define (start-sync-files)
Dave Griffiths's avatar
Dave Griffiths committed
298 299 300 301 302
  (list
   (http-request
    (string-append "file-list")
    (string-append url "fn=file-list")
    (lambda (file-list)
Dave Griffiths's avatar
Dave Griffiths committed
303 304 305 306 307 308
      (let ((r (sync-files file-list)))
        (when (not (null? r))
              (set-current! 'upload 0)
              (debug! "Found a mismatch with files on raspberry pi - fixing..."))
        r)))))

Dave Griffiths's avatar
Dave Griffiths committed
309

Dave Griffiths's avatar
Dave Griffiths committed
310 311 312 313
;; spit all dirty entities to server
(define (spit db table entities)
  (foldl
   (lambda (e r)
314
     ;;(msg (car (car e)))
Dave Griffiths's avatar
Dave Griffiths committed
315 316 317 318 319 320 321
     (debug! (string-append "Sending a " (car (car e)) " to Raspberry Pi"))
     (append
      (list
       (http-request
        (string-append "req-" (list-ref (car e) 1))
        (build-url-from-entity table e)
        (lambda (v)
Dave Griffiths's avatar
Dave Griffiths committed
322
          (msg "in spit..." v)
Dave Griffiths's avatar
Dave Griffiths committed
323 324 325
          (cond
           ((or (equal? (car v) "inserted") (equal? (car v) "match"))
            (update-entity-clean db table (cadr v))
Dave Griffiths's avatar
Dave Griffiths committed
326
            (debug! (string-append "Uploaded " (car (car e)))))
Dave Griffiths's avatar
Dave Griffiths committed
327 328 329 330
           ((equal? (car v) "no change")
            (debug! (string-append "No change for " (car (car e)))))
           ((equal? (car v) "updated")
            (update-entity-clean db table (cadr v))
Dave Griffiths's avatar
Dave Griffiths committed
331
            (debug! (string-append "Updated changed " (car (car e)))))
Dave Griffiths's avatar
Dave Griffiths committed
332 333 334 335
           (else
            (debug! (string-append
                     "Problem uploading "
                     (car (car e)) " : " (car v)))))
Dave Griffiths's avatar
Dave Griffiths committed
336 337 338 339 340 341 342 343 344
          (append
           ;; check for file uploads
           (if (or (equal? (car v) "updated")
                   (equal? (car v) "inserted")
                   (equal? (car v) "match"))
               (send-files (cadr e)) ;; takes a ktvlist
               '())
           (list
            (update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty db)))))))
Dave Griffiths's avatar
Dave Griffiths committed
345 346 347 348
      r))
   '()
   entities))

Dave Griffiths's avatar
Dave Griffiths committed
349 350 351 352 353
;; todo fix all hardcoded paths here
(define (request-files ktvlist)
  (foldl
   (lambda (ktv r)
     (if (equal? (ktv-type ktv) "file")
Dave Griffiths's avatar
Dave Griffiths committed
354 355 356 357 358 359
         (begin
           (cons (http-download
                  (string-append "download-" (ktv-value ktv))
                  (string-append "http://192.168.2.1:8889/files/" (ktv-value ktv))
                  (string-append "/sdcard/symbai/files/" (ktv-value ktv)))
                 r))
Dave Griffiths's avatar
Dave Griffiths committed
360 361 362
         r))
   '() ktvlist))

363 364
(msg "suck ent")

Dave Griffiths's avatar
Dave Griffiths committed
365
(define (suck-entity-from-server db table unique-id)
Dave Griffiths's avatar
Dave Griffiths committed
366 367 368 369 370 371
  ;; ask for the current version
  (http-request
   (string-append unique-id "-update-new")
   (string-append url "fn=entity&table=" table "&unique-id=" unique-id)
   (lambda (data)
     ;; check "sync-insert" in sync.ss raspberry pi-side for the contents of 'entity'
Dave Griffiths's avatar
Dave Griffiths committed
372 373 374 375 376
     (let* ((entity (list-ref data 0))
            (ktvlist (list-ref data 1))
            (unique-id (list-ref entity 1))
            (exists (entity-exists? db table unique-id)))
       ;; need to check exists again here, due to delays back and forth
Dave Griffiths's avatar
Dave Griffiths committed
377 378 379 380
       (if (not exists)
           (insert-entity-wholesale
            db table
            (list-ref entity 0) ;; entity-type
Dave Griffiths's avatar
Dave Griffiths committed
381
            unique-id
Dave Griffiths's avatar
Dave Griffiths committed
382 383 384 385 386 387 388
            0 ;; dirty
            (list-ref entity 2) ;; version
            ktvlist)
           (update-to-version
            db table (get-entity-id db table unique-id)
            (list-ref entity 2) ktvlist))
       (debug! (string-append (if exists "Got new: " "Updated: ") (ktv-get ktvlist "name")))
Dave Griffiths's avatar
Dave Griffiths committed
389 390 391 392
       (cons
        (update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty db))
        (request-files ktvlist))))))

Dave Griffiths's avatar
docs  
Dave Griffiths committed
393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413
(define (build-entity-requests db table version-data)
  (foldl
   (lambda (i r)
     (let* ((unique-id (car i))
            (version (cadr i))
            (exists (entity-exists? db table unique-id))
            (old
             (if exists
                 (> version (get-entity-version
                             db table
                             (get-entity-id db table unique-id)))
                 #f)))

       ;; if we don't have this entity or the version on the server is newer
       (if (and (or (not exists) old)
                ;; limit this to 5 a time
                (< (length r) 5))
           (cons (suck-entity-from-server db table unique-id) r)
           r)))
   '()
   version-data))
Dave Griffiths's avatar
Dave Griffiths committed
414

Dave Griffiths's avatar
Dave Griffiths committed
415
(define (mark-unlisted-entities-dirty! db table version-data)
Dave Griffiths's avatar
Dave Griffiths committed
416
  (msg "mark-unlisted...")
Dave Griffiths's avatar
Dave Griffiths committed
417 418 419 420 421 422
  ;; load all local entities
  (let ((ids (all-unique-ids db table))
        (server-ids (map car version-data)))
    ;; look for each one in data
    (for-each
     (lambda (id)
Dave Griffiths's avatar
Dave Griffiths committed
423
       (when (not (in-list? id server-ids))
Dave Griffiths's avatar
Dave Griffiths committed
424
             (msg "can't find " id " in server data, marking dirty")
Dave Griffiths's avatar
Dave Griffiths committed
425
             (debug! "Have an entity here not on raspberry pi - marking for upload...")
Dave Griffiths's avatar
Dave Griffiths committed
426
             ;; mark those not present as dirty for next spit cycle
Dave Griffiths's avatar
Dave Griffiths committed
427
             (update-entity-dirtify db table id)))
Dave Griffiths's avatar
Dave Griffiths committed
428 429
     ids)))

Dave Griffiths's avatar
Dave Griffiths committed
430 431 432 433 434 435 436 437
;; repeatedly read version and request updates
(define (suck-new db table)
  (debug! "Requesting new entities")
  (list
   (http-request
    "new-entities-req"
    (string-append url "fn=entity-versions&table=" table)
    (lambda (data)
Dave Griffiths's avatar
docs  
Dave Griffiths committed
438
      (let ((new-entity-requests (build-entity-requests db table data)))
Dave Griffiths's avatar
Dave Griffiths committed
439 440 441
        (alog "suck-new: marking dirty")
        (mark-unlisted-entities-dirty! db table data)
        (alog "suck-new: done marking dirty")
Dave Griffiths's avatar
Dave Griffiths committed
442
        (cond
Dave Griffiths's avatar
Dave Griffiths committed
443
         ((null? new-entity-requests)
Dave Griffiths's avatar
Dave Griffiths committed
444 445 446 447 448 449
          (debug! "No new data to download")
          (set-current! 'download 1)
          (append
           (if (eqv? (get-current 'upload 0) 1)
               (list (play-sound "ping")) '())
           (list
Dave Griffiths's avatar
docs  
Dave Griffiths committed
450
            (toast "No new data to download"))))
Dave Griffiths's avatar
Dave Griffiths committed
451 452 453
         (else
          (debug! (string-append
                   "Requesting "
Dave Griffiths's avatar
Dave Griffiths committed
454
                   (number->string (length new-entity-requests)) " entities"))
Dave Griffiths's avatar
Dave Griffiths committed
455 456
          (cons
           (play-sound "active")
Dave Griffiths's avatar
Dave Griffiths committed
457
           new-entity-requests))))))))
Dave Griffiths's avatar
Dave Griffiths committed
458

459 460 461
(msg "build-dirty defined...")

(define (build-dirty db)
Dave Griffiths's avatar
Dave Griffiths committed
462 463 464
  (let ((sync (get-dirty-stats db "sync"))
        (stream (get-dirty-stats db "stream")))
    (string-append
465 466
     "Sync data: " (number->string (car sync)) "/" (number->string (cadr sync)) " "
     "Stream data: " (number->string (car stream)) "/" (number->string (cadr stream)))))
Dave Griffiths's avatar
Dave Griffiths committed
467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490

(define (upload-dirty db)
  (let ((r (append
            (spit db "sync" (dirty-entities db "sync"))
            (spit db "stream" (dirty-entities db "stream")))))
    (append (cond
             ((> (length r) 0)
              (debug! (string-append "Uploading " (number->string (length r)) " items..."))
              (list
               (toast "Uploading data...")
               (play-sound "active")))
             (else
              (debug! "No data changed to upload")
              (set-current! 'upload 1)
              (append
               (if (eqv? (get-current 'download 0) 1)
                   (list (play-sound "ping")) '())
               (list
                (toast "No data changed to upload"))))) r)))

(define (connect-to-net fn)
  (list
   (network-connect
    "network"
Dave Griffiths's avatar
Dave Griffiths committed
491
    "symbai-web"
Dave Griffiths's avatar
Dave Griffiths committed
492 493 494 495 496 497 498
    (lambda (state)
      (debug! (string-append "Raspberry Pi connection state now: " state))
      (append
       (if (equal? state "Connected") (fn) '())
       (list
        ;;(update-widget 'text-view (get-id "sync-connect") 'text state)
        ))))))
Dave Griffiths's avatar
Dave Griffiths committed
499 500 501 502 503 504 505 506 507 508 509 510 511 512 513


(define i18n-lang 0)

(define i18n-text
  (list))

(define (mtext-lookup id)
  (define (_ l)
    (cond
     ((null? l) (string-append (symbol->string id) " not translated"))
     ((eq? (car (car l)) id)
      (let ((translations (cadr (car l))))
        (if (<= (length translations) i18n-lang)
            (string-append (symbol->string id) " not translated")
Dave Griffiths's avatar
Dave Griffiths committed
514 515 516
            (let ((r (list-ref translations i18n-lang)))
              (if (or (equal? r "") (equal? r " "))
                  (list-ref translations 0) r)))))
Dave Griffiths's avatar
Dave Griffiths committed
517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544
     (else (_ (cdr l)))))
  (_ i18n-text))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (symbol->id id)
  (when (not (symbol? id))
        (msg "symbol->id: [" id "] is not a symbol"))
  (make-id (symbol->string id)))

(define (get-symbol-id id)
  (when (not (symbol? id))
        (msg "symbol->id: [" id "] is not a symbol"))
  (get-id (symbol->string id)))

(define (mbutton id fn)
  (button (symbol->id id)
          (mtext-lookup id)
          40 (layout 'fill-parent 'wrap-content -1 'centre 5) fn))

(define (mbutton-scale id fn)
  (button (symbol->id id)
          (mtext-lookup id)
          40 (layout 'fill-parent 'wrap-content 1 'centre 5) fn))

(define (mtoggle-button id fn)
  (toggle-button (symbol->id id)
                 (mtext-lookup id)
Dave Griffiths's avatar
Dave Griffiths committed
545 546 547
                 30 (layout 'fill-parent 'wrap-content -1 'centre 0) "fancy"
                 ;; convert to 0/1 for easier db storage
                 (lambda (v) (fn (if v 1 0)))))
Dave Griffiths's avatar
Dave Griffiths committed
548 549 550 551

(define (mtoggle-button-scale id fn)
  (toggle-button (symbol->id id)
                 (mtext-lookup id)
Dave Griffiths's avatar
Dave Griffiths committed
552 553
                 30 (layout 'fill-parent 'wrap-content 1 'centre 0) "fancy"
                 (lambda (v) (fn (if v 1 0)))))
Dave Griffiths's avatar
Dave Griffiths committed
554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585

(define (mtext id)
  (text-view (symbol->id id)
             (mtext-lookup id)
             30 (layout 'wrap-content 'wrap-content -1 'centre 0)))

(define (mtext-fixed w id)
  (text-view (symbol->id id)
             (mtext-lookup id)
             30 (layout w 'wrap-content -1 'centre 0)))

(define (mtext-small id)
  (text-view (symbol->id id)
             (mtext-lookup id)
             20 (layout 'wrap-content 'wrap-content -1 'centre 0)))

(define (mtext-scale id)
  (text-view (symbol->id id)
             (mtext-lookup id)
             30 (layout 'wrap-content 'wrap-content 1 'centre 0)))

(define (mtitle id)
  (text-view (symbol->id id)
             (mtext-lookup id)
             50 (layout 'fill-parent 'wrap-content -1 'centre 5)))

(define (mtitle-scale id)
  (text-view (symbol->id id)
             (mtext-lookup id)
             50 (layout 'fill-parent 'wrap-content 1 'centre 5)))

(define (medit-text id type fn)
Dave Griffiths's avatar
Dave Griffiths committed
586 587 588 589 590 591 592 593 594 595 596
  (linear-layout
   (make-id (string-append (symbol->string id) "-container"))
   'vertical
   (layout 'fill-parent 'wrap-content 1 'centre 20)
   (list 0 0 0 0)
   (list
    (text-view 0 (mtext-lookup id)
               30 (layout 'wrap-content 'wrap-content -1 'centre 0))
    (edit-text (symbol->id id) "" 30 type
               (layout 'fill-parent 'wrap-content -1 'centre 0)
               fn))))
Dave Griffiths's avatar
Dave Griffiths committed
597 598

(define (medit-text-scale id type fn)
Dave Griffiths's avatar
Dave Griffiths committed
599 600 601 602 603 604 605 606 607 608 609
  (linear-layout
   (make-id (string-append (symbol->string id) "-container"))
   'vertical
   (layout 'fill-parent 'wrap-content 1 'centre 20)
   (list 0 0 0 0)
   (list
    (text-view 0 (mtext-lookup id)
               30 (layout 'wrap-content 'wrap-content 1 'centre 0))
    (edit-text (symbol->id id) "" 30 type
               (layout 'fill-parent 'wrap-content 1 'centre 0)
               fn))))
Dave Griffiths's avatar
Dave Griffiths committed
610

Dave Griffiths's avatar
Dave Griffiths committed
611 612 613 614 615 616 617 618 619 620 621 622 623 624
(define (medit-text-large id type fn)
  (linear-layout
   (make-id (string-append (symbol->string id) "-container"))
   'vertical
   (layout 'fill-parent 'wrap-content 1 'centre 20)
   (list 0 0 0 0)
   (list
    (text-view 0 (mtext-lookup id)
               30 (layout 'wrap-content 'wrap-content -1 'centre 0))
    (edit-text (symbol->id id) "" 30 type
               (layout 'fill-parent 300 -1 'left 0)
               fn))))


Dave Griffiths's avatar
Dave Griffiths committed
625 626 627 628
(define (mspinner id types fn)
  (vert
   (text-view (symbol->id id)
              (mtext-lookup id)
629
              30 (layout 'wrap-content 'wrap-content 1 'centre 0))
Dave Griffiths's avatar
Dave Griffiths committed
630 631 632 633 634 635
   (spinner (make-id (string-append (symbol->string id) "-spinner"))
            (map mtext-lookup types)
            (layout 'wrap-content 'wrap-content 1 'centre 0)
            (lambda (c) (fn c)))))

(define (mspinner-other id types fn)
636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659
  (linear-layout
   (make-id (string-append (symbol->string id) "-container"))
   'horizontal
   (layout 'fill-parent 'wrap-content 1 'centre 5)
   (list 0 0 0 0)
   (list
    (vert
     (text-view (symbol->id id)
                (mtext-lookup id)
                30 (layout 'wrap-content 'wrap-content 1 'centre 10))
     (spinner (make-id (string-append (symbol->string id) "-spinner"))
              (map mtext-lookup types)
              (layout 'wrap-content 'wrap-content 1 'centre 0)
              (lambda (c)
                ;; dont call if set to "other"
                (if (< c (- (length types) 1))
                    (fn c)
                    '()))))
    (vert
     (mtext-scale 'other)
     (edit-text (make-id (string-append (symbol->string id) "-edit-text"))
                "" 30 "normal"
                (layout 'fill-parent 'wrap-content 1 'centre 0)
                (lambda (t) (fn t)))))))
Dave Griffiths's avatar
Dave Griffiths committed
660

Dave Griffiths's avatar
Dave Griffiths committed
661 662 663 664 665 666 667 668 669 670 671 672
(define (mspinner-other-vert id text-id types fn)
  (linear-layout
   0 'vertical
   (layout 'fill-parent 'wrap-content 1 'centre 5)
   (list 0 0 0 0)
   (list
    (text-view (symbol->id id)
               (mtext-lookup text-id)
               30 (layout 'wrap-content 'wrap-content 1 'centre 5))
    (spinner (make-id (string-append (symbol->string id) "-spinner"))
             (map mtext-lookup types)
             (layout 'wrap-content 'wrap-content 1 'centre 0)
Dave Griffiths's avatar
Dave Griffiths committed
673 674 675 676
             (lambda (c)
               ;; dont call if set to "other"
               (if (< c (- (length types) 1))
                   (fn c) '())))
Dave Griffiths's avatar
Dave Griffiths committed
677 678 679 680 681 682
    (mtext-scale 'other)
    (edit-text (make-id (string-append (symbol->string id) "-edit-text"))
               "" 30 "normal"
               (layout 'fill-parent 'wrap-content 1 'centre 0)
               (lambda (t) (fn t))))))

Dave Griffiths's avatar
Dave Griffiths committed
683 684 685 686 687 688 689 690 691 692 693 694 695 696

(define (mclear-toggles id-list)
  (map
   (lambda (id)
     (update-widget 'toggle-button (get-id id) 'checked 0))
   id-list))

(define (mclear-toggles-not-me me id-list)
  (foldl
   (lambda (id r)
     (if (equal? me id)
         r (cons (update-widget 'toggle-button (get-id id) 'checked 0) r)))
   '() id-list))

697 698 699
(define (image-invalid? image-name)
  (or (null? image-name)
      (not image-name)
700 701
      (equal? image-name "none")
      (equal? image-name "")))
702

Dave Griffiths's avatar
Dave Griffiths committed
703 704 705 706 707
;; fill out the widget from the current entity in the memory store
;; dispatches based on widget type
(define (mupdate widget-type id-symbol key)
  (cond
   ((or (eq? widget-type 'edit-text) (eq? widget-type 'text-view))
708 709 710 711
    (let ((v (entity-get-value key)))
      (update-widget widget-type (get-symbol-id id-symbol) 'text
                     ;; hide -1 as it represents unset
                     (if (and (number? v) (eqv? v -1))
Dave Griffiths's avatar
Dave Griffiths committed
712
                         "" v))))
Dave Griffiths's avatar
Dave Griffiths committed
713
   ((eq? widget-type 'toggle-button)
Dave Griffiths's avatar
Dave Griffiths committed
714
    (update-widget widget-type (get-symbol-id id-symbol) 'checked
Dave Griffiths's avatar
Dave Griffiths committed
715 716 717
                   (entity-get-value key)))
   ((eq? widget-type 'image-view)
    (let ((image-name (entity-get-value key)))
718
      (if (image-invalid? image-name)
Dave Griffiths's avatar
Dave Griffiths committed
719 720 721 722 723
          (update-widget widget-type (get-symbol-id id-symbol) 'image "face")
          (update-widget widget-type (get-symbol-id id-symbol) 'external-image
                         (string-append dirname "files/" image-name)))))
   (else (msg "mupdate-widget unhandled widget type" widget-type))))

724
(define (spinner-choice l i)
Dave Griffiths's avatar
Dave Griffiths committed
725 726 727
  (if (number? i)
      (symbol->string (list-ref l i))
      i))
728

729
(define (mupdate-spinner id-symbol key choices)
730 731
  (let* ((val (entity-get-value key)))
    (if (not val)
732 733
        (update-widget 'spinner
                       (get-id (string-append (symbol->string id-symbol) "-spinner"))
734 735 736 737 738 739 740 741 742 743 744
                       'selection 0)
        (let ((index (index-find (string->symbol val) choices)))
          (if index
              (update-widget 'spinner
                             (get-id (string-append (symbol->string id-symbol) "-spinner"))
                             'selection index)
              (begin
                (msg "spinner item in db " val " not found in list of items")
                (update-widget 'spinner
                               (get-id (string-append (symbol->string id-symbol) "-spinner"))
                               'selection 0)))))))
745 746

(define (mupdate-spinner-other id-symbol key choices)
Dave Griffiths's avatar
Dave Griffiths committed
747
  (let* ((val (entity-get-value key)))
748
    (if (not val)
Dave Griffiths's avatar
Dave Griffiths committed
749 750 751
        (list (update-widget 'spinner
                             (get-id (string-append (symbol->string id-symbol) "-spinner"))
                             'selection 0))
752 753
        (let ((index (index-find (string->symbol val) choices)))
          (if index
Dave Griffiths's avatar
Dave Griffiths committed
754 755 756 757 758 759 760 761 762 763
              (list (update-widget 'spinner
                                   (get-id (string-append (symbol->string id-symbol) "-spinner"))
                                   'selection index))
              (list
               (update-widget 'spinner
                              (get-id (string-append (symbol->string id-symbol) "-spinner"))
                              'selection (- (length choices) 1))
               (update-widget 'edit-text
                              (get-id (string-append (symbol->string id-symbol) "-edit-text"))
                              'text val)))))))
764

Dave Griffiths's avatar
Dave Griffiths committed
765 766 767 768 769 770 771 772 773 774 775 776 777
;;;;
;; (y m d h m s)
(define (date-minus-months d ms)
  (let ((year (list-ref d 0))
        (month (- (list-ref d 1) 1)))
    (let ((new-month (- month ms)))
      (list
       (if (< new-month 0) (- year 1) year)
       (+ (if (< new-month 0) (+ new-month 12) new-month) 1)
       (list-ref d 2)
       (list-ref d 3)
       (list-ref d 4)
       (list-ref d 5)))))
Dave Griffiths's avatar
Dave Griffiths committed
778 779

(define (do-gps display-id key-prepend)
Dave Griffiths's avatar
Dave Griffiths committed
780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809
  (list
   (alert-dialog
    "gps-check"
    (mtext-lookup 'gps-are-you-sure)
    (lambda (v)
      (cond
       ((eqv? v 1)
        (list
         (alert-dialog
          "gps-check2"
          (mtext-lookup 'gps-are-you-sure-2)
          (lambda (v)
            (cond
             ((eqv? v 1)
              (let ((loc (get-current 'location '(0 0))))
                (entity-set-value! (string-append key-prepend "-lat") "real" (car loc))
                (entity-set-value! (string-append key-prepend "-lon") "real" (cadr loc))
                (list
                 (update-widget
                  'text-view
                  (get-id (string-append (symbol->string display-id) "-lat"))
                  'text
                  (number->string (car loc)))
                 (update-widget
                  'text-view
                  (get-id (string-append (symbol->string display-id) "-lon"))
                  'text
                  (number->string (cadr loc))))))
             (else '()))))))
       (else '()))))))
Dave Griffiths's avatar
Dave Griffiths committed
810 811

(define (mupdate-gps display-id key-prepend)
Dave Griffiths's avatar
Dave Griffiths committed
812 813 814
  (let ((lat (entity-get-value (string-append key-prepend "-lat")))
        (lon (entity-get-value (string-append key-prepend "-lon"))))
    (if (or (not lat) (not lon))
Dave Griffiths's avatar
Dave Griffiths committed
815 816 817 818 819 820 821
        (list
         (update-widget
          'text-view (get-id (string-append (symbol->string display-id) "-lat"))
          'text "O")
         (update-widget
          'text-view (get-id (string-append (symbol->string display-id) "-lon"))
          'text "0"))
Dave Griffiths's avatar
Dave Griffiths committed
822 823 824 825 826 827 828
        (list
         (update-widget
          'text-view (get-id (string-append (symbol->string display-id) "-lat"))
          'text (number->string lat))
         (update-widget
          'text-view (get-id (string-append (symbol->string display-id) "-lon"))
          'text (number->string lon))))))
829 830 831 832


;; a standard builder for list widgets of entities and a
;; make new button, to add defaults to the list
833
(define (build-list-widget db table title title-ids entity-type edit-activity parent-fn ktv-default-fn)
834 835 836 837 838 839 840 841 842
    (vert-colour
     colour-two
     (horiz
      (mtitle-scale title)
      (button
       (make-id (string-append (symbol->string title) "-add"))
       (mtext-lookup 'add-item-to-list)
       40 (layout 100 'wrap-content 1 'centre 5)
       (lambda ()
843 844 845
         (entity-create!
          db table entity-type
          (ktvlist-merge
Dave Griffiths's avatar
Dave Griffiths committed
846
           (ktv-default-fn)
847
           (list (ktv "parent" "varchar" (parent-fn)))))
848
         (list (update-list-widget db table title-ids entity-type edit-activity (parent-fn))))))
849 850 851 852 853 854 855
     (linear-layout
      (make-id (string-append entity-type "-list"))
      'vertical
      (layout 'fill-parent 'wrap-content 1 'centre 20)
      (list 0 0 0 0)
      (list))))

856 857 858 859 860 861 862 863 864 865 866 867
(define (make-list-widget-title e title-ids)
  (if (eqv? (length title-ids) 1)
      (ktv-get e (car title-ids))
      (string-append
       (ktv-get e (car title-ids)) "\n"
       (foldl
        (lambda (id r)
          (if (equal? r "")
              (ktv-get e id)
              (string-append r " " (ktv-get e id))))
        "" (cdr title-ids)))))

868
;; pull db data into list of button widgets
869
(define (update-list-widget db table title-ids entity-type edit-activity parent)
870 871
  (let ((search-results
         (if parent
872 873
             (db-filter-only db table entity-type
                             (list (list "parent" "varchar" "=" parent))
874 875 876 877
                             (map
                              (lambda (id)
                                (list id "varchar"))
                              title-ids))
878 879 880 881 882 883 884 885 886 887 888
             (db-all db table entity-type))))
    (update-widget
     'linear-layout
     (get-id (string-append entity-type "-list"))
     'contents
     (if (null? search-results)
         (list (mtext 'list-empty))
         (map
          (lambda (e)
            (button
             (make-id (string-append "list-button-" (ktv-get e "unique_id")))
889 890
             (make-list-widget-title e title-ids)
             30 (layout 'fill-parent 'wrap-content 1 'centre 5)
891 892 893 894 895 896 897 898 899 900 901 902 903 904 905
             (lambda ()
               (list (start-activity edit-activity 0 (ktv-get e "unique_id"))))))
          search-results)))))

(define (delete-button)
  (mbutton
   'delete
   (lambda ()
     (list
      (alert-dialog
       "delete-check"
       (mtext-lookup 'delete-are-you-sure)
       (lambda (v)
         (cond
          ((eqv? v 1)
906
           (entity-set-value! "deleted" "int" 1)
907 908 909 910
           (entity-update-values!)
           (list (finish-activity 1)))
          (else
           (list)))))))))
Dave Griffiths's avatar
Dave Griffiths committed
911

912 913 914 915 916
(define (build-array-from-names db table entity-type)
  (map
   (lambda (e)
     (list (ktv-get e "name")
           (ktv-get e "unique_id")))
Dave Griffiths's avatar
Dave Griffiths committed
917 918 919
   (db-filter-only db table entity-type
                   (list)
                   (list (list "name" "varchar")))))
920

Dave Griffiths's avatar
Dave Griffiths committed
921 922 923 924 925 926 927
(define (find-index-from-name-array arr unique-id)
  (define (_ l i)
    (cond
     ((null? l) #f)
     ((equal? unique-id (cadr (car l))) i)
     (else (_ (cdr l) (+ i 1)))))
  (_ arr 0))
928

Dave Griffiths's avatar
Dave Griffiths committed
929 930 931 932 933 934 935 936



(define (simpsons-village db table default-ktvlist)
  (entity-create! db table "village"
                  (ktvlist-merge
                   default-ktvlist
                   (list
Dave Griffiths's avatar
Dave Griffiths committed
937
                    (ktv "name" "varchar" (string-append "Village-" (number->string (random 1000))))
Dave Griffiths's avatar
Dave Griffiths committed
938 939
                    (ktv "block" "varchar" (word-gen))
                    (ktv "district" "varchar" (word-gen))
Dave Griffiths's avatar
Dave Griffiths committed
940
                    (ktv "car" "int" (random 2))))))
Dave Griffiths's avatar
Dave Griffiths committed
941 942 943 944 945 946

(define (simpsons-household db table parent default-ktvlist)
  (entity-create! db table "household"
                  (ktvlist-merge
                   default-ktvlist
                   (list
Dave Griffiths's avatar
Dave Griffiths committed
947 948
                    (ktv "name" "varchar" (string-append "Household-" (number->string (random 1000))))
                    (ktv "num-pots" "int" (random 10))
Dave Griffiths's avatar
Dave Griffiths committed
949 950 951
                    (ktv "parent" "varchar" parent)))))

(define (simpsons-individual db table parent default-ktvlist)
Dave Griffiths's avatar
Dave Griffiths committed
952
  (let ((n (random 1000)))
Dave Griffiths's avatar
Dave Griffiths committed
953 954 955 956 957 958 959 960
  (entity-create! db table "individual"
                  (ktvlist-merge
                   default-ktvlist
                   (append
                    (list (ktv "parent" "varchar" parent))
  (choose
   (list
   (list
Dave Griffiths's avatar
Dave Griffiths committed
961
    (ktv "name" "varchar"
Dave Griffiths's avatar
Dave Griffiths committed
962
                (string-append "Abe-" (number->string n)))
Dave Griffiths's avatar
Dave Griffiths committed
963 964
    (ktv "gender" "varchar" "male")
    (ktv "photo" "file" "abe.jpg"))
Dave Griffiths's avatar
Dave Griffiths committed
965
   (list
Dave Griffiths's avatar
Dave Griffiths committed
966
    (ktv
Dave Griffiths's avatar
Dave Griffiths committed
967
     "name" "varchar" (string-append "Akira-" (number->string n)))
Dave Griffiths's avatar
Dave Griffiths committed
968 969
    (ktv "gender" "varchar" "male")
    (ktv "photo" "file" "akira.jpg"))
Dave Griffiths's avatar
Dave Griffiths committed
970
   (list
Dave Griffiths's avatar
Dave Griffiths committed
971
    (ktv
Dave Griffiths's avatar
Dave Griffiths committed
972
     "name" "varchar" (string-append "Apu-" (number->string n)))
Dave Griffiths's avatar
Dave Griffiths committed
973 974
    (ktv "gender" "varchar" "male")
    (ktv "photo" "file" "apu.jpg"))
Dave Griffiths's avatar
Dave Griffiths committed
975
   (list
Dave Griffiths's avatar
Dave Griffiths committed
976
    (ktv
Dave Griffiths's avatar
Dave Griffiths committed
977
     "name" "varchar" (string-append "Barney-" (number->string n)))
Dave Griffiths's avatar
Dave Griffiths committed
978 979
    (ktv "gender" "varchar" "male")
    (ktv "photo" "file" "barney.jpg"))
Dave Griffiths's avatar
Dave Griffiths committed
980
   (list
Dave Griffiths's avatar
Dave Griffiths committed
981
    (ktv
Dave Griffiths's avatar
Dave Griffiths committed
982
     "name" "varchar" (string-append "Bart-" (number->string n)))
Dave Griffiths's avatar
Dave Griffiths committed
983 984
    (ktv "gender" "varchar" "male")
    (ktv "photo" "file" "bartsimpson.jpg"))
Dave Griffiths's avatar
Dave Griffiths committed
985
   (list
Dave Griffiths's avatar
Dave Griffiths committed
986
    (ktv
Dave Griffiths's avatar
Dave Griffiths committed
987
     "name" "varchar" (string-append "Billy-" (number->string n)))
Dave Griffiths's avatar
Dave Griffiths committed
988 989
    (ktv "gender" "varchar" "male")
    (ktv "photo" "file" "billy.jpg"))
Dave Griffiths's avatar
Dave Griffiths committed
990
   (list
Dave Griffiths's avatar
Dave Griffiths committed
991
    (ktv
Dave Griffiths's avatar
Dave Griffiths committed
992
     "name" "varchar" (string-append "Carl-" (number->string n)))
Dave Griffiths's avatar
Dave Griffiths committed
993 994
    (ktv "gender" "varchar" "male")
    (ktv "photo" "file" "carl.jpg"))
Dave Griffiths's avatar
Dave Griffiths committed
995
   (list
Dave Griffiths's avatar
Dave Griffiths committed
996
    (ktv
Dave Griffiths's avatar
Dave Griffiths committed
997
     "name" "varchar" (string-append "Cletus-" (number->string n)))
Dave Griffiths's avatar
Dave Griffiths committed
998 999
    (ktv "gender" "varchar" "male")
    (ktv "photo" "file" "cletus.jpg"))
Dave Griffiths's avatar
Dave Griffiths committed
1000
   (list
Dave Griffiths's avatar
Dave Griffiths committed
1001
    (ktv
Dave Griffiths's avatar
Dave Griffiths committed
1002
     "name" "varchar" (string-append "ComicBookGuy-" (number->string n)))
Dave Griffiths's avatar
Dave Griffiths committed
1003 1004
    (ktv "gender" "varchar" "male")
    (ktv "photo" "file" "comicbookguy.jpg"))
Dave Griffiths's avatar
Dave Griffiths committed
1005
   (list
Dave Griffiths's avatar
Dave Griffiths committed
1006
    (ktv
Dave Griffiths's avatar
Dave Griffiths committed
1007
     "name" "varchar" (string-append "Homer-" (number->string n)))
Dave Griffiths's avatar
Dave Griffiths committed
1008 1009
    (ktv "gender" "varchar" "male")
    (ktv "photo" "file" "homersimpson.jpg"))
Dave Griffiths's avatar
Dave Griffiths committed
1010
   (list
Dave Griffiths's avatar
Dave Griffiths committed
1011
    (ktv
Dave Griffiths's avatar
Dave Griffiths committed
1012
     "name" "varchar" (string-append "Jasper-" (number->string n)))
Dave Griffiths's avatar
Dave Griffiths committed
1013 1014
    (ktv "gender" "varchar" "male")
    (ktv "photo" "file" "jasper.jpg"))
Dave Griffiths's avatar
Dave Griffiths committed
1015
   (list
Dave Griffiths's avatar
Dave Griffiths committed
1016
    (ktv
Dave Griffiths's avatar
Dave Griffiths committed
1017
     "name" "varchar" (string-append "Kent-" (number->string n)))
Dave Griffiths's avatar
Dave Griffiths committed
1018 1019
    (ktv "gender" "varchar" "male")
    (ktv "photo" "file" "kentbrockman.jpg"))
Dave Griffiths's avatar
Dave Griffiths committed
1020
   (list
Dave Griffiths's avatar
Dave Griffiths committed
1021
    (ktv
Dave Griffiths's avatar
Dave Griffiths committed
1022
     "name" "varchar" (string-append "Kodos-" (number->string n)))
Dave Griffiths's avatar
Dave Griffiths committed
1023 1024
    (ktv "gender" "varchar" "male")
    (ktv "photo" "file" "kodos.jpg"))
Dave Griffiths's avatar
Dave Griffiths committed
1025
   (list
Dave Griffiths's avatar
Dave Griffiths committed
1026
    (ktv
Dave Griffiths's avatar
Dave Griffiths committed
1027
     "name" "varchar" (string-append "Lenny-" (number->string n)))
Dave Griffiths's avatar
Dave Griffiths committed
1028 1029
    (ktv "gender" "varchar" "male")
    (ktv "photo" "file" "lenny.jpg"))
Dave Griffiths's avatar
Dave Griffiths committed
1030
   (list
Dave Griffiths's avatar
Dave Griffiths committed
1031
    (ktv
Dave Griffiths's avatar
Dave Griffiths committed
1032
     "name" "varchar" (string-append "Lisa-" (number->string n)))
Dave Griffiths's avatar
Dave Griffiths committed
1033 1034
    (ktv "gender" "varchar" "female")
    (ktv "photo" "file" "lisasimpson.jpg"))
Dave Griffiths's avatar
Dave Griffiths committed
1035
   (list
Dave Griffiths's avatar
Dave Griffiths committed
1036
    (ktv
Dave Griffiths's avatar
Dave Griffiths committed
1037
     "name" "varchar" (string-append "Marge-" (number->string n)))
Dave Griffiths's avatar
Dave Griffiths committed
1038 1039
    (ktv "gender" "varchar" "female")
    (ktv "photo" "file" "margesimpson.jpg"))
Dave Griffiths's avatar
Dave Griffiths committed
1040
   (list
Dave Griffiths's avatar
Dave Griffiths committed
1041
    (ktv
Dave Griffiths's avatar
Dave Griffiths committed
1042
     "name" "varchar" (string-append "Martin-" (number->string n)))
Dave Griffiths's avatar
Dave Griffiths committed
1043 1044
    (ktv "gender" "varchar" "male")
    (ktv "photo" "file" "martinprince.jpg"))
Dave Griffiths's avatar
Dave Griffiths committed
1045
   (list
Dave Griffiths's avatar
Dave Griffiths committed
1046
    (ktv
Dave Griffiths's avatar
Dave Griffiths committed
1047
     "name" "varchar" (string-append "Milhouse-" (number->string n)))
Dave Griffiths's avatar
Dave Griffiths committed
1048 1049
    (ktv "gender" "varchar" "male")
    (ktv "photo" "file" "milhouse.jpg"))
Dave Griffiths's avatar
Dave Griffiths committed
1050
   (list
Dave Griffiths's avatar
Dave Griffiths committed
1051
    (ktv
Dave Griffiths's avatar
Dave Griffiths committed
1052
     "name" "varchar" (string-append "MrBurns-" (number->string n)))
Dave Griffiths's avatar
Dave Griffiths committed
1053 1054
    (ktv "gender" "varchar" "male")
    (ktv "photo" "file" "mrburns.jpg"))
Dave Griffiths's avatar
Dave Griffiths committed
1055
   (list
Dave Griffiths's avatar
Dave Griffiths committed
1056
    (ktv
Dave Griffiths's avatar
Dave Griffiths committed
1057
     "name" "varchar" (string-append "Ned-" (number->string n)))
Dave Griffiths's avatar
Dave Griffiths committed
1058 1059
    (ktv "gender" "varchar" "male")
    (ktv "photo" "file" "nedflanders.jpg"))
Dave Griffiths's avatar
Dave Griffiths committed
1060
   (list
Dave Griffiths's avatar
Dave Griffiths committed
1061
    (ktv
Dave Griffiths's avatar
Dave Griffiths committed
1062
     "name" "varchar" (string-append "Nelson-" (number->string n)))
Dave Griffiths's avatar
Dave Griffiths committed
1063 1064
    (ktv "gender" "varchar" "male")
    (ktv "photo" "file" "nelson.jpg"))
Dave Griffiths's avatar
Dave Griffiths committed
1065
   (list
Dave Griffiths's avatar
Dave Griffiths committed
1066
    (ktv
Dave Griffiths's avatar
Dave Griffiths committed
1067
     "name" "varchar" (string-append "Otto-" (number->string n)))
Dave Griffiths's avatar
Dave Griffiths committed
1068 1069
    (ktv "gender" "varchar" "male")
    (ktv "photo" "file" "otto.jpg"))
Dave Griffiths's avatar
Dave Griffiths committed
1070
   (list
Dave Griffiths's avatar
Dave Griffiths committed
1071
    (ktv
Dave Griffiths's avatar
Dave Griffiths committed
1072
     "name" "varchar" (string-append "Ralph-" (number->string n)))
Dave Griffiths's avatar
Dave Griffiths committed
1073 1074
    (ktv "gender" "varchar" "male")
    (ktv "photo" "file" "ralphwiggum.jpg"))
Dave Griffiths's avatar
Dave Griffiths committed
1075
   (list
Dave Griffiths's avatar
Dave Griffiths committed
1076
    (ktv
Dave Griffiths's avatar
Dave Griffiths committed
1077
     "name" "varchar" (string-append "Santaslittlehelper-" (number->string n)))
Dave Griffiths's avatar
Dave Griffiths committed
1078 1079
    (ktv "gender" "varchar" "male")
    (ktv "photo" "file" "santaslittlehelper.jpg"))
Dave Griffiths's avatar
Dave Griffiths committed
1080
   (list
Dave Griffiths's avatar
Dave Griffiths committed
1081
    (ktv
Dave Griffiths's avatar
Dave Griffiths committed
1082
     "name" "varchar" (string-append "SideshowBob-" (number->string n)))
Dave Griffiths's avatar
Dave Griffiths committed
1083 1084
    (ktv "gender" "varchar" "male")
    (ktv "photo" "file" "sideshowbob.jpg")))))))))
Dave Griffiths's avatar
Dave Griffiths committed
1085 1086 1087 1088 1089 1090 1091 1092

(define (looper! n fn)
  (when (not (zero? n))
        (fn n)
        (looper! (- n 1) fn)))

(define (build-test! db table village-ktvlist household-ktvlist individual-ktvlist)
  (looper!
Dave Griffiths's avatar
Dave Griffiths committed
1093
   1
Dave Griffiths's avatar
Dave Griffiths committed
1094 1095 1096 1097
   (lambda (i)
     (msg "making village" i)
     (let ((village (simpsons-village db table village-ktvlist)))
       (looper!
1098
        15
Dave Griffiths's avatar
Dave Griffiths committed
1099 1100 1101 1102 1103
        (lambda (i)
          (alog "household")
          (msg "making household" i)
          (let ((household (simpsons-household db table village household-ktvlist)))
            (looper!
Dave Griffiths's avatar
Dave Griffiths committed
1104
             (+ 2 (random 5))
Dave Griffiths's avatar
Dave Griffiths committed
1105 1106 1107
             (lambda (i)
               (msg "making individual" i)
               (simpsons-individual db table household individual-ktvlist))))))))))
Dave Griffiths's avatar
Dave Griffiths committed
1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142


(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)))