Commit d9621bd7 authored by Dave Griffiths's avatar Dave Griffiths
Browse files

review validation works for lists and removed lat/lon/user/time

parent 320d6d4b
...@@ -197,19 +197,21 @@ ...@@ -197,19 +197,21 @@
entities)) entities))
(define (string-split-simple str delim) (define (string-split-simple str delim)
(let ((r (foldl (string-split str (list delim)))
(lambda (c r)
(cond ; (let ((r (foldl
((eqv? c delim) ; (lambda (c r)
(list "" (append (cadr r) (list (car r))))) ; (cond
(else ; ((eqv? c delim)
(list (string-append (car r) (string c)) ; (list "" (append (cadr r) (list (car r)))))
(cadr r))))) ; (else
(list "" '()) ; (list (string-append (car r) (string c))
(string->list str)))) ; (cadr r)))))
(if (equal? (car r) "") ; (list "" '())
(cadr r) ; (string->list str))))
(append (cadr r) (list (car r)))))) ; (if (equal? (car r) "")
; (cadr r)
; (append (cadr r) (list (car r))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; syncing code ;; syncing code
......
...@@ -338,6 +338,16 @@ ...@@ -338,6 +338,16 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (string-remove-whitespace str)
(define (_ i)
(cond
((>= i (string-length str)) "")
((char-whitespace? (string-ref str i))
(_ (+ i 1)))
(else (string-append (string (string-ref str i))
(_ (+ i 1))))))
(_ 0))
(define (string-split str . rest) (define (string-split str . rest)
; maxsplit is a positive number ; maxsplit is a positive number
(define (split-by-whitespace str maxsplit) (define (split-by-whitespace str maxsplit)
......
...@@ -446,7 +446,10 @@ ...@@ -446,7 +446,10 @@
;; review ;; review
(define (ktv-key-is-id? ktv) (define (ktv-key-is-id? ktv)
(equal? (substring (ktv-key ktv) 0 3) "id-")) (or
(equal? (ktv-key ktv) "pack")
(equal? (ktv-key ktv) "present")
(equal? (substring (ktv-key ktv) 0 3) "id-")))
;; search for a comma in a list of ids ;; search for a comma in a list of ids
(define (ktv-value-is-list? ktv) (define (ktv-value-is-list? ktv)
...@@ -456,42 +459,75 @@ ...@@ -456,42 +459,75 @@
#f #f
(string->list (ktv-value ktv)))) (string->list (ktv-value ktv))))
(define (uid->name uid)
(let* ((entity-id (entity-id-from-unique db "sync" uid)))
(ktv-get (get-entity-only db "sync" entity-id
(list (list "name" "varchar")))
"name")))
(define (review-build-id ktv) (define (review-build-id ktv)
(let* ((uid (ktv-value ktv)) (list (medit-text-value
(entity-id (entity-id-from-unique db "sync" uid)) (string-append (ktv-value ktv) (ktv-key ktv))
(type (get-entity-type db "sync" entity-id)) (ktv-key ktv)
(name (ktv-get (get-entity-only db "sync" entity-id (uid->name (ktv-value ktv)) "normal"
(list (list "name" "varchar"))) (lambda (v)
"name"))) (entity-set-value! (ktv-key ktv) (ktv-type ktv) v)
(msg (ktv-value ktv) entity-id type name) '()))))
(define (review-build-list ktv)
(let ((ids (string-split-simple (ktv-value ktv) #\,)))
(list (medit-text-value (list (medit-text-value
(string-append uid (ktv-key ktv))
(ktv-key ktv) (ktv-key ktv)
name "normal" (ktv-key ktv)
(foldl
(lambda (id r)
(if (equal? r "")
(uid->name id)
(string-append r ", " (uid->name id))))
""
ids)
"normal"
(lambda (v) (lambda (v)
(entity-set-value! (ktv-key ktv) (ktv-type ktv) v) (entity-set-value! (ktv-key ktv) (ktv-type ktv) v)
'()))))) '())))))
(define (convert-id name) (define (convert-id name)
(let ((new-entity (db-filter-only (let ((name (string-remove-whitespace name)))
db "sync" "*" ;; search for unique id first
(list (list "name" "varchar" "=" name)) (if (entity-exists? db "sync" name)
(list)))) name
(msg "in convert-id") (let ((new-entity (db-filter-only
(msg new-entity) db "sync" "*"
(if (null? new-entity) (list (list "name" "varchar" "=" name))
#f (list))))
(ktv-get (car new-entity) "unique_id")))) (if (null? new-entity)
#f
(ktv-get (car new-entity) "unique_id"))))))
(define (convert-id-list str)
(let ((names (string-split-simple str #\,)))
(foldl
(lambda (name r)
(if (string? r)
(let ((id (convert-id name)))
(if id
(if (equal? r "") id (string-append r "," id))
#f))
#f))
"" names)))
;; replace entity with names -> uids, or name of not found ;; replace entity with names -> uids, or name of not found
(define (review-validate-contents uid entity) (define (review-validate-contents uid entity)
(msg "review-validate-contents")
(foldl (foldl
(lambda (ktv r) (lambda (ktv r)
(cond (cond
((string? r) r) ;; we have already found an error ((string? r) r) ;; we have already found an error
((ktv-key-is-id? ktv) ((ktv-key-is-id? ktv)
(let ((replacement (convert-id (ktv-value ktv)))) (let ((replacement
(if (ktv-value-is-list? ktv)
(convert-id-list (ktv-value ktv))
(convert-id (ktv-value ktv)))))
(if replacement (if replacement
(cons (list (ktv-key ktv) (ktv-type ktv) replacement) r) (cons (list (ktv-key ktv) (ktv-type ktv) replacement) r)
;; ditch the entity and return error ;; ditch the entity and return error
...@@ -502,24 +538,24 @@ ...@@ -502,24 +538,24 @@
(define (review-build-contents uid entity) (define (review-build-contents uid entity)
(msg "review-build-contents")
(append (append
(foldl (foldl
(lambda (ktv r) (lambda (ktv r)
(msg ktv)
(append (append
r (cond r (cond
((or (equal? (ktv-key ktv) "parent") ((or
(equal? (ktv-key ktv) "unique_id") (equal? (ktv-key ktv) "user")
(equal? (ktv-key ktv) "deleted")) '()) (equal? (ktv-key ktv) "lat")
(equal? (ktv-key ktv) "lon")
(equal? (ktv-key ktv) "time")
(equal? (ktv-key ktv) "parent")
(equal? (ktv-key ktv) "unique_id")
(equal? (ktv-key ktv) "deleted")) '())
((equal? (ktv-type ktv) "varchar") ((equal? (ktv-type ktv) "varchar")
(msg "building review varchar")
(if (ktv-key-is-id? ktv) (if (ktv-key-is-id? ktv)
;;(if (ktv-value-is-list? ktv) (if (ktv-value-is-list? ktv)
(begin (review-build-list ktv)
(msg "we have an id...") (review-build-id ktv))
(review-build-id ktv))
;; (review-build-list ktv))
;; normal varchar ;; normal varchar
(list (medit-text-value (string-append uid (ktv-key ktv)) (list (medit-text-value (string-append uid (ktv-key ktv))
(ktv-key ktv) (ktv-key ktv)
...@@ -550,7 +586,6 @@ ...@@ -550,7 +586,6 @@
(mbutton (string-append uid "-save") "Save" (mbutton (string-append uid "-save") "Save"
(lambda () (lambda ()
(let ((new-entity (review-validate-contents uid (get-current 'entity-values '())))) (let ((new-entity (review-validate-contents uid (get-current 'entity-values '()))))
(msg "from review-validate-contents:" new-entity)
(cond (cond
((list? new-entity) ((list? new-entity)
;; replace with converted ids ;; replace with converted ids
...@@ -561,7 +596,7 @@ ...@@ -561,7 +596,7 @@
(list (list
(alert-dialog (alert-dialog
"mongoose-not-found" "mongoose-not-found"
(string-append "Mongoose " new-entity " not found!") (string-append "Can't find mongoose or pack: " new-entity)
(lambda (v) (lambda (v)
(cond (cond
((eqv? v 1) (list)) ((eqv? v 1) (list))
...@@ -570,7 +605,6 @@ ...@@ -570,7 +605,6 @@
(define (review-item-build) (define (review-item-build)
(let ((uid (entity-get-value "unique_id"))) (let ((uid (entity-get-value "unique_id")))
(msg "review-item-build" uid)
(list (list
(update-widget (update-widget
'linear-layout 'linear-layout
...@@ -1007,7 +1041,6 @@ ...@@ -1007,7 +1041,6 @@
(list (list
(mbutton "pf-grpint-done" "Done" (mbutton "pf-grpint-done" "Done"
(lambda () (lambda ()
(msg "entity-record-values about to be called?")
(entity-record-values!) (entity-record-values!)
(list (replace-fragment (get-id "event-holder") "events")))) (list (replace-fragment (get-id "event-holder") "events"))))
(mbutton "pf-grpint-cancel" "Cancel" (mbutton "pf-grpint-cancel" "Cancel"
...@@ -1382,8 +1415,8 @@ ...@@ -1382,8 +1415,8 @@
(entity-update-single-value! (ktv "id-escort" "varchar" (assemble-array individuals))) (entity-update-single-value! (ktv "id-escort" "varchar" (assemble-array individuals)))
(list)) (list))
(get-grid-select-init-state "id-escort")) (get-grid-select-init-state "id-escort"))
(update-widget 'spinner (get-id "gc-pup-strength") 'selection (dbg (spinner-index list-strength (dbg (entity-get-value "strength"))))) (update-widget 'spinner (get-id "gc-pup-strength") 'selection (spinner-index list-strength (entity-get-value "strength")))
(update-widget 'spinner (get-id "gc-pup-accuracy") 'selection (spinner-index list-strength (dbg (entity-get-value "accurate")))) (update-widget 'spinner (get-id "gc-pup-accuracy") 'selection (spinner-index list-strength (entity-get-value "accurate")))
) )
(update-grid-selector-enabled "gc-pup-escort" (get-current 'gc-present '())) (update-grid-selector-enabled "gc-pup-escort" (get-current 'gc-present '()))
(update-grid-selector-checked "gc-pup-escort" "id-escort") (update-grid-selector-checked "gc-pup-escort" "id-escort")
...@@ -1561,13 +1594,13 @@ ...@@ -1561,13 +1594,13 @@
(let ((user-id (ktv-get (get-entity db "local" 1) "user-id"))) (let ((user-id (ktv-get (get-entity db "local" 1) "user-id")))
(set-current! 'user-id user-id) (set-current! 'user-id user-id)
(msg "on-start 2") (msg "on-start 2")
(dbg (list (list
(gps-start "gps" (lambda (loc) (gps-start "gps" (lambda (loc)
(set-current! 'location loc) (set-current! 'location loc)
(list (toast (string-append (list (toast (string-append
(number->string (car loc)) ", " (number->string (car loc)) ", "
(number->string (cadr loc))))))) (number->string (cadr loc)))))))
(update-widget 'edit-text (get-id "main-id-text") 'text user-id))))) (update-widget 'edit-text (get-id "main-id-text") 'text user-id))))
(lambda (activity) '()) (lambda (activity) '())
(lambda (activity) '()) (lambda (activity) '())
(lambda (activity) '()) (lambda (activity) '())
......
...@@ -95,10 +95,10 @@ ...@@ -95,10 +95,10 @@
(define (filter-entities db table type filter) (define (filter-entities db table type filter)
(let ((s (apply (let ((s (apply
db-select db-select
(append (dbg (append
(list db (build-query table filter (not (equal? type "*")))) (list db (build-query table filter (not (equal? type "*"))))
(build-args filter) (build-args filter)
(if (equal? type "*") '() (list type)))))) (if (equal? type "*") '() (list type)))))))
(msg (db-status db)) (msg (db-status db))
(if (null? s) (if (null? s)
'() '()
......
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