Random Bits of Open Code

Check-in [11a07463f1]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:First pass on sync
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:11a07463f16498167b6548eec0a4c8dc9b79c7a2
User & Date: matt 2018-08-09 04:37:07
Context
2018-08-09
05:30
fixed bunch of little bugs in sync check-in: 5326d1328c user: matt tags: trunk
04:37
First pass on sync check-in: 11a07463f1 user: matt tags: trunk
2018-08-08
05:47
Added sync file and preped to use it. check-in: dbd18f41a2 user: matt tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to multiapp/apps/learn-teach/learn-teach.scm.

73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
  (sessions-matrix #f)
  ;; filters
  (bundle-filter #f)
  (area-filter   #f)
  (target-filter #f)
  (run-name-filter #f)
  (test-filter   #f)
  (filter-prev-values (make-hash-table))
  ;; mapped paths - updating the tree object can be slow, track the paths applied here
  (mapped-paths  (make-hash-table))
  config
  reset-fn
  )

(define pkt-spec
  '((person   . ((app      . a)
		 (name     . n)
		 (location . l)))     ;; location or domainname
    (tslot    . ((app      . a)       ;; app name, always tnl for teach and learn
		 (person   . p)
		 (datetime . d)	     
		 (tutor    . t)))    
    (subject  . ((app      . a)	     







|







|







73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
  (sessions-matrix #f)
  ;; filters
  (bundle-filter #f)
  (area-filter   #f)
  (target-filter #f)
  (run-name-filter #f)
  (test-filter   #f)
  (filter-prev-values (make-hash-table))l
  ;; mapped paths - updating the tree object can be slow, track the paths applied here
  (mapped-paths  (make-hash-table))
  config
  reset-fn
  )

(define pkt-spec
  '(#;(person   . ((app      . a)
		 (name     . n)
		 (location . l)))     ;; location or domainname
    (tslot    . ((app      . a)       ;; app name, always tnl for teach and learn
		 (person   . p)
		 (datetime . d)	     
		 (tutor    . t)))    
    (subject  . ((app      . a)	     

Changes to multiapp/src/sync.scm.

12
13
14
15
16
17
18











19
20
21
22
23
24
25
26
27
28
29
30
31
32


















































33
34
(declare (unit sync))


(module sync
	*
(import scheme chicken data-structures)












;; for all pkts local but NOT del pkts
;;    if mine
;;       if not exists remote
;;           copy it to remote
;;    else
;;       if not exists remote
;;           remote from local
;; for all pkts remote
;;    if mine
;;       if not exists local
;;           remote from remote
;;       else
;;           if not exists local
;;             copy to local



















































)







>
>
>
>
>
>
>
>
>
>
>






|



|



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|

12
13
14
15
16
17
18
19
20
21
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
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
(declare (unit sync))


(module sync
	*
(import scheme chicken data-structures)

(use (prefix pkts pkts:) posix srfi-69 extras files)

;; (pkts:pkt->alist pkt pktspec: pkt-spec)

(define (path->pktid path)
  (pathname-strip-extension
   (pathname-file path)))

(define (read-pkt-as-alist fname pkt-spec)
  (pkts:pkt->alist (with-input-from-file fname read-string) pktspec: pkt-spec))
  
;; for all pkts local but NOT del pkts
;;    if mine
;;       if not exists remote
;;           copy it to remote
;;    else
;;       if not exists remote
;;           remove from local
;; for all pkts remote
;;    if mine
;;       if not exists local
;;           remove from remote
;;       else
;;           if not exists local
;;             copy to local
;;
;; returns success errmsg
(define (sync-all local remote user-id pkt-spec)
  (cond
   ((not (file-exists? local)) (values #f (conc "local pkts dir, " local ", not found")))
   ((not (file-exists? remote))(values #f (conc "remote pkts dir, " remote ", not found")))
   (else
    (let* ((process-paths (lambda (pths ht)
			    (map (lambda (p)
				   (hash-table-set! ht (path->pktid p) p))
				 pths)))
	   (local-pkts    (make-hash-table))  ;; pktuuid => path
	   (remote-pkts   (make-hash-table))  ;; pktuuid => path
	   (local-fnames  (glob (conc local "/*.pkt")))
	   (remote-fnames (glob (conc remote "/.pkt"))))
      (process-paths local-fnames local-pkts)
      (process-paths remote-fnames remote-pkts)
      ;; first process all locally known pkts
      (for-each
       (lambda (local-key)
	 ;; packet not in remote
	 (if (not (hash-table-exists? remote-pkts local-key))
	     (let* ((apkt   (read-pkt-as-alist (hash-table-ref local-pkts local-key) pkt-spec))
		    (owner  (alist-ref 'person apkt))
		    (ptype  (alist-ref 'T apkt))
		    (rawp   (alist-ref 'pkt apkt)))
	       (cond
		((equal? owner user-id) ;; my pkt, copy it to remote
		 (with-output-to-file (conc remote "/" local-key ".pkt")
		   (lambda ()(write rawp))))
		(else ;; file is now gone from remote and it is not mine
		 (delete-file (hash-table-ref local-pkts local-key)))))))
       (hash-table-keys local-pkts))
      ;; next process all remotely known pkts
      (for-each
       (lambda (remote-key)
	 (if (not (hash-table-exists? local-pkts remote-key))
	     ;; remote pkt not found locally
	     (let* ((apkt (read-pkt-as-alist (hash-table-ref remote-pkts remote-key) pkt-spec))
		    (owner (alist-ref 'person apkt))
		    (ptype (alist-ref 'T apkt))
		    (rawp  (alist-ref 'pkt apkt)))
	       (cond
		((equal? owner user-id)
		 (delete-file (hash-table-ref remote-pkts remote-key)))
		(else
		 (with-output-to-file (conc local "/" remote-key ".pkt")
		   (lambda ()
		     (write rawp))))))))
       (hash-table-keys remote-pkts))))))
	   
)