server-sync.ss 6.5 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 18
#lang racket

;; MongooseWeb 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/>.

(require (planet jaymccarthy/sqlite:5:1/sqlite))
Dave Griffiths's avatar
Dave Griffiths committed
19 20 21 22 23 24 25 26 27 28 29 30 31
(require
 "utils.ss"
 "sql.ss"
 "../../eavdb/ktv.ss"
 "../../eavdb/ktv-list.ss"
 "../../eavdb/entity-values.ss"
 "../../eavdb/entity-insert.ss"
 "../../eavdb/entity-get.ss"
 "../../eavdb/entity-update.ss"
 "../../eavdb/entity-sync.ss"
 "../../eavdb/entity-filter.ss"
 "../../eavdb/eavdb.ss")

Dave Griffiths's avatar
Dave Griffiths committed
32 33 34 35 36 37 38
(provide (all-defined-out))


(define (request-args->ktvlist data)
  (map
   (lambda (i)
     (let ((kv (string-split (symbol->string (car i)) '(#\:))))
Dave Griffiths's avatar
Dave Griffiths committed
39
       (list (car kv) (cadr kv) (cdr i))))
Dave Griffiths's avatar
Dave Griffiths committed
40 41 42 43
   data))

(define (sync-update db table entity-type unique-id dirty version data)
  (let ((entity-id (entity-id-from-unique db table unique-id))
dave griffiths's avatar
dave griffiths committed
44 45
        (ktvlist (request-args->ktvlist data)))
    (msg "sync-update")
Dave Griffiths's avatar
Dave Griffiths committed
46 47 48 49
    (update-to-version db table entity-id version ktvlist)
    (list "updated" unique-id)))

(define (sync-insert db table entity-type unique-id dirty version data)
dave griffiths's avatar
dave griffiths committed
50 51
  (let ((ktvlist (request-args->ktvlist data)))
    (msg "inserting new")
Dave Griffiths's avatar
Dave Griffiths committed
52 53 54 55 56 57 58 59 60 61
    (insert-entity-wholesale db table entity-type unique-id dirty version ktvlist)
    (list "inserted" unique-id)))

(define (send-version db table entity-type unique-id current-version)
  (let ((entity-id (entity-id-from-unique db table unique-id)))
    (list
     "new version"
     (list table entity-type entity-id unique-id current-version)
     (get-entity db table entity-id))))

62 63
(define (merge-n-bump current-version db table entity-type unique-id dirty version data)
  (let ((entity-id (entity-id-from-unique db table unique-id)))
dave griffiths's avatar
dave griffiths committed
64
    ;;(msg "merge start:" (get-entity-version db table entity-id))
65
    (let ((r (sync-update db table entity-type unique-id dirty version data)))
dave griffiths's avatar
dave griffiths committed
66
      ;;(msg "merge post:" (get-entity-version db table entity-id))
67 68
      ;; must be one newer than highest in the system
      (update-entity-version db table entity-id (+ current-version 1))
dave griffiths's avatar
dave griffiths committed
69
      ;;(msg "merge over:" (get-entity-version db table entity-id))
70 71
      r)))

Dave Griffiths's avatar
Dave Griffiths committed
72 73 74
(define (check-for-sync db table entity-type unique-id dirty version data)
  (let ((current-version (entity-version-from-unique db table unique-id)))
    (if (not (null? current-version))
75 76
(begin	(msg "versions" version "vs previous " current-version)

Dave Griffiths's avatar
Dave Griffiths committed
77 78 79
        ;; if it exists
        (cond

80
	 ;; dirty path - basically merge it whatever...
Dave Griffiths's avatar
Dave Griffiths committed
81 82 83

         ;; need to update existing data, newer version from android
         ((and (eq? dirty 1) (> version current-version) )
84 85 86
	  (msg "NEWER - merging...")
	  ;; bump the version as this is a new entity post-merge
	  (merge-n-bump version db table entity-type unique-id dirty version data))
Dave Griffiths's avatar
Dave Griffiths committed
87

88 89 90 91 92 93
         ;; dirty but matches, should be ok (timeout causes this)
         ((and (eq? dirty 1) (eq? version current-version))
	  (msg "MATCHES, merging...")
	  ;;(list "match" unique-id))
	  ;; bump the version number so others get merged version
	  (merge-n-bump current-version db table entity-type unique-id dirty version data))
Dave Griffiths's avatar
Dave Griffiths committed
94 95

         ;; it's changed, but has an old or same version = conflict!!??
96 97 98 99 100 101 102 103
	 ;; still merge, but complicated...
         ((and (eq? dirty 1) (< version current-version))
	  (msg "CONFLICT, merging")
          (list "CONFLICT" unique-id)
	  ;; bump the version number so others get merged version
	  (merge-n-bump current-version db table entity-type unique-id dirty version data))

	 ;; not dirty path (avoid doing stuff here as it's probably a bug)
Dave Griffiths's avatar
Dave Griffiths committed
104

105
         ;; android version is newer than existing but not changed??
Dave Griffiths's avatar
Dave Griffiths committed
106
         ((and (eq? dirty 0) (> version current-version))
107
	  (msg "MISMATCH")
Dave Griffiths's avatar
Dave Griffiths committed
108
          (list "MISMATCH" unique-id))
Dave Griffiths's avatar
Dave Griffiths committed
109

110 111 112 113 114 115 116 117 118
         ;; everything matches - no change
         ((and (eq? dirty 0) (eq? version current-version))
	  (msg "NOT DIRTY, WHY SENT? (eq)")
          (list "no change" unique-id))

         ;; need to send update
         ((and (eq? dirty 0) (< version current-version))
	  (msg "NOT DIRTY, WHY SENT? (older)")
          (list "no change" unique-id))
Dave Griffiths's avatar
Dave Griffiths committed
119 120

         (else
121 122
	  (msg "WAT?")
          (list "WAT?" unique-id))))
Dave Griffiths's avatar
Dave Griffiths committed
123 124 125 126 127

        ;; doesnt exist yet, so insert it
        (sync-insert db table entity-type unique-id dirty version data))))

(define (entity-versions db table)
128 129
  (let ((s (db-select
	    db (string-append "select unique_id, version from " table "_entity;"))))
dave griffiths's avatar
dave griffiths committed
130
    (msg s)
Dave Griffiths's avatar
Dave Griffiths committed
131
    (if (null? s)
132 133 134 135 136
	'()
	(map
	 (lambda (i)
	   (list (vector-ref i 0) (vector-ref i 1)))
	 (cdr s)))))
Dave Griffiths's avatar
Dave Griffiths committed
137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194

(define (send-entity db table unique-id)
  (let* ((entity-id (entity-id-from-unique db table unique-id))
         (entity (db-select
                  db (string-append "select entity_type, unique_id, version from "
                                    table "_entity where entity_id = ?")
                  entity-id)))
    (if (not (null? entity))
        (list
         (vector->list (cadr entity))
         (get-entity-plain db table entity-id))
        (list "entity not found" unique-id))))

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

;(define db (open-db "test.db"))

;;(add-entity
;; db "mongoose"
;; (list
;;  (ktv "code" "varchar" "brendon")
;;  (ktv "gender" "varchar" "male")
;;  (ktv "pack-id" "int" 1)
;;  (ktv "weight" "real" 10.4)))

(define (choose l) (list-ref l (random (length l))))

(define (random-string len)
  (if (zero? len)
      "" (string-append (choose (list "g" "t" "a" "c"))
                        (random-string (- len 1)))))

(define (random-ktv)
  (ktv (random-string 2) "varchar" (random-string 4096)))

(define (random-entity size)
  (if (zero? size)
      '() (cons (random-ktv) (random-entity (- size 1)))))

(define (insert-random-entity db)
  (msg "building")
  (let ((e (random-entity 40)))
    (msg "inserting")
    (insert-entity
     db (random-string 2) e)))

(define (build db n)
  (when (not (zero? n))
        (msg "adding entity" n)
        (insert-random-entity db)
        (build db (- n 1))))

(define (test)
  (let ((db (db-open "unit.db")))
    (build db 99999999)
    ))

;(test)