Megatest

Changes On Branch 07fcd3d7a36c338c
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Hide Diff Patch Side-by-Side Diff

Changes In Branch v1.6569-newdiet Through [07fcd3d7a3] Excluding Merge-Ins

This is equivalent to a diff from 80a01976f7 to 07fcd3d7a3

2021-03-09
18:45
merged v1.65-real-button-img check-in: 7a3804ade8 user: mmgraham tags: v1.65-real
2021-03-06
21:28
Added img to buttons for GTK3 change check-in: c350a6b24f user: matt tags: v1.65-real-button-img
04:39
Try a grounds-up switch to chicken-5 check-in: 101ee7c52b user: matt tags: v1.65-real-chicken-5
2021-02-26
07:43
Start from low load node and add diet one by one From: f462c25d37b9b9f978673390d0906efa6dbed868 User: matt check-in: 1706e8d4fe user: matt tags: v1.65-diet2-cm1 (unpublished)
07:37
Partial work on fixing rerun From: b5b72d675da2eba5c01850ea653e0451706a04c2 User: mrwellan check-in: 3c92e0ef5f user: matt tags: v1.65-rerun-fixes-cm1 (unpublished)
2021-02-25
23:22
eval-string-in-environment if was disabled, re-enabled From: 9564772564650055d045983029236da1cf850ca7 User: matt check-in: cc82a07623 user: matt tags: v1.65-real-reenable-eval-if (unpublished)
23:12
Working on ulex again From: 1db1be496dd6a3b45eb72b3be1dd6a921509edfc User: matt check-in: cef3d0f7a8 user: matt tags: v1.65-real-ulex (unpublished)
22:24
rebased lazy-queue rollup From: 07ab120544e101aafc5dd80650cb243bb7f5ff4e User: matt check-in: df4852aa6d user: matt tags: v1.65-lazyqueue-items-rollup-2 (unpublished)
21:48
begin diet From: badd71f3b34a7dc4f4bdf120b79438d403fd0733 User: matt check-in: c556f6d31c user: matt tags: v1.6569-diet-3 (unpublished)
21:39
Merged diet2 and fixed wrong use of optional (should be key). From: 8a73112be852c6b8910157005985773a412cf768 User: matt check-in: 08108473c8 user: matt tags: v1.6569-diet-2 (unpublished)
16:24
begin diet From: badd71f3b34a7dc4f4bdf120b79438d403fd0733 User: matt check-in: 28303029ea user: matt tags: v1.6569-new-diet (unpublished)
16:02
begin diet From: badd71f3b34a7dc4f4bdf120b79438d403fd0733 User: matt Closed-Leaf check-in: 867f012792 user: matt tags: v1.6569-newdiet
16:01
Restoring test_records.scm, not quite able to get rid of it yet. From: 24a028a1722528811637cd277f1d911b6ce6b79b User: matt check-in: 07fcd3d7a3 user: matt tags: v1.6569-newdiet
16:00
Couple unused functions From: 7ef4e75485c86fd03913be6075df8dbc5a266771 User: matt check-in: 74793670c5 user: matt tags: v1.6569-newdiet
15:46
Create new branch named "v1.6569-newdiet" check-in: d0d7abb726 user: matt tags: v1.6569-newdiet
15:46
Missing dep. check-in: 80a01976f7 user: matt tags: v1.65-real
2021-02-15
20:34
Oops. Dropped a function. Added it back... check-in: 405c573a88 user: matt tags: v1.65-real

Modified Makefile from [eb444dcd26] to [ee3ee268fa].

︙
170
171
172
173
174
175
176


177
178
179
180
181
182
183

170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185








+
+








runs.o : test_records.scm

megatest.o : megatest-fossil-hash.scm megatest-version.scm

rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm

common_records.scm : altdb.scm

runs.o tests.o : test_records.scm

# mofiles/stml2.o : mofiles/cookie.o
# configf.o : mofiles/commonmod.o

vg.o dashboard.o : vg_records.scm megatest-version.scm

dcommon.o : run_records.scm
︙

Modified archive.scm from [35b9e5966e] to [318f092a8a].

︙
29
30
31
32
33
34
35
36

37
38
39
40
41
42
43

29
30
31
32
33
34
35

36
37
38
39
40
41
42
43








-
+









;;======================================================================
;; 
;;======================================================================

;; NOT CURRENTLY USED
;;
(define (archive:main linktree target runname testname itempath options)
#;(define (archive:main linktree target runname testname itempath options)
  (let ((testdir (conc linktree "/" target "/" runname "/" testname "/" itempatt))
	(flavor  'plain) ;; type of machine to run jobs on
	(maxload 1.5)   ;; max allowed load for this work
	(adisks  (archive:get-archive-disks)))
    ;; get testdir size
    ;;   - hand off du to job mgr
    (if (and (common:file-exists? testdir)
︙
387
388
389
390
391
392
393
394

395
396
397
398
399
400
401

387
388
389
390
391
392
393

394
395
396
397
398
399
400
401








-
+








                              (debug:print-error 0 *default-log-port* "There was an error archiving data with bup. Archive failed.")
                              (exit 1))
                             (debug:print-info 0 *default-log-port* "To restore megatest.db run megatest -archive replicacte-db -source archive-dir -time-stamp <ts>. Current timestamp: " (seconds->std-time-str (current-seconds))))))) 
               (else
                   (debug:print-info 0 *default-log-port* "No support for databse archiving with " archiver)))
               (debug:print-error 0 *default-log-port* "There was an error rsyncing tmp database")))))

(define (archive:restore-db archive-path ts)
#;(define (archive:restore-db archive-path ts)
   (let* ((bup-exe               (or (configf:lookup *configdat* "archive" "bup") "bup"))
         (archive-internal-path (conc (common:get-testsuite-name) "-megatest-db/" ts "/megatest.db" ))
         (bup-restore-params  (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path)))
		 (debug:print-info 2 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path)
		 (run-n-wait bup-exe params: bup-restore-params print-cmd: "Running:"))
      (sleep 2)
      (db:multi-db-sync
︙

Modified client.scm from [dc4c7b41e8] to [bed3bdf664].

︙
29
30
31
32
33
34
35
36
37


38
39
40
41
42
43
44

29
30
31
32
33
34
35


36
37
38
39
40
41
42
43
44








-
-
+
+








(declare (uses common))
(declare (uses db))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.

(include "common_records.scm")
(include "db_records.scm")

;; client:get-signature
(define (client:get-signature)
;; client:get-signature, not used right now but likely needed
#;(define (client:get-signature)
  (if *my-client-signature* *my-client-signature*
      (let ((sig (conc (get-host-name) " " (current-process-id))))
	(set! *my-client-signature* sig)
	*my-client-signature*)))

;; Not currently used! But, I think it *should* be used!!!
#;(define (client:logout serverdat)
︙

Deleted codescanlib.scm version [6e625610ce]. 

1
2
3
4
5
6
7
8
9
10
11
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
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144


















































































































































-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-

;;  Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest 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 General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

;; gotta compile with csc, doesn't work with csi -s for whatever reason

(use srfi-69)
(use matchable)
(use utils)
(use ports)
(use extras)
(use srfi-1)
(use posix)
(use srfi-12)

;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define (<procname> <args>) <body> )
(define (load-scm-file scm-file)
  ;;(print "load "scm-file)
  (handle-exceptions
   exn
   '()
   (with-input-from-string
       (conc "("
             (with-input-from-file scm-file read-all)
             ")" )
     read)))

;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file
;;   -- be advised:
;;      * this may be fooled by macros, since this code does not take them into account.
;;      * this code does only checks for form (define (<procname> ... ) <body>)
;;           so it excludes from reckoning
;;               - generated functions, as in things like foo-set! from defstructs,
;;               - define-inline, (
;;               - define procname (lambda ..
;;               - etc...
(define (get-toplevel-procs+file+args+body filename)
  (let* ((scm-tree (load-scm-file filename))
         (procs
          (filter identity
                  (map
                   (match-lambda 
                    [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ...
                    [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ...
                    [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ...
                    [('define (defname args ...) body ...) ;; match (define (procname <args>) <body>)
                     (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??)
                         (list defname filename args body)
                         #f)]
                    [else #f] ) scm-tree))))
    procs))


;; given a sexp, return a flat list of atoms in that sexp
(define (get-atoms-in-body body)
  (cond
   ((null? body) '())
   ((atom? body) (list body))
   (else
    (apply append (map get-atoms-in-body body)))))

;;  given a file, return a list of procname, file, list of atoms in said procname
(define (get-procs+file+atoms file)
  (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file))
         (res
          (map
           (lambda (item)
             (let* ((proc (car item))
                    (file (cadr item))
                    (args (caddr item))
                    (body (cadddr item))
                    (atoms (append (get-atoms-in-body args) (get-atoms-in-body body))))
               (list proc file atoms)))
           toplevel-proc-items)))
    res))

;; uniquify a list of atoms 
(define (unique-atoms lst)
  (let loop ((lst (flatten lst)) (res '()))
    (if (null? lst)
        (reverse res)
        (let ((c (car lst)))
          (loop (cdr lst) (if (member c res) res (cons c res)))))))

;; given a list of procname, filename, list of procs called from procname, cross reference and reverse
;; returning alist mapping procname to procname that calls said procname
(define (get-callers-alist all-procs+file+calls)
  (let* ((all-procs (map car all-procs+file+calls))
         (caller-ht (make-hash-table))) 
    ;; let's cross reference with a hash table
    (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs)
    (for-each (lambda (item)
               (let* ((proc (car item))
                      (file (cadr item))
                      (calls (caddr item)))
                 (for-each (lambda (callee)
                             (hash-table-set! caller-ht callee
                                              (cons proc
                                                    (hash-table-ref caller-ht callee))))
                           calls)))
              all-procs+file+calls)
    (map (lambda (x)
           (let ((k (car x))
                 (r (unique-atoms (cdr x))))
             (cons k r)))                    
         (hash-table->alist caller-ht))))

;; create a handy cross-reference of callees to callers in the form of an alist.
(define (get-xref all-scm-files)
  (let* ((all-procs+file+atoms
          (apply append (map get-procs+file+atoms all-scm-files)))
         (all-procs (map car all-procs+file+atoms))
         (all-procs+file+calls  ; proc calls things in calls list
          (map (lambda (item)
                 (let* ((proc (car item))
                        (file (cadr item))
                        (atoms (caddr item))
                        (calls
                         (filter identity
                                 (map
                                  (lambda (x)
                                    (if (and ;; (not (equal? x proc))  ;; uncomment to prevent listing self
                                         (member x all-procs))
                                        x
                                        #f))
                                  atoms))))
                   (list proc file calls)))
               all-procs+file+atoms))
         (callers (get-callers-alist all-procs+file+calls))) 
    callers))

Modified common.scm from [82673dacdb] to [fdeca0aaad].

︙
661
662
663
664
665
666
667
668

669
670
671
672
673

674
675
676
677
678
679
680

661
662
663
664
665
666
667

668
669
670
671
672

673
674
675
676
677
678
679
680








-
+




-
+








	  (sparse-vector-set! new-row y val)))))

;;======================================================================
;; L O C K E R S   A N D   B L O C K E R S 
;;======================================================================

;; block further accesses to databases. Call this before shutting db down
(define (common:db-block-further-queries)
#;(define (common:db-block-further-queries)
  (mutex-lock! *db-access-mutex*)
  (set! *db-access-allowed* #f)
  (mutex-unlock! *db-access-mutex*))

(define (common:db-access-allowed?)
#;(define (common:db-access-allowed?)
  (let ((val (begin
	       (mutex-lock! *db-access-mutex*)
	       *db-access-allowed*
	       (mutex-unlock! *db-access-mutex*))))
    val))

;;======================================================================
︙
2625
2626
2627
2628
2629
2630
2631
2632

2633
2634
2635
2636
2637
2638
2639

2625
2626
2627
2628
2629
2630
2631

2632
2633
2634
2635
2636
2637
2638
2639








-
+








	 (sort (hash-table-keys directories) (lambda (a b)(> (string-length a)(string-length b))))))
    ))

;;======================================================================
;; E N V I R O N M E N T   V A R S
;;======================================================================

(define (bb-check-path #!key (msg "check-path: "))
#;(define (bb-check-path #!key (msg "check-path: "))
  (let ((path (or (get-environment-variable "PATH") "none")))
    (debug:print-info 0 *default-log-port* (conc msg" : $PATH="path))
    (if (string-match "^.*/isoenv-core/.*" path)
        (debug:print-error 0 *default-log-port* (conc msg" : !!ISOENV PRESENT!!")) ;; remove for prod
        (debug:print-info 1 *default-log-port* (conc msg" : **no isoenv present**")))))
	      
(define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF" "MAKEOVERRIDES")))
︙
3609
3610
3611
3612
3613
3614
3615
3616
3617


3618
3619

3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639

3640
3641
3642
3643
3644
3645
3646

3609
3610
3611
3612
3613
3614
3615


3616
3617
3618

3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638

3639
3640
3641
3642
3643
3644
3645
3646








-
-
+
+

-
+



















-
+








	     (begin
	       (debug:print 0 *default-log-port* "joining threads failed. exn=" exn)
               #t) ;; just ignore it, it might have died in the meantime so joining it will throw an exception
             (thread-join! thread))
           )))
   (hash-table-keys *common:thread-punchlist*)))

;;======================================================================
;; (define *common:telemetry-log-state* 'startup)
#;(define *common:telemetry-log-state* 'startup)
#;(define *common:telemetry-log-socket* #f)
;; (define *common:telemetry-log-socket* #f)
;; 
#;(define (common:telemetry-log-open)
;; (define (common:telemetry-log-open)
;;   (if (eq? *common:telemetry-log-state* 'startup)
;;       (let* ((serverhost (configf:lookup *configdat* "telemetry" "host"))
;;              (serverport (configf:lookup-number *configdat* "telemetry" "port"))
;;              (user (or (get-environment-variable "USER") "unknown"))
;;              (host (or (get-environment-variable "HOST") "unknown")))
;;         (set! *common:telemetry-log-state*
;;               (handle-exceptions
;;                exn
;;                (begin
;;                  (debug:print-info 0 *default-log-port* "common-telemetry-log open udp port failure")
;;                  'broken)
;;                (if (and serverhost serverport user host)
;;                    (let* ((s (udp-open-socket)))
;;                      ;;(udp-bind! s #f 0)
;;                      (udp-connect! s serverhost serverport)
;;                      (set! *common:telemetry-log-socket* s)
;;                      'open)
;;                    'not-needed))))))
;;   
#;(define (common:telemetry-log event #!key (payload '()))
;; (define (common:telemetry-log event #!key (payload '()))
;;   (if (eq? *common:telemetry-log-state* 'startup)
;;       (common:telemetry-log-open))
;; 
;;   (if (eq? 'open *common:telemetry-log-state*)
;;       (handle-exceptions
;;        exn
︙
3659
3660
3661
3662
3663
3664
3665
3666

3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679

3659
3660
3661
3662
3663
3664
3665

3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679








-
+














;;                   (payload-serialized
;;                    (base64:base64-encode
;;                     (z3:encode-buffer
;;                      (with-output-to-string (lambda () (pp payload))))))
;;                   (msg     (conc user":"host":"start":"(current-process-id)":"(car (argv))":"
;;                                  toppath":"payload-serialized)))
;;              (udp-send *common:telemetry-log-socket* msg))))))
;;   
#;(define (common:telemetry-log-close)
;; (define (common:telemetry-log-close)
;;   (when (or (member *common:telemetry-log-state* '(broken-or-no-server-preclose open)) *common:telemetry-log-socket*)
;;     (handle-exceptions
;;      exn
;;      (begin
;;        (define *common:telemetry-log-state* 'closed-fail)
;;        (debug:print-info 0 *default-log-port* "common-telemetry-log closure failure")
;;        )
;;      (begin
;;        (define *common:telemetry-log-state* 'closed)
;;        (udp-close-socket *common:telemetry-log-socket*)
;;        (set! *common:telemetry-log-socket* #f)))))

Added danglers-to-ignore.txt version [b2a2845e76]. 






1
2
3
4

+
+
+
+

spublish:lst->path
megatest-param->mtutil-param
add-target-mapper
add-runname-mapper








Modified dashboard-guimonitor.scm
from [9920d4908c]
to [03f2c3c501].




︙


169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184









185
186
187
188
189
190
191

169
170
171
172
173
174
175









176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191








-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+








    (iup:show topdialog)
    (iup:callback-set! *tim* "ACTION_CB"
		       (lambda (x)
			 (refreshdat)
			 (if *exit-started*
			     (set! *exit-started* 'ok))))))

(define (main-window setuptab fsltab collateraltab toolstab)
  (iup:show
   (iup:dialog #:title "FSL Power Window" #:size "290x190" ; #:expand "YES"
               (let ((tabtop (iup:tabs setuptab collateraltab fsltab toolstab)))
                 (iup:attribute-set! tabtop "TABTITLE0" "Setup") 
                 (iup:attribute-set! tabtop "TABTITLE1" "Collateral")
                 (iup:attribute-set! tabtop "TABTITLE2" "Fossil")
                 (iup:attribute-set! tabtop "TABTITLE3" "Tools")
                 tabtop))))
;; (define (main-window setuptab fsltab collateraltab toolstab)
;;   (iup:show
;;    (iup:dialog #:title "FSL Power Window" #:size "290x190" ; #:expand "YES"
;;                (let ((tabtop (iup:tabs setuptab collateraltab fsltab toolstab)))
;;                  (iup:attribute-set! tabtop "TABTITLE0" "Setup") 
;;                  (iup:attribute-set! tabtop "TABTITLE1" "Collateral")
;;                  (iup:attribute-set! tabtop "TABTITLE2" "Fossil")
;;                  (iup:attribute-set! tabtop "TABTITLE3" "Tools")
;;                  tabtop))))

;; BUG: Remember to re-instate this!!!!
;; (on-exit (lambda ()
;; 	   (let ((tdb (tasks:open-db)))
;; 	     ;; (print "On-exit called")
;; 	     (tasks:remove-monitor-record tdb)
;; 	     (sqlite3:finalize! tdb))))




︙







Modified dashboard.scm
from [065c30d7e0]
to [195dd92137].




︙


349
350
351
352
353
354
355
356

357
358
359
360
361
362
363

349
350
351
352
353
354
355

356
357
358
359
360
361
362
363








-
+








  ;; runs summary view
  
  tests-tree       ;; used in newdashboard
  )

;; register tabdat with BBpp
;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle
(hash-table-set! *BBpp_custom_expanders_list* TABDAT:
#;(hash-table-set! *BBpp_custom_expanders_list* TABDAT:
                 (cons dboard:tabdat?
                       (lambda (tabdat-item)
                         (filter
                          (lambda (alist-entry)
                            (member (car alist-entry)
                                    '(allruns-by-id allruns))) ;; FIELDS OF INTEREST
                          (dboard:tabdat->alist tabdat-item)))))




︙


499
500
501
502
503
504
505
506

507
508
509
510
511
512
513

499
500
501
502
503
504
505

506
507
508
509
510
511
512
513








-
+








  status
  start-time
  duration
  )

;; register dboard:rundat with BBpp
;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle
(hash-table-set! *BBpp_custom_expanders_list* RUNDAT:
#;(hash-table-set! *BBpp_custom_expanders_list* RUNDAT:
                 (cons dboard:rundat?
                       (lambda (tabdat-item)
                         (filter
                          (lambda (alist-entry)
                            (member (car alist-entry)
                                    '(run run-data-offset ))) ;; FIELDS OF INTEREST
                          (dboard:rundat->alist tabdat-item)))))




︙







Added datashare-src/datashare.scm version [2c1663032f].





























































































































































































































































































































































































































































































































































































































































































































































































































































1
2
3
4
5
6
7
8
9
10
11
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
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
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
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
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
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
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
545
546
547
548
549
550
551
552
553
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
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
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
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+


;; Copyright 2006-2013, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest 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 General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

(use ssax)
(use sxml-serializer)
(use sxml-modifications)
(use regex)
(use srfi-69)
(use regex-case)
(use posix)
(use json)
(use csv)
(use srfi-18)
(use format)

(require-library iup)
(import (prefix iup iup:))
(require-library ini-file)
(import (prefix ini-file ini:))

(use canvas-draw)
(import canvas-draw-iup)

(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))

(declare (uses configf))
(declare (uses tree))
(declare (uses margs))
;; (declare (uses dcommon))
;; (declare (uses launch))
;; (declare (uses gutils))
;; (declare (uses db))
;; (declare (uses synchash))
;; (declare (uses server))
;; (declare (uses megatest-version))
;; (declare (uses tbd))

(include "megatest-fossil-hash.scm")

;;
;; GLOBALS
;;
(define *datashare:current-tab-number* 0)
(define *args-hash* (make-hash-table))
(define datashare:help (conc "Usage: datashare [action [params ...]]

Note: run datashare without parameters to start the gui.

  list-areas                          : List the allowed areas

  list-versions <area>                : List versions available in <area>
         options : -full, -vpatt patt

  publish <path> <area> <version>     : Publish data for area and with version

  get <area> <version>                : Get a link to data, put the link in destpath
         options : -i iteration

  update <area>                       : Update the link to data to the latest iteration.

Part of the Megatest tool suite.
Learn more at http://www.kiatoa.com/fossils/megatest

Version: " megatest-fossil-hash)) ;; "

;;======================================================================
;; RECORDS
;;======================================================================

;; make-vector-record "testing" datastore pkg id area version_name store_type copied source_path iteration submitter datetime storegrp datavol quality disk_id comment
;; testing
(define (make-datashare:pkg)(make-vector 15))
(define-inline (datashare:pkg-get-id             vec)    (vector-ref  vec 0))
(define-inline (datashare:pkg-get-area           vec)    (vector-ref  vec 1))
(define-inline (datashare:pkg-get-version_name   vec)    (vector-ref  vec 2))
(define-inline (datashare:pkg-get-store_type     vec)    (vector-ref  vec 3))
(define-inline (datashare:pkg-get-copied         vec)    (vector-ref  vec 4))
(define-inline (datashare:pkg-get-source_path    vec)    (vector-ref  vec 5))
(define-inline (datashare:pkg-get-iteration      vec)    (vector-ref  vec 6))
(define-inline (datashare:pkg-get-submitter      vec)    (vector-ref  vec 7))
(define-inline (datashare:pkg-get-datetime       vec)    (vector-ref  vec 8))
(define-inline (datashare:pkg-get-storegrp       vec)    (vector-ref  vec 9))
(define-inline (datashare:pkg-get-datavol        vec)    (vector-ref  vec 10))
(define-inline (datashare:pkg-get-quality        vec)    (vector-ref  vec 11))
(define-inline (datashare:pkg-get-disk_id        vec)    (vector-ref  vec 12))
(define-inline (datashare:pkg-get-comment        vec)    (vector-ref  vec 13))
(define-inline (datashare:pkg-get-stored_path    vec)    (vector-ref  vec 14))
(define-inline (datashare:pkg-set-id!            vec val)(vector-set! vec 0 val))
(define-inline (datashare:pkg-set-area!          vec val)(vector-set! vec 1 val))
(define-inline (datashare:pkg-set-version_name!  vec val)(vector-set! vec 2 val))
(define-inline (datashare:pkg-set-store_type!    vec val)(vector-set! vec 3 val))
(define-inline (datashare:pkg-set-copied!        vec val)(vector-set! vec 4 val))
(define-inline (datashare:pkg-set-source_path!   vec val)(vector-set! vec 5 val))
(define-inline (datashare:pkg-set-iteration!     vec val)(vector-set! vec 6 val))
(define-inline (datashare:pkg-set-submitter!     vec val)(vector-set! vec 7 val))
(define-inline (datashare:pkg-set-datetime!      vec val)(vector-set! vec 8 val))
(define-inline (datashare:pkg-set-storegrp!      vec val)(vector-set! vec 9 val))
(define-inline (datashare:pkg-set-datavol!       vec val)(vector-set! vec 10 val))
(define-inline (datashare:pkg-set-quality!       vec val)(vector-set! vec 11 val))
(define-inline (datashare:pkg-set-disk_id!       vec val)(vector-set! vec 12 val))
(define-inline (datashare:pkg-set-comment!       vec val)(vector-set! vec 13 val))
(define-inline (datashare:pkg-set-stored_path!   vec val)(vector-set! vec 14 val))

;;======================================================================
;; DB
;;======================================================================

(define (datashare:initialize-db db)
  (for-each
   (lambda (qry)
     (sqlite3:execute db qry))
   (list 
    "CREATE TABLE pkgs 
         (id           INTEGER PRIMARY KEY,
          area         TEXT,
          version_name TEXT,
          store_type   TEXT DEFAULT 'copy',
          copied       INTEGER DEFAULT 0,
          source_path  TEXT,
          stored_path  TEXT,
          iteration    INTEGER DEFAULT 0,
          submitter    TEXT,
          datetime     TIMESTAMP DEFAULT (strftime('%s','now')),
          storegrp     TEXT,
          datavol      INTEGER,
          quality      TEXT,
          disk_id      INTEGER,
          comment      TEXT);"
    "CREATE TABLE refs
         (id        INTEGER PRIMARY KEY,
          pkg_id    INTEGER,
          destlink  TEXT);"
    "CREATE TABLE disks
         (id         INTEGER PRIMARY KEY,
          storegrp   TEXT,
          path       TEXT);")))

(define (datashare:register-data db area version-name store-type submitter quality source-path comment)
  (let ((iter-qry       (sqlite3:prepare db "SELECT max(iteration) FROM pkgs WHERE area=? AND version_name=?;"))
	(next-iteration 0))
    (sqlite3:with-transaction
     db
     (lambda ()
       (sqlite3:for-each-row
	(lambda (iteration)
	  (if (and (number? iteration)
		   (>= iteration next-iteration))
	      (set! next-iteration (+ iteration 1))))
	iter-qry area version-name)
       ;; now store the data
       (sqlite3:execute db "INSERT INTO pkgs (area,version_name,iteration,store_type,submitter,source_path,quality,comment) 
                                 VALUES (?,?,?,?,?,?,?,?);"
			area version-name next-iteration (conc store-type) submitter source-path quality comment)))
    (sqlite3:finalize! iter-qry)
    next-iteration))

(define (datashare:get-id db area version-name iteration)
  (let ((res #f))
    (sqlite3:for-each-row
     (lambda (id)
       (set! res id))
     db
     "SELECT id FROM pkgs WHERE area=? AND version_name=? AND iteration=?;"
     area version-name iteration)
    res))

(define (datashare:set-stored-path db id path)
  (sqlite3:execute db "UPDATE pkgs SET stored_path=? WHERE id=?;" path id))

(define (datashare:set-copied db id value)
  (sqlite3:execute db "UPDATE pkgs SET copied=? WHERE id=?;" value id))
  
(define (datashare:get-pkg-record db area version-name iteration)
  (let ((res #f))
    (sqlite3:for-each-row
     (lambda (a . b)
       (set! res (apply vector a b)))
     db 
     "SELECT * FROM pkgs WHERE area=? AND version_name=? AND iteration=?;"
     area 
     version-name
     iteration)
    res))

;; take version-name iteration and register or update "lastest/0"
;;
(define (datashare:set-latest db id area version-name iteration)
  (let* ((rec         (datashare:get-pkg-record db area version-name iteration))
	 (latest-id   (datashare:get-id db area "latest" 0))
	 (stored-path (datashare:pkg-get-stored_path rec)))
    (if latest-id ;; have a record - bump the link pointer
	(datashare:set-stored-path db latest-id stored-path)
	(datashare:register-data db area "latest" 'link "auto" "na" stored-path "latest data"))))

;; set a package ref, this is the location where the link back to the stored data 
;; is put. 
;;
;; if there is nothing at that location then the record can be removed
;; if there are no refs for a particular pkg-id then that pkg-id is a 
;; candidate for removal
;;
(define (datashare:record-pkg-ref db pkg-id dest-link)
  (sqlite3:execute db "INSERT INTO refs (pkg_id,destlink) VALUES (?,?);" pkg-id dest-link))
  
(define (datashare:count-refs db pkg-id)
  (let ((res 0))
    (sqlite3:for-each-row
     (lambda (count)
       (set! res count))
     db
     "SELECT count(id) FROM refs WHERE pkg_id=?;"
     pkg-id)
    res))

;; Create the sqlite db
(define (datashare:open-db configdat) 
  (let ((path (configf:lookup configdat "database" "location")))
    (if (and path
	     (directory? path)
	     (file-read-access? path))
	(let* ((dbpath    (conc path "/datashare.db"))
	       (writeable (file-write-access? dbpath))
	       (dbexists  (common:file-exists? dbpath))
	       (handler   (make-busy-timeout 136000)))
	  (handle-exceptions
	   exn
	   (begin
	     (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath
			  ((condition-property-accessor 'exn 'message) exn))
	     (exit))
	   (set! db (sqlite3:open-database dbpath)))
	  (if *db-write-access* (sqlite3:set-busy-handler! db handler))
	  (if (not dbexists)
	      (begin
		(datashare:initialize-db db)))
	  db)
	(print "ERROR: invalid path for storing database: " path))))

(define (open-run-close-exception-handling proc idb . params)
  (handle-exceptions
   exn
   (let ((sleep-time (random 30))
         (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
     (case err-status
       ((busy)
        (thread-sleep! sleep-time))
       (else
        (print "EXCEPTION: database overloaded or unreadable.")
        (print " message: " ((condition-property-accessor 'exn 'message) exn))
        (print "exn=" (condition->list exn))
        (print " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
        (print-call-chain (current-error-port))
        (thread-sleep! sleep-time)
        (print "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
     (apply open-run-close-exception-handling proc idb params))
   (apply open-run-close-no-exception-handling proc idb params)))

(define (open-run-close-no-exception-handling  proc idb . params)
  ;; (print "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
  (let* ((db (cond
	      ((sqlite3:database? idb)     idb)
	      ((not idb)                   (print "ERROR: cannot open-run-close with #f anymore"))
	      ((procedure? idb)            (idb))
	      (else                        (print "ERROR: cannot open-run-close with #f anymore"))))
	 (res #f))
    (set! res (apply proc db params))
    (if (not idb)(sqlite3:finalize! dbstruct))
    ;; (print "open-run-close-no-exception-handling END" )
    res))

(define open-run-close open-run-close-no-exception-handling)

(define (datashare:get-pkgs db area-filter version-filter iter-filter)
  (let ((res '()))
    (sqlite3:for-each-row ;; replace with fold ...
     (lambda (a . b)
       (set! res (cons (list->vector (cons a b)) res)))
     db 
     (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path "
	   " FROM pkgs WHERE area like ? AND version_name LIKE ? AND iteration " iter-filter ";")
     area-filter version-filter)
    (reverse res)))

(define (datashare:get-pkg db area-name version-name #!key (iteration #f))
  (let ((dat '())
	(res #f))
    (sqlite3:for-each-row ;; replace with fold ...
     (lambda (a . b)
       (set! dat (cons (list->vector (cons a b)) dat)))
     db 
     (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path "
	   " FROM pkgs WHERE area=? AND version_name=? ORDER BY iteration ASC;")
     area-name version-name)
    ;; now filter for iteration, either max if #f or specific one
    (if (null? dat)
	#f
	(let loop ((hed (car dat))
		   (tal (cdr dat))
		   (cur 0))
	  (let ((itr (datashare:pkg-get-iteration hed)))
	    (if (equal? itr iteration) ;; this is the one if iteration is specified
		hed
		(if (null? tal)
		    hed
		    (loop (car tal)(cdr tal)))))))))

(define (datashare:get-versions-for-area db area-name #!key (version-patt #f))
  (let ((res '())
	(data (make-hash-table)))
    (sqlite3:for-each-row
     (lambda (version-name submitter iteration submitted-time comment)
       ;;                                              0           1         2           3           4
       (hash-table-set! data version-name (vector version-name submitter iteration submitted-time comment)))
     db 
     "SELECT version_name,submitter,iteration,datetime,comment FROM pkgs WHERE area='megatest' AND version_name != 'latest' AND version_name LIKE ? ORDER BY datetime asc;"
     (or version-patt "%"))
    (map (lambda (x)(hash-table-ref data x))(sort (hash-table-keys data) string-ci>=))))

;;======================================================================
;; DATA IMPORT/EXPORT
;;======================================================================

(define (datashare:import-data configdat source-path dest-path area version iteration)
  (let* ((space-avail (car dest-path))
	 (disk-path   (cdr dest-path))
	 (targ-path   (conc disk-path "/" area "/" version "/" iteration))
	 (id          (datashare:get-id db area version iteration))
	 (db          (datashare:open-db configdat)))
    (if (> space-avail 10000) ;; dumb heuristic
	(begin
	  (create-directory targ-path #t)
	  (datashare:set-stored-path db id targ-path)
	  (print "Running command: rsync -av " source-path "/ " targ-path "/")
	  (let ((th1 (make-thread (lambda ()
				    (let ((pid (process-run "rsync" (list "-av" (conc source-path "/") (conc targ-path "/")))))
				      (process-wait pid)
				      (datashare:set-copied db id "yes")
				      (sqlite3:finalize! db)))
				   "Data copy")))
	    (thread-start! th1))
	  #t)
	(begin
	  (print "ERROR: Not enough space in storage area " dest-path)
	  (datashare:set-copied db id "no")
	  (sqlite3:finalize! db)
	  #f))))

(define (datashare:get-areas configdat)
  (let* ((areadat (configf:get-section configdat "areas"))
	 (areas   (if areadat (map car areadat) '())))
    areas))

(define (datashare:publish configdat publish-type area-name version comment spath submitter quality)
  ;; input checks
  (cond 
   ((not (member area-name (datashare:get-areas configdat)))
    (cons #f (conc "Illegal area name \"" area-name "\"")))
   (else
    (let ((db          (datashare:open-db configdat))
	  (iteration   (datashare:register-data db area-name version publish-type submitter quality spath comment))
	  (dest-store  (datashare:get-best-storage configdat)))
      (if iteration
	  (if (eq? 'copy publish-type)
	      (begin
		(datashare:import-data configdat spath dest-store area-name version iteration)
		(let ((id (datashare:get-id db area-name version iteration)))
		  (datashare:set-latest db id area-name version iteration)))
	      (let ((id (datashare:get-id db area-name version iteration)))
		(datashare:set-stored-path db id spath)
		(datashare:set-copied db id "yes")
		(datashare:set-copied db id "n/a")
		(datashare:set-latest db id area-name version iteration)))
	  (print "ERROR: Failed to get an iteration number"))
      (sqlite3:finalize! db)
      (cons #t "Successfully saved data")))))

(define (datashare:get-best-storage configdat)
  (let* ((storage     (configf:lookup configdat "settings" "storage"))
	 (store-areas (if storage (string-split storage) '())))
    (print "Looking for available space in " store-areas)
    (datashare:find-most-space store-areas)))

;; (string->number (list-ref (with-input-from-pipe "df -B1000000 /tmp" (lambda ()(read-line)(string-split (read-line)))) 3))

(define (datashare:find-most-space paths)
  (fold (lambda (area res)
	  ;; (print "area=" area " res=" res)
	  (let ((maxspace (car res))
		(currpath (cdr res)))
	    ;; (print currpath " " maxspace)
	    (if (file-write-access? area)
		(let ((currspace (string->number
				  (list-ref
				   (with-input-from-pipe 
				    ;; (conc "df --output=avail " area)
				    (conc "df -B1000000 " area)
				    ;; (lambda ()(read)(read))
				    (lambda ()(read-line)(string-split (read-line))))
				   3))))
		  (if (> currspace maxspace) 
		      (cons currspace area)
		      res))
		res)))
	(cons 0 #f)
	paths))

;; remove existing link and if possible ...
;; create path to next of tip of target, create link back to source
(define (datashare:build-dir-make-link source target)
  (if (common:file-exists? target)(datashare:backup-move target))
  (create-directory (pathname-directory target) #t)
  (create-symbolic-link source target))

(define (datashare:backup-move path)
  (let* ((trashdir  (conc (pathname-directory path) "/.trash"))
	 (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path))))
    (create-directory trashdir #t)
    (if (directory? path)
	(system (conc "mv " path " " trashfile))
	(file-move path trash-file))))

;;======================================================================
;; GUI
;;======================================================================

;; The main menu 
(define (datashare:main-menu)
  (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top)
   (iup:menu-item "Files" (iup:menu   ;; Note that you can use either #:action or action: for options
		       (iup:menu-item "Open"  action: (lambda (obj)
							(iup:show (iup:file-dialog))
							(print "File->open " obj)))
		       (iup:menu-item "Save"  #:action (lambda (obj)(print "File->save " obj)))
		       (iup:menu-item "Exit"  #:action (lambda (obj)(exit)))))
   (iup:menu-item "Tools" (iup:menu
		       (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah")))
		       ;; (iup:menu-item "Show dialog"     #:action (lambda (obj)
		       ;;  					   (show message-window
		       ;;  					     #:modal? #t
		       ;;  					     ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
		       ;;  					     ;; #:x 'mouse
		       ;;  					     ;; #:y 'mouse
		       ;;  )					     
		       ))))

(define (datashare:publish-view configdat)
  ;; (pp (hash-table->alist configdat))
  (let* ((areas       (configf:get-section configdat "areas"))
	 (label-size  "70x")
	 (areas-sel   (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES"))
	 (version-tb  (iup:textbox #:expand "HORIZONTAL")) ;;  #:size "50x"))
	 (areas-sel   (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES"))
	 (component   (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" ))
	 (version-val (iup:textbox #:expand "HORIZONTAL" #:size "50x"))
	 ;; (copy-link   (iup:toggle  #:expand "HORIZONTAL"))
	 ;; (iteration   (iup:textbox #:expand "YES" #:size "20x"))
	 ;; (iteration   (iup:textbox #:expand "HORIZONTAL" #:size "20x"))
	 (area-filter (iup:textbox #:expand "HORIZONTAL" #:value "%"))
	 (comment-tb  (iup:textbox #:expand "YES" #:multiline "YES"))
	 (source-tb   (iup:textbox #:expand "HORIZONTAL"
				   #:value (or (configf:lookup configdat "settings" "basepath")
					       "")))
	 (publish     (lambda (publish-type)
			(let* ((area-num    (or (string->number (iup:attribute areas-sel "VALUE")) 0))
			       (area-dat    (if (> area-num 0)(list-ref areas (- area-num 1))'("NOT SELECTED" "NOT SELECTED")))
			       (area-path   (cadr area-dat))
			       (area-name   (car  area-dat))
			       (version     (iup:attribute version-tb "VALUE"))
			       (comment     (iup:attribute comment-tb "VALUE"))
			       (spath       (iup:attribute source-tb  "VALUE"))
			       (submitter   (current-user-name))
			       (quality     2))
			  (datashare:publish configdat publish-type area-name version comment spath submitter quality))))
	 (copy        (iup:button "Copy and Publish"
				  #:expand "HORIZONTAL"
				  #:action (lambda (obj)
					     (publish 'copy))))
	 (link        (iup:button "Link and Publish"
				  #:expand "HORIZONTAL"
				  #:action (lambda (obj)
					     (publish 'link))))
	 (browse-btn  (iup:button "Browse"
				  #:size "40x"
				  #:action (lambda (obj)
					     (let* ((fd  (iup:file-dialog #:dialogtype "DIR"))
						    (top (iup:show fd #:modal? "YES")))
					       (iup:attribute-set! source-tb "VALUE"
								   (iup:attribute fd "VALUE"))
					       (iup:destroy! fd))))))
    (print "areas")
    ;; (pp areas)
    (fold (lambda (areadat num)
	    ;; (print "Adding num=" num ", areadat=" areadat)
	    (iup:attribute-set! areas-sel (conc num) (car areadat))
	    (+ 1 num))
	  1 areas)
    (iup:vbox
     (iup:hbox (iup:label "Area:"        #:size label-size) ;; area-filter 
	       areas-sel)
     (iup:hbox (iup:label "Version:"     #:size label-size)   version-tb)
     ;; (iup:hbox (iup:label "Link only"    #:size label-size)   copy-link)
     ;; 	       (iup:label "Iteration:")   iteration)
     (iup:hbox (iup:label "Comment:"     #:size label-size)   comment-tb)
     (iup:hbox (iup:label "Source base path:" #:size label-size)   source-tb browse-btn)
     (iup:hbox copy link))))

(define (datashare:lst->path pathlst)
  (conc "/" (string-intersperse (map conc pathlst) "/")))

(define (datashare:path->lst path)
  (string-split path "/"))

(define (datashare:pathdat-apply-heuristics configdat path)
  (cond
   ((common:file-exists? path) "found")
   (else (conc path " not installed"))))

(define (datashare:get-view configdat)
  (iup:vbox
   (iup:hbox
    (let* ((label-size     "60x")
	   ;; filter elements
	   (area-filter    "%")
	   (version-filter "%")
	   (iter-filter    ">= 0")
	   ;; reverse lookup from path to data for src and installed
	   (srcdat         (make-hash-table)) ;; reverse lookup
	   (installed-dat  (make-hash-table))
	   ;; config values
	   (basepath       (configf:lookup configdat "settings" "basepath"))
	   ;; gui elements
	   (submitter      (iup:label "" #:expand "HORIZONTAL"))
	   (date-submitted (iup:label "" #:expand "HORIZONTAL"))
	   (comment        (iup:label "" #:expand "HORIZONTAL"))
	   (copy-link      (iup:label "" #:expand "HORIZONTAL"))
	   (quality        (iup:label "" #:expand "HORIZONTAL"))
	   (installed-status (iup:label "" #:expand "HORIZONTAL"))
	   ;; misc 
	   (curr-record    #f)
	   ;; (source-data    (iup:label "" #:expand "HORIZONTAL"))
	   (tb             (iup:treebox
			    #:value 0
			    #:name "Packages"
			    #:expand "YES"
			    #:addexpanded "NO"
			    #:selection-cb
			    (lambda (obj id state)
			      ;; (print "obj: " obj ", id: " id ", state: " state)
			      (let* ((path   (datashare:lst->path (cdr (tree:node->path obj id))))
				     (record (hash-table-ref/default srcdat path #f)))
				(if record
				    (begin
				      (set! curr-record record)
				      (iup:attribute-set! submitter      "TITLE" (datashare:pkg-get-submitter record))
				      (iup:attribute-set! date-submitted "TITLE" (time->string (seconds->local-time (datashare:pkg-get-datetime record))))
				      (iup:attribute-set! comment        "TITLE" (datashare:pkg-get-comment record))
				      (iup:attribute-set! quality        "TITLE" (datashare:pkg-get-quality record))
				      (iup:attribute-set! copy-link      "TITLE" (datashare:pkg-get-store_type record))
				      ))
				;; (print  "id=" id " path=" path " record=" record);; (tree:node->path obj id) " run-id: " run-id)
				))))
	   (tb2             (iup:treebox
			    #:value 0
			    #:name "Installed"
			    #:expand "YES"
			    #:addexpanded "NO"
			    #:selection-cb
			    (lambda (obj id state)
			      ;; (print "obj: " obj ", id: " id ", state: " state)
			      (let* ((path   (datashare:lst->path (cdr (tree:node->path obj id))))
				     (status (hash-table-ref/default installed-dat path #f)))
				(iup:attribute-set! installed-status "TITLE" (if status status ""))
				))))
	   (refresh        (lambda (obj)
			     (let* ((db    (datashare:open-db configdat))
				    (areas (or (configf:get-section configdat "areas") '())))
			       ;;
			       ;; first update the Sources
			       ;;
			       (for-each
				(lambda (pkgitem)
				  (let* ((pkg-path   (list (datashare:pkg-get-area  pkgitem)
							   (datashare:pkg-get-version_name pkgitem)
							   (datashare:pkg-get-iteration pkgitem)))
					 (pkg-id     (datashare:pkg-get-id          pkgitem))
					 (path       (datashare:lst->path pkg-path)))
				    ;; (print "tree:add-node tb=" tb ", pkg-path=" pkg-path ", pkg-id=" pkg-id)
				    (if (not (hash-table-ref/default srcdat path #f))
					(tree:add-node tb "Packages" pkg-path userdata: (conc "pkg-id: " pkg-id)))
				    ;; (print "path=" path " pkgitem=" pkgitem)
				    (hash-table-set! srcdat path pkgitem)))
				(datashare:get-pkgs db area-filter version-filter iter-filter))
			       ;;
			       ;; then update the installed
			       ;;
			       (for-each
				(lambda (area)
				  (let* ((path     (conc "/" (cadr area)))
					 (fullpath (conc basepath path)))
				    (if (not (hash-table-ref/default installed-dat path #f))
					(tree:add-node tb2 "Installed" (datashare:path->lst path)))
				    (hash-table-set! installed-dat path (datashare:pathdat-apply-heuristics configdat fullpath))))
				areas)
			       (sqlite3:finalize! db))))
	   (apply          (iup:button "Apply"
				       #:action
				       (lambda (obj)
					 (if curr-record
					     (let* ((area        (datashare:pkg-get-area        curr-record))
						    (stored-path (datashare:pkg-get-stored_path curr-record))
						    (source-type (datashare:pkg-get-store_type  curr-record))
						    (source-path (case source-type ;;  (equal? source-type "link"))
								   ((link)(datashare:pkg-get-source-path curr-record))
								   ((copy)stored-path)
								   (else #f)))
						    (dest-stub   (configf:lookup configdat "areas" area))
						    (target-path (conc basepath "/" dest-stub)))
					       (datashare:build-dir-make-link stored-path target-path)
					       (print "Creating link from " stored-path " to " target-path)))))))
      (iup:vbox 
       (iup:hbox tb tb2)
       (iup:frame 
	#:title "Source Info"
	(iup:vbox
	 (iup:hbox (iup:button "Refresh" #:action refresh) apply)
	 (iup:hbox (iup:label "Submitter: ") ;;  #:size label-size)
		   submitter 
		   (iup:label "Submitted on: ") ;;  #:size label-size)
		   date-submitted)
	 (iup:hbox (iup:label "Data stored: ")
		   copy-link
		   (iup:label "Quality: ")
		   quality)
	 (iup:hbox (iup:label "Comment: ")
		   comment)))
       (iup:frame
	#:title "Installed Info"
	(iup:vbox
	 (iup:hbox (iup:label "Installed status/path: ") installed-status)))
       )))))

(define (datashare:manage-view configdat)
  (iup:vbox
   (iup:hbox 
    (iup:button "Pushme"
		#:expand "YES"
		))))

(define (datashare:gui configdat)
  (iup:show
   (iup:dialog 
    #:title (conc "DataShare dashboard " (current-user-name) ":" (current-directory))   
    #:menu (datashare:main-menu)
    (let* ((tabs (iup:tabs
		  #:tabchangepos-cb (lambda (obj curr prev)
				      (set! *datashare:current-tab-number* curr))
		  (datashare:publish-view configdat)
		  (datashare:get-view configdat)
		  (datashare:manage-view configdat)
		  )))
	;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
	(iup:attribute-set! tabs "TABTITLE0" "Publish")
	(iup:attribute-set! tabs "TABTITLE1" "Get")
	(iup:attribute-set! tabs "TABTITLE2" "Manage")
	;; (iup:attribute-set! tabs "BGCOLOR" "190 190 190")
	tabs)))
  (iup:main-loop))

;;======================================================================
;; MISC
;;======================================================================


(define (datashare:do-as-calling-user proc)
  (let ((eid (current-effective-user-id))
        (cid (current-user-id)))
    (if (not (eq? eid cid)) ;; running suid
            (set! (current-effective-user-id) cid))
    ;; (print "running as " (current-effective-user-id))
    (proc)
    (if (not (eq? eid cid))
        (set! (current-effective-user-id) eid))))

(define (datashare:find name paths)
  (if (null? paths)
      #f
      (let loop ((hed (car paths))
		 (tal (cdr paths)))
	(if (common:file-exists? (conc hed "/" name))
	    hed
	    (if (null? tal)
		#f
		(loop (car tal)(cdr tal)))))))

;;======================================================================
;; MAIN
;;======================================================================

(define (datashare:load-config exe-dir exe-name)
  (let* ((fname   (conc exe-dir "/." exe-name ".config")))
    (ini:property-separator-patt " *  *")
    (ini:property-separator #\space)
    (if (common:file-exists? fname)
	;; (ini:read-ini fname)
	(read-config fname #f #t)
	(make-hash-table))))

(define (datashare:process-action configdat action . args)
  (case (string->symbol action)
    ((get)
     (if (< (length args) 2)
	 (begin 
	   (print "ERROR: Missing arguments; " (string-intersperse args ", "))
	   (exit 1))
	 (let* ((basepath    (configf:lookup configdat "settings" "basepath"))
		(db          (datashare:open-db configdat))
		(area        (car args))
		(version     (cadr args)) ;;    iteration
		(remargs     (args:get-args args '("-i") '() args:arg-hash 0))
		(iteration   (if (args:get-arg "-i")(string->number (args:get-arg "-i")) #f))
		(curr-record (datashare:get-pkg db area version iteration: iteration)))
	   (if (not curr-record)
	       (begin
		 (print "ERROR: No matching record found; area=" area ", version=" version ", iteration=" (if iteration iteration "(max)"))
		 (exit 1))
	       (let* ((stored-path (datashare:pkg-get-stored_path curr-record))
		      (source-type (datashare:pkg-get-store_type  curr-record))
		      (source-path (case source-type ;;  (equal? source-type "link"))
				     ((link) (datashare:pkg-get-source-path curr-record))
				     ((copy) stored-path)
				     (else #f)))
		      (dest-stub   (configf:lookup configdat "areas" area))
		      (target-path (conc basepath "/" dest-stub)))
		 (datashare:build-dir-make-link stored-path target-path)
		 (datashare:record-pkg-ref db (datashare:pkg-get-id curr-record) target-path)
		 (sqlite3:finalize! db)
		 (print "Creating link from " stored-path " to " target-path))))))
    ((publish)
     (if (< (length args) 3)
	 (begin 
	   (print "ERROR: Missing arguments; " (string-intersperse args ", "))
	   (exit 1))
	 (let* ((srcpath  (list-ref args 0))
		(areaname (list-ref args 1))
		(version  (list-ref args 2))
		(remargs  (args:get-args (drop args 2)
					 '("-type" ;; link or copy (default is copy)
					   "-m")
 					 '()
 					 args:arg-hash
 					 0))
		(publish-type (if (equal? (args:get-arg "-type") "link") 'link 'copy))
		(comment      (or (args:get-arg "-m") ""))
		(submitter    (current-user-name))
		(quality      (args:get-arg "-quality"))
		(publish-res  (datashare:publish configdat publish-type areaname version comment srcpath submitter quality)))
	   (if (not (car publish-res))
	       (begin
		 (print "ERROR: " (cdr publish-res))
		 (exit 1))))))
    ((list-versions)
     (let ((area-name (car args)) ;;      version patt   full print
	   (remargs   (args:get-args args '("-vpatt") '("-full") args:arg-hash 0))
	   (db        (datashare:open-db configdat))
	   (versions  (datashare:get-versions-for-area db (car args) version-patt: (args:get-arg "-vpatt"))))
       ;; (print "area-name=" area-name " args=" args " *args-hash*=" (hash-table->alist *args-hash*))
       (map (lambda (x)
	      (if (args:get-arg "-full")
		  (format #t 
			  "~10a~10a~4a~27a~30a\n"
			  (vector-ref x 0)
			  (vector-ref x 1) 
			  (vector-ref x 2) 
			  (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"")
			  (conc "\"" (vector-ref x 4) "\""))
		  (print (vector-ref x 0))))
	    versions)
       (sqlite3:finalize! db)))))

;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION!
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.datasharerc")))
  (if (common:file-exists? debugcontrolf)
      (load debugcontrolf)))

(define (main)
  (let* ((args      (argv))
	 (prog      (car args))
	 (rema      (cdr args))
	 (exe-name  (pathname-file (car (argv))))
	 (exe-dir   (or (pathname-directory prog)
			(datashare:find exe-name (string-split (get-environment-variable "PATH") ":"))))
	 (configdat (datashare:load-config exe-dir exe-name)))
    (cond
     ;; one-word commands
     ((eq? (length rema) 1)
      (case (string->symbol (car rema))
	((help -h -help --h --help)
	 (print datashare:help))
	((list-areas)
	 (map print (datashare:get-areas configdat)))
	(else
	 (print "ERROR: Unrecognised command. Try \"datashare help\""))))
     ;; multi-word commands
     ((null? rema)(datashare:gui configdat))
     ((>= (length rema) 2)
      (apply datashare:process-action configdat (car rema)(cdr rema)))
     (else (print "ERROR: Unrecognised command. Try \"datashare help\"")))))

(main)








Deleted datashare.scm version [2c1663032f].



1
2
3
4
5
6
7
8
9
10
11
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
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
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
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
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
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
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
545
546
547
548
549
550
551
552
553
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
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
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
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825



























































































































































































































































































































































































































































































































































































































































































































































































































































-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-


;; Copyright 2006-2013, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest 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 General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

(use ssax)
(use sxml-serializer)
(use sxml-modifications)
(use regex)
(use srfi-69)
(use regex-case)
(use posix)
(use json)
(use csv)
(use srfi-18)
(use format)

(require-library iup)
(import (prefix iup iup:))
(require-library ini-file)
(import (prefix ini-file ini:))

(use canvas-draw)
(import canvas-draw-iup)

(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))

(declare (uses configf))
(declare (uses tree))
(declare (uses margs))
;; (declare (uses dcommon))
;; (declare (uses launch))
;; (declare (uses gutils))
;; (declare (uses db))
;; (declare (uses synchash))
;; (declare (uses server))
;; (declare (uses megatest-version))
;; (declare (uses tbd))

(include "megatest-fossil-hash.scm")

;;
;; GLOBALS
;;
(define *datashare:current-tab-number* 0)
(define *args-hash* (make-hash-table))
(define datashare:help (conc "Usage: datashare [action [params ...]]

Note: run datashare without parameters to start the gui.

  list-areas                          : List the allowed areas

  list-versions <area>                : List versions available in <area>
         options : -full, -vpatt patt

  publish <path> <area> <version>     : Publish data for area and with version

  get <area> <version>                : Get a link to data, put the link in destpath
         options : -i iteration

  update <area>                       : Update the link to data to the latest iteration.

Part of the Megatest tool suite.
Learn more at http://www.kiatoa.com/fossils/megatest

Version: " megatest-fossil-hash)) ;; "

;;======================================================================
;; RECORDS
;;======================================================================

;; make-vector-record "testing" datastore pkg id area version_name store_type copied source_path iteration submitter datetime storegrp datavol quality disk_id comment
;; testing
(define (make-datashare:pkg)(make-vector 15))
(define-inline (datashare:pkg-get-id             vec)    (vector-ref  vec 0))
(define-inline (datashare:pkg-get-area           vec)    (vector-ref  vec 1))
(define-inline (datashare:pkg-get-version_name   vec)    (vector-ref  vec 2))
(define-inline (datashare:pkg-get-store_type     vec)    (vector-ref  vec 3))
(define-inline (datashare:pkg-get-copied         vec)    (vector-ref  vec 4))
(define-inline (datashare:pkg-get-source_path    vec)    (vector-ref  vec 5))
(define-inline (datashare:pkg-get-iteration      vec)    (vector-ref  vec 6))
(define-inline (datashare:pkg-get-submitter      vec)    (vector-ref  vec 7))
(define-inline (datashare:pkg-get-datetime       vec)    (vector-ref  vec 8))
(define-inline (datashare:pkg-get-storegrp       vec)    (vector-ref  vec 9))
(define-inline (datashare:pkg-get-datavol        vec)    (vector-ref  vec 10))
(define-inline (datashare:pkg-get-quality        vec)    (vector-ref  vec 11))
(define-inline (datashare:pkg-get-disk_id        vec)    (vector-ref  vec 12))
(define-inline (datashare:pkg-get-comment        vec)    (vector-ref  vec 13))
(define-inline (datashare:pkg-get-stored_path    vec)    (vector-ref  vec 14))
(define-inline (datashare:pkg-set-id!            vec val)(vector-set! vec 0 val))
(define-inline (datashare:pkg-set-area!          vec val)(vector-set! vec 1 val))
(define-inline (datashare:pkg-set-version_name!  vec val)(vector-set! vec 2 val))
(define-inline (datashare:pkg-set-store_type!    vec val)(vector-set! vec 3 val))
(define-inline (datashare:pkg-set-copied!        vec val)(vector-set! vec 4 val))
(define-inline (datashare:pkg-set-source_path!   vec val)(vector-set! vec 5 val))
(define-inline (datashare:pkg-set-iteration!     vec val)(vector-set! vec 6 val))
(define-inline (datashare:pkg-set-submitter!     vec val)(vector-set! vec 7 val))
(define-inline (datashare:pkg-set-datetime!      vec val)(vector-set! vec 8 val))
(define-inline (datashare:pkg-set-storegrp!      vec val)(vector-set! vec 9 val))
(define-inline (datashare:pkg-set-datavol!       vec val)(vector-set! vec 10 val))
(define-inline (datashare:pkg-set-quality!       vec val)(vector-set! vec 11 val))
(define-inline (datashare:pkg-set-disk_id!       vec val)(vector-set! vec 12 val))
(define-inline (datashare:pkg-set-comment!       vec val)(vector-set! vec 13 val))
(define-inline (datashare:pkg-set-stored_path!   vec val)(vector-set! vec 14 val))

;;======================================================================
;; DB
;;======================================================================

(define (datashare:initialize-db db)
  (for-each
   (lambda (qry)
     (sqlite3:execute db qry))
   (list 
    "CREATE TABLE pkgs 
         (id           INTEGER PRIMARY KEY,
          area         TEXT,
          version_name TEXT,
          store_type   TEXT DEFAULT 'copy',
          copied       INTEGER DEFAULT 0,
          source_path  TEXT,
          stored_path  TEXT,
          iteration    INTEGER DEFAULT 0,
          submitter    TEXT,
          datetime     TIMESTAMP DEFAULT (strftime('%s','now')),
          storegrp     TEXT,
          datavol      INTEGER,
          quality      TEXT,
          disk_id      INTEGER,
          comment      TEXT);"
    "CREATE TABLE refs
         (id        INTEGER PRIMARY KEY,
          pkg_id    INTEGER,
          destlink  TEXT);"
    "CREATE TABLE disks
         (id         INTEGER PRIMARY KEY,
          storegrp   TEXT,
          path       TEXT);")))

(define (datashare:register-data db area version-name store-type submitter quality source-path comment)
  (let ((iter-qry       (sqlite3:prepare db "SELECT max(iteration) FROM pkgs WHERE area=? AND version_name=?;"))
	(next-iteration 0))
    (sqlite3:with-transaction
     db
     (lambda ()
       (sqlite3:for-each-row
	(lambda (iteration)
	  (if (and (number? iteration)
		   (>= iteration next-iteration))
	      (set! next-iteration (+ iteration 1))))
	iter-qry area version-name)
       ;; now store the data
       (sqlite3:execute db "INSERT INTO pkgs (area,version_name,iteration,store_type,submitter,source_path,quality,comment) 
                                 VALUES (?,?,?,?,?,?,?,?);"
			area version-name next-iteration (conc store-type) submitter source-path quality comment)))
    (sqlite3:finalize! iter-qry)
    next-iteration))

(define (datashare:get-id db area version-name iteration)
  (let ((res #f))
    (sqlite3:for-each-row
     (lambda (id)
       (set! res id))
     db
     "SELECT id FROM pkgs WHERE area=? AND version_name=? AND iteration=?;"
     area version-name iteration)
    res))

(define (datashare:set-stored-path db id path)
  (sqlite3:execute db "UPDATE pkgs SET stored_path=? WHERE id=?;" path id))

(define (datashare:set-copied db id value)
  (sqlite3:execute db "UPDATE pkgs SET copied=? WHERE id=?;" value id))
  
(define (datashare:get-pkg-record db area version-name iteration)
  (let ((res #f))
    (sqlite3:for-each-row
     (lambda (a . b)
       (set! res (apply vector a b)))
     db 
     "SELECT * FROM pkgs WHERE area=? AND version_name=? AND iteration=?;"
     area 
     version-name
     iteration)
    res))

;; take version-name iteration and register or update "lastest/0"
;;
(define (datashare:set-latest db id area version-name iteration)
  (let* ((rec         (datashare:get-pkg-record db area version-name iteration))
	 (latest-id   (datashare:get-id db area "latest" 0))
	 (stored-path (datashare:pkg-get-stored_path rec)))
    (if latest-id ;; have a record - bump the link pointer
	(datashare:set-stored-path db latest-id stored-path)
	(datashare:register-data db area "latest" 'link "auto" "na" stored-path "latest data"))))

;; set a package ref, this is the location where the link back to the stored data 
;; is put. 
;;
;; if there is nothing at that location then the record can be removed
;; if there are no refs for a particular pkg-id then that pkg-id is a 
;; candidate for removal
;;
(define (datashare:record-pkg-ref db pkg-id dest-link)
  (sqlite3:execute db "INSERT INTO refs (pkg_id,destlink) VALUES (?,?);" pkg-id dest-link))
  
(define (datashare:count-refs db pkg-id)
  (let ((res 0))
    (sqlite3:for-each-row
     (lambda (count)
       (set! res count))
     db
     "SELECT count(id) FROM refs WHERE pkg_id=?;"
     pkg-id)
    res))

;; Create the sqlite db
(define (datashare:open-db configdat) 
  (let ((path (configf:lookup configdat "database" "location")))
    (if (and path
	     (directory? path)
	     (file-read-access? path))
	(let* ((dbpath    (conc path "/datashare.db"))
	       (writeable (file-write-access? dbpath))
	       (dbexists  (common:file-exists? dbpath))
	       (handler   (make-busy-timeout 136000)))
	  (handle-exceptions
	   exn
	   (begin
	     (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath
			  ((condition-property-accessor 'exn 'message) exn))
	     (exit))
	   (set! db (sqlite3:open-database dbpath)))
	  (if *db-write-access* (sqlite3:set-busy-handler! db handler))
	  (if (not dbexists)
	      (begin
		(datashare:initialize-db db)))
	  db)
	(print "ERROR: invalid path for storing database: " path))))

(define (open-run-close-exception-handling proc idb . params)
  (handle-exceptions
   exn
   (let ((sleep-time (random 30))
         (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
     (case err-status
       ((busy)
        (thread-sleep! sleep-time))
       (else
        (print "EXCEPTION: database overloaded or unreadable.")
        (print " message: " ((condition-property-accessor 'exn 'message) exn))
        (print "exn=" (condition->list exn))
        (print " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
        (print-call-chain (current-error-port))
        (thread-sleep! sleep-time)
        (print "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
     (apply open-run-close-exception-handling proc idb params))
   (apply open-run-close-no-exception-handling proc idb params)))

(define (open-run-close-no-exception-handling  proc idb . params)
  ;; (print "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
  (let* ((db (cond
	      ((sqlite3:database? idb)     idb)
	      ((not idb)                   (print "ERROR: cannot open-run-close with #f anymore"))
	      ((procedure? idb)            (idb))
	      (else                        (print "ERROR: cannot open-run-close with #f anymore"))))
	 (res #f))
    (set! res (apply proc db params))
    (if (not idb)(sqlite3:finalize! dbstruct))
    ;; (print "open-run-close-no-exception-handling END" )
    res))

(define open-run-close open-run-close-no-exception-handling)

(define (datashare:get-pkgs db area-filter version-filter iter-filter)
  (let ((res '()))
    (sqlite3:for-each-row ;; replace with fold ...
     (lambda (a . b)
       (set! res (cons (list->vector (cons a b)) res)))
     db 
     (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path "
	   " FROM pkgs WHERE area like ? AND version_name LIKE ? AND iteration " iter-filter ";")
     area-filter version-filter)
    (reverse res)))

(define (datashare:get-pkg db area-name version-name #!key (iteration #f))
  (let ((dat '())
	(res #f))
    (sqlite3:for-each-row ;; replace with fold ...
     (lambda (a . b)
       (set! dat (cons (list->vector (cons a b)) dat)))
     db 
     (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path "
	   " FROM pkgs WHERE area=? AND version_name=? ORDER BY iteration ASC;")
     area-name version-name)
    ;; now filter for iteration, either max if #f or specific one
    (if (null? dat)
	#f
	(let loop ((hed (car dat))
		   (tal (cdr dat))
		   (cur 0))
	  (let ((itr (datashare:pkg-get-iteration hed)))
	    (if (equal? itr iteration) ;; this is the one if iteration is specified
		hed
		(if (null? tal)
		    hed
		    (loop (car tal)(cdr tal)))))))))

(define (datashare:get-versions-for-area db area-name #!key (version-patt #f))
  (let ((res '())
	(data (make-hash-table)))
    (sqlite3:for-each-row
     (lambda (version-name submitter iteration submitted-time comment)
       ;;                                              0           1         2           3           4
       (hash-table-set! data version-name (vector version-name submitter iteration submitted-time comment)))
     db 
     "SELECT version_name,submitter,iteration,datetime,comment FROM pkgs WHERE area='megatest' AND version_name != 'latest' AND version_name LIKE ? ORDER BY datetime asc;"
     (or version-patt "%"))
    (map (lambda (x)(hash-table-ref data x))(sort (hash-table-keys data) string-ci>=))))

;;======================================================================
;; DATA IMPORT/EXPORT
;;======================================================================

(define (datashare:import-data configdat source-path dest-path area version iteration)
  (let* ((space-avail (car dest-path))
	 (disk-path   (cdr dest-path))
	 (targ-path   (conc disk-path "/" area "/" version "/" iteration))
	 (id          (datashare:get-id db area version iteration))
	 (db          (datashare:open-db configdat)))
    (if (> space-avail 10000) ;; dumb heuristic
	(begin
	  (create-directory targ-path #t)
	  (datashare:set-stored-path db id targ-path)
	  (print "Running command: rsync -av " source-path "/ " targ-path "/")
	  (let ((th1 (make-thread (lambda ()
				    (let ((pid (process-run "rsync" (list "-av" (conc source-path "/") (conc targ-path "/")))))
				      (process-wait pid)
				      (datashare:set-copied db id "yes")
				      (sqlite3:finalize! db)))
				   "Data copy")))
	    (thread-start! th1))
	  #t)
	(begin
	  (print "ERROR: Not enough space in storage area " dest-path)
	  (datashare:set-copied db id "no")
	  (sqlite3:finalize! db)
	  #f))))

(define (datashare:get-areas configdat)
  (let* ((areadat (configf:get-section configdat "areas"))
	 (areas   (if areadat (map car areadat) '())))
    areas))

(define (datashare:publish configdat publish-type area-name version comment spath submitter quality)
  ;; input checks
  (cond 
   ((not (member area-name (datashare:get-areas configdat)))
    (cons #f (conc "Illegal area name \"" area-name "\"")))
   (else
    (let ((db          (datashare:open-db configdat))
	  (iteration   (datashare:register-data db area-name version publish-type submitter quality spath comment))
	  (dest-store  (datashare:get-best-storage configdat)))
      (if iteration
	  (if (eq? 'copy publish-type)
	      (begin
		(datashare:import-data configdat spath dest-store area-name version iteration)
		(let ((id (datashare:get-id db area-name version iteration)))
		  (datashare:set-latest db id area-name version iteration)))
	      (let ((id (datashare:get-id db area-name version iteration)))
		(datashare:set-stored-path db id spath)
		(datashare:set-copied db id "yes")
		(datashare:set-copied db id "n/a")
		(datashare:set-latest db id area-name version iteration)))
	  (print "ERROR: Failed to get an iteration number"))
      (sqlite3:finalize! db)
      (cons #t "Successfully saved data")))))

(define (datashare:get-best-storage configdat)
  (let* ((storage     (configf:lookup configdat "settings" "storage"))
	 (store-areas (if storage (string-split storage) '())))
    (print "Looking for available space in " store-areas)
    (datashare:find-most-space store-areas)))

;; (string->number (list-ref (with-input-from-pipe "df -B1000000 /tmp" (lambda ()(read-line)(string-split (read-line)))) 3))

(define (datashare:find-most-space paths)
  (fold (lambda (area res)
	  ;; (print "area=" area " res=" res)
	  (let ((maxspace (car res))
		(currpath (cdr res)))
	    ;; (print currpath " " maxspace)
	    (if (file-write-access? area)
		(let ((currspace (string->number
				  (list-ref
				   (with-input-from-pipe 
				    ;; (conc "df --output=avail " area)
				    (conc "df -B1000000 " area)
				    ;; (lambda ()(read)(read))
				    (lambda ()(read-line)(string-split (read-line))))
				   3))))
		  (if (> currspace maxspace) 
		      (cons currspace area)
		      res))
		res)))
	(cons 0 #f)
	paths))

;; remove existing link and if possible ...
;; create path to next of tip of target, create link back to source
(define (datashare:build-dir-make-link source target)
  (if (common:file-exists? target)(datashare:backup-move target))
  (create-directory (pathname-directory target) #t)
  (create-symbolic-link source target))

(define (datashare:backup-move path)
  (let* ((trashdir  (conc (pathname-directory path) "/.trash"))
	 (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path))))
    (create-directory trashdir #t)
    (if (directory? path)
	(system (conc "mv " path " " trashfile))
	(file-move path trash-file))))

;;======================================================================
;; GUI
;;======================================================================

;; The main menu 
(define (datashare:main-menu)
  (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top)
   (iup:menu-item "Files" (iup:menu   ;; Note that you can use either #:action or action: for options
		       (iup:menu-item "Open"  action: (lambda (obj)
							(iup:show (iup:file-dialog))
							(print "File->open " obj)))
		       (iup:menu-item "Save"  #:action (lambda (obj)(print "File->save " obj)))
		       (iup:menu-item "Exit"  #:action (lambda (obj)(exit)))))
   (iup:menu-item "Tools" (iup:menu
		       (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah")))
		       ;; (iup:menu-item "Show dialog"     #:action (lambda (obj)
		       ;;  					   (show message-window
		       ;;  					     #:modal? #t
		       ;;  					     ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
		       ;;  					     ;; #:x 'mouse
		       ;;  					     ;; #:y 'mouse
		       ;;  )					     
		       ))))

(define (datashare:publish-view configdat)
  ;; (pp (hash-table->alist configdat))
  (let* ((areas       (configf:get-section configdat "areas"))
	 (label-size  "70x")
	 (areas-sel   (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES"))
	 (version-tb  (iup:textbox #:expand "HORIZONTAL")) ;;  #:size "50x"))
	 (areas-sel   (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES"))
	 (component   (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" ))
	 (version-val (iup:textbox #:expand "HORIZONTAL" #:size "50x"))
	 ;; (copy-link   (iup:toggle  #:expand "HORIZONTAL"))
	 ;; (iteration   (iup:textbox #:expand "YES" #:size "20x"))
	 ;; (iteration   (iup:textbox #:expand "HORIZONTAL" #:size "20x"))
	 (area-filter (iup:textbox #:expand "HORIZONTAL" #:value "%"))
	 (comment-tb  (iup:textbox #:expand "YES" #:multiline "YES"))
	 (source-tb   (iup:textbox #:expand "HORIZONTAL"
				   #:value (or (configf:lookup configdat "settings" "basepath")
					       "")))
	 (publish     (lambda (publish-type)
			(let* ((area-num    (or (string->number (iup:attribute areas-sel "VALUE")) 0))
			       (area-dat    (if (> area-num 0)(list-ref areas (- area-num 1))'("NOT SELECTED" "NOT SELECTED")))
			       (area-path   (cadr area-dat))
			       (area-name   (car  area-dat))
			       (version     (iup:attribute version-tb "VALUE"))
			       (comment     (iup:attribute comment-tb "VALUE"))
			       (spath       (iup:attribute source-tb  "VALUE"))
			       (submitter   (current-user-name))
			       (quality     2))
			  (datashare:publish configdat publish-type area-name version comment spath submitter quality))))
	 (copy        (iup:button "Copy and Publish"
				  #:expand "HORIZONTAL"
				  #:action (lambda (obj)
					     (publish 'copy))))
	 (link        (iup:button "Link and Publish"
				  #:expand "HORIZONTAL"
				  #:action (lambda (obj)
					     (publish 'link))))
	 (browse-btn  (iup:button "Browse"
				  #:size "40x"
				  #:action (lambda (obj)
					     (let* ((fd  (iup:file-dialog #:dialogtype "DIR"))
						    (top (iup:show fd #:modal? "YES")))
					       (iup:attribute-set! source-tb "VALUE"
								   (iup:attribute fd "VALUE"))
					       (iup:destroy! fd))))))
    (print "areas")
    ;; (pp areas)
    (fold (lambda (areadat num)
	    ;; (print "Adding num=" num ", areadat=" areadat)
	    (iup:attribute-set! areas-sel (conc num) (car areadat))
	    (+ 1 num))
	  1 areas)
    (iup:vbox
     (iup:hbox (iup:label "Area:"        #:size label-size) ;; area-filter 
	       areas-sel)
     (iup:hbox (iup:label "Version:"     #:size label-size)   version-tb)
     ;; (iup:hbox (iup:label "Link only"    #:size label-size)   copy-link)
     ;; 	       (iup:label "Iteration:")   iteration)
     (iup:hbox (iup:label "Comment:"     #:size label-size)   comment-tb)
     (iup:hbox (iup:label "Source base path:" #:size label-size)   source-tb browse-btn)
     (iup:hbox copy link))))

(define (datashare:lst->path pathlst)
  (conc "/" (string-intersperse (map conc pathlst) "/")))

(define (datashare:path->lst path)
  (string-split path "/"))

(define (datashare:pathdat-apply-heuristics configdat path)
  (cond
   ((common:file-exists? path) "found")
   (else (conc path " not installed"))))

(define (datashare:get-view configdat)
  (iup:vbox
   (iup:hbox
    (let* ((label-size     "60x")
	   ;; filter elements
	   (area-filter    "%")
	   (version-filter "%")
	   (iter-filter    ">= 0")
	   ;; reverse lookup from path to data for src and installed
	   (srcdat         (make-hash-table)) ;; reverse lookup
	   (installed-dat  (make-hash-table))
	   ;; config values
	   (basepath       (configf:lookup configdat "settings" "basepath"))
	   ;; gui elements
	   (submitter      (iup:label "" #:expand "HORIZONTAL"))
	   (date-submitted (iup:label "" #:expand "HORIZONTAL"))
	   (comment        (iup:label "" #:expand "HORIZONTAL"))
	   (copy-link      (iup:label "" #:expand "HORIZONTAL"))
	   (quality        (iup:label "" #:expand "HORIZONTAL"))
	   (installed-status (iup:label "" #:expand "HORIZONTAL"))
	   ;; misc 
	   (curr-record    #f)
	   ;; (source-data    (iup:label "" #:expand "HORIZONTAL"))
	   (tb             (iup:treebox
			    #:value 0
			    #:name "Packages"
			    #:expand "YES"
			    #:addexpanded "NO"
			    #:selection-cb
			    (lambda (obj id state)
			      ;; (print "obj: " obj ", id: " id ", state: " state)
			      (let* ((path   (datashare:lst->path (cdr (tree:node->path obj id))))
				     (record (hash-table-ref/default srcdat path #f)))
				(if record
				    (begin
				      (set! curr-record record)
				      (iup:attribute-set! submitter      "TITLE" (datashare:pkg-get-submitter record))
				      (iup:attribute-set! date-submitted "TITLE" (time->string (seconds->local-time (datashare:pkg-get-datetime record))))
				      (iup:attribute-set! comment        "TITLE" (datashare:pkg-get-comment record))
				      (iup:attribute-set! quality        "TITLE" (datashare:pkg-get-quality record))
				      (iup:attribute-set! copy-link      "TITLE" (datashare:pkg-get-store_type record))
				      ))
				;; (print  "id=" id " path=" path " record=" record);; (tree:node->path obj id) " run-id: " run-id)
				))))
	   (tb2             (iup:treebox
			    #:value 0
			    #:name "Installed"
			    #:expand "YES"
			    #:addexpanded "NO"
			    #:selection-cb
			    (lambda (obj id state)
			      ;; (print "obj: " obj ", id: " id ", state: " state)
			      (let* ((path   (datashare:lst->path (cdr (tree:node->path obj id))))
				     (status (hash-table-ref/default installed-dat path #f)))
				(iup:attribute-set! installed-status "TITLE" (if status status ""))
				))))
	   (refresh        (lambda (obj)
			     (let* ((db    (datashare:open-db configdat))
				    (areas (or (configf:get-section configdat "areas") '())))
			       ;;
			       ;; first update the Sources
			       ;;
			       (for-each
				(lambda (pkgitem)
				  (let* ((pkg-path   (list (datashare:pkg-get-area  pkgitem)
							   (datashare:pkg-get-version_name pkgitem)
							   (datashare:pkg-get-iteration pkgitem)))
					 (pkg-id     (datashare:pkg-get-id          pkgitem))
					 (path       (datashare:lst->path pkg-path)))
				    ;; (print "tree:add-node tb=" tb ", pkg-path=" pkg-path ", pkg-id=" pkg-id)
				    (if (not (hash-table-ref/default srcdat path #f))
					(tree:add-node tb "Packages" pkg-path userdata: (conc "pkg-id: " pkg-id)))
				    ;; (print "path=" path " pkgitem=" pkgitem)
				    (hash-table-set! srcdat path pkgitem)))
				(datashare:get-pkgs db area-filter version-filter iter-filter))
			       ;;
			       ;; then update the installed
			       ;;
			       (for-each
				(lambda (area)
				  (let* ((path     (conc "/" (cadr area)))
					 (fullpath (conc basepath path)))
				    (if (not (hash-table-ref/default installed-dat path #f))
					(tree:add-node tb2 "Installed" (datashare:path->lst path)))
				    (hash-table-set! installed-dat path (datashare:pathdat-apply-heuristics configdat fullpath))))
				areas)
			       (sqlite3:finalize! db))))
	   (apply          (iup:button "Apply"
				       #:action
				       (lambda (obj)
					 (if curr-record
					     (let* ((area        (datashare:pkg-get-area        curr-record))
						    (stored-path (datashare:pkg-get-stored_path curr-record))
						    (source-type (datashare:pkg-get-store_type  curr-record))
						    (source-path (case source-type ;;  (equal? source-type "link"))
								   ((link)(datashare:pkg-get-source-path curr-record))
								   ((copy)stored-path)
								   (else #f)))
						    (dest-stub   (configf:lookup configdat "areas" area))
						    (target-path (conc basepath "/" dest-stub)))
					       (datashare:build-dir-make-link stored-path target-path)
					       (print "Creating link from " stored-path " to " target-path)))))))
      (iup:vbox 
       (iup:hbox tb tb2)
       (iup:frame 
	#:title "Source Info"
	(iup:vbox
	 (iup:hbox (iup:button "Refresh" #:action refresh) apply)
	 (iup:hbox (iup:label "Submitter: ") ;;  #:size label-size)
		   submitter 
		   (iup:label "Submitted on: ") ;;  #:size label-size)
		   date-submitted)
	 (iup:hbox (iup:label "Data stored: ")
		   copy-link
		   (iup:label "Quality: ")
		   quality)
	 (iup:hbox (iup:label "Comment: ")
		   comment)))
       (iup:frame
	#:title "Installed Info"
	(iup:vbox
	 (iup:hbox (iup:label "Installed status/path: ") installed-status)))
       )))))

(define (datashare:manage-view configdat)
  (iup:vbox
   (iup:hbox 
    (iup:button "Pushme"
		#:expand "YES"
		))))

(define (datashare:gui configdat)
  (iup:show
   (iup:dialog 
    #:title (conc "DataShare dashboard " (current-user-name) ":" (current-directory))   
    #:menu (datashare:main-menu)
    (let* ((tabs (iup:tabs
		  #:tabchangepos-cb (lambda (obj curr prev)
				      (set! *datashare:current-tab-number* curr))
		  (datashare:publish-view configdat)
		  (datashare:get-view configdat)
		  (datashare:manage-view configdat)
		  )))
	;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
	(iup:attribute-set! tabs "TABTITLE0" "Publish")
	(iup:attribute-set! tabs "TABTITLE1" "Get")
	(iup:attribute-set! tabs "TABTITLE2" "Manage")
	;; (iup:attribute-set! tabs "BGCOLOR" "190 190 190")
	tabs)))
  (iup:main-loop))

;;======================================================================
;; MISC
;;======================================================================


(define (datashare:do-as-calling-user proc)
  (let ((eid (current-effective-user-id))
        (cid (current-user-id)))
    (if (not (eq? eid cid)) ;; running suid
            (set! (current-effective-user-id) cid))
    ;; (print "running as " (current-effective-user-id))
    (proc)
    (if (not (eq? eid cid))
        (set! (current-effective-user-id) eid))))

(define (datashare:find name paths)
  (if (null? paths)
      #f
      (let loop ((hed (car paths))
		 (tal (cdr paths)))
	(if (common:file-exists? (conc hed "/" name))
	    hed
	    (if (null? tal)
		#f
		(loop (car tal)(cdr tal)))))))

;;======================================================================
;; MAIN
;;======================================================================

(define (datashare:load-config exe-dir exe-name)
  (let* ((fname   (conc exe-dir "/." exe-name ".config")))
    (ini:property-separator-patt " *  *")
    (ini:property-separator #\space)
    (if (common:file-exists? fname)
	;; (ini:read-ini fname)
	(read-config fname #f #t)
	(make-hash-table))))

(define (datashare:process-action configdat action . args)
  (case (string->symbol action)
    ((get)
     (if (< (length args) 2)
	 (begin 
	   (print "ERROR: Missing arguments; " (string-intersperse args ", "))
	   (exit 1))
	 (let* ((basepath    (configf:lookup configdat "settings" "basepath"))
		(db          (datashare:open-db configdat))
		(area        (car args))
		(version     (cadr args)) ;;    iteration
		(remargs     (args:get-args args '("-i") '() args:arg-hash 0))
		(iteration   (if (args:get-arg "-i")(string->number (args:get-arg "-i")) #f))
		(curr-record (datashare:get-pkg db area version iteration: iteration)))
	   (if (not curr-record)
	       (begin
		 (print "ERROR: No matching record found; area=" area ", version=" version ", iteration=" (if iteration iteration "(max)"))
		 (exit 1))
	       (let* ((stored-path (datashare:pkg-get-stored_path curr-record))
		      (source-type (datashare:pkg-get-store_type  curr-record))
		      (source-path (case source-type ;;  (equal? source-type "link"))
				     ((link) (datashare:pkg-get-source-path curr-record))
				     ((copy) stored-path)
				     (else #f)))
		      (dest-stub   (configf:lookup configdat "areas" area))
		      (target-path (conc basepath "/" dest-stub)))
		 (datashare:build-dir-make-link stored-path target-path)
		 (datashare:record-pkg-ref db (datashare:pkg-get-id curr-record) target-path)
		 (sqlite3:finalize! db)
		 (print "Creating link from " stored-path " to " target-path))))))
    ((publish)
     (if (< (length args) 3)
	 (begin 
	   (print "ERROR: Missing arguments; " (string-intersperse args ", "))
	   (exit 1))
	 (let* ((srcpath  (list-ref args 0))
		(areaname (list-ref args 1))
		(version  (list-ref args 2))
		(remargs  (args:get-args (drop args 2)
					 '("-type" ;; link or copy (default is copy)
					   "-m")
 					 '()
 					 args:arg-hash
 					 0))
		(publish-type (if (equal? (args:get-arg "-type") "link") 'link 'copy))
		(comment      (or (args:get-arg "-m") ""))
		(submitter    (current-user-name))
		(quality      (args:get-arg "-quality"))
		(publish-res  (datashare:publish configdat publish-type areaname version comment srcpath submitter quality)))
	   (if (not (car publish-res))
	       (begin
		 (print "ERROR: " (cdr publish-res))
		 (exit 1))))))
    ((list-versions)
     (let ((area-name (car args)) ;;      version patt   full print
	   (remargs   (args:get-args args '("-vpatt") '("-full") args:arg-hash 0))
	   (db        (datashare:open-db configdat))
	   (versions  (datashare:get-versions-for-area db (car args) version-patt: (args:get-arg "-vpatt"))))
       ;; (print "area-name=" area-name " args=" args " *args-hash*=" (hash-table->alist *args-hash*))
       (map (lambda (x)
	      (if (args:get-arg "-full")
		  (format #t 
			  "~10a~10a~4a~27a~30a\n"
			  (vector-ref x 0)
			  (vector-ref x 1) 
			  (vector-ref x 2) 
			  (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"")
			  (conc "\"" (vector-ref x 4) "\""))
		  (print (vector-ref x 0))))
	    versions)
       (sqlite3:finalize! db)))))

;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION!
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.datasharerc")))
  (if (common:file-exists? debugcontrolf)
      (load debugcontrolf)))

(define (main)
  (let* ((args      (argv))
	 (prog      (car args))
	 (rema      (cdr args))
	 (exe-name  (pathname-file (car (argv))))
	 (exe-dir   (or (pathname-directory prog)
			(datashare:find exe-name (string-split (get-environment-variable "PATH") ":"))))
	 (configdat (datashare:load-config exe-dir exe-name)))
    (cond
     ;; one-word commands
     ((eq? (length rema) 1)
      (case (string->symbol (car rema))
	((help -h -help --h --help)
	 (print datashare:help))
	((list-areas)
	 (map print (datashare:get-areas configdat)))
	(else
	 (print "ERROR: Unrecognised command. Try \"datashare help\""))))
     ;; multi-word commands
     ((null? rema)(datashare:gui configdat))
     ((>= (length rema) 2)
      (apply datashare:process-action configdat (car rema)(cdr rema)))
     (else (print "ERROR: Unrecognised command. Try \"datashare help\"")))))

(main)








Modified db.scm
from [ed256dd44f]
to [373c9e3316].




︙


1995
1996
1997
1998
1999
2000
2001
2002

2003
2004
2005
2006
2007
2008
2009

1995
1996
1997
1998
1999
2000
2001

2002
2003
2004
2005
2006
2007
2008
2009








-
+








;; 1. Look at test records either deleted or part of deleted run:
;;    a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
;;    b. If test dir gone, delete the test record
;; 2. Look at run records
;;    a. If have tests that are not deleted, set state='unknown'
;;    b. ....
;;
(define (db:clean-up-rundb dbdat)
#;(define (db:clean-up-rundb dbdat)
  ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
  (let* ((db         (db:dbdat-get-db dbdat))
	 (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);"))
	(statements
	 (map (lambda (stmt)
		(sqlite3:prepare db stmt))
	      (list




︙


2300
2301
2302
2303
2304
2305
2306
2307

2308
2309
2310
2311
2312
2313
2314

2300
2301
2302
2303
2304
2305
2306

2307
2308
2309
2310
2311
2312
2313
2314








-
+








	(lambda (runname)
	  (set! res runname))
	db
	"SELECT runname FROM runs WHERE id=?;"
	run-id)
       res))))

(define (db:get-run-key-val dbstruct run-id key)
#;(define (db:get-run-key-val dbstruct run-id key)
  (db:with-db
   dbstruct
   #f
   #f
   (lambda (db)
     (let ((res #f))
       (sqlite3:for-each-row




︙


3319
3320
3321
3322
3323
3324
3325
3326

3327
3328
3329
3330
3331
3332
3333

3319
3320
3321
3322
3323
3324
3325

3326
3327
3328
3329
3330
3331
3332
3333








-
+








	    0))))

;; tags: '("tag%" "tag2" "%ag6")
;;

;; done with run when:
;;   0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING
(define (db:estimated-tests-remaining dbstruct run-id)
#;(define (db:estimated-tests-remaining dbstruct run-id)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (sqlite3:first-result
      db




︙


3450
3451
3452
3453
3454
3455
3456
3457

3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469

3470
3471
3472
3473
3474
3475
3476

3450
3451
3452
3453
3454
3455
3456

3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468

3469
3470
3471
3472
3473
3474
3475
3476








-
+











-
+








	      (loop (+ new-id 1))
	      (begin
		(debug:print-info 0 *default-log-port* "New test id " new-id " selected for test with id " test-id)
		(sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id)))))))

;; move test ids into the 30k * run_id range
;;
(define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs)
#;(define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs)
  (debug:print-info 0 *default-log-port* "Adjusting test ids in megatest.db for run " run-id)
  (let ((min-test-id (* run-id 30000)))
    (for-each 
     (lambda (testrec)
       (let* ((test-id (vector-ref testrec (db:field->number "id" db:test-record-fields))))
	 (db:adj-test-id (db:dbdat-get-db mtdb) min-test-id test-id)))
     testrecs)))
	
;; 1. move test ids into the 30k * run_id range
;; 2. move step ids into the 30k * run_id range
;;
(define (db:prep-megatest.db-for-migration mtdb)
#;(define (db:prep-megatest.db-for-migration mtdb)
  (let* ((run-ids (db:get-all-run-ids mtdb)))
    (for-each 
     (lambda (run-id)
       (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)))
	 (db:prep-megatest.db-adj-test-ids (db:dbdat-get-db mtdb) run-id testrecs)))
     run-ids)))





︙







Modified mt.scm
from [e9055c2687]
to [283ae4be89].




︙


100
101
102
103
104
105
106
107

108
109
110
111
112
113
114

100
101
102
103
104
105
106

107
108
109
110
111
112
113
114








-
+








		   (if last-time
		       (< (current-seconds)(+ last-time 5))
		       #f))))
    (if useres
	(let ((result (vector-ref res 1)))
	  (debug:print 4 *default-log-port* "Using lazy value res: " result)
	  result)
	(let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmaps: itemmaps)))
	(let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode itemmaps)))
	  (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres))
	  newres))))

(define (mt:get-run-stats dbstruct run-id)
;;  Get run stats from local access, move this ... but where?
  (db:get-run-stats dbstruct run-id))





︙







Modified mtut.scm
from [ead30f316f]
to [88e0c0a24a].




︙


53
54
55
56
57
58
59
60

61
62
63
64
65
66
67

53
54
55
56
57
58
59

60
61
62
63
64
65
66
67








-
+








       in-stml))))

;; helpers for mappers/checkers
(define (add-target-mapper name proc)
  (hash-table-set! *target-mappers* name proc))
(define (add-runname-mapper name proc)
  (hash-table-set! *runname-mappers* name proc))
(define (add-area-checker name proc)
(define (add-area-checker name proc) ;; util, USED EXTERNALLY, do not remove.
  (hash-table-set! *area-checkers* name proc))

;; given a runkey, xlatr-key and other info return one of the following:
;;   list of targets, null list to skip processing
;;   
(define (map-targets mtconf aval-alist runkey area contour #!key (xlatr-key-in #f))
  (pp aval-alist)




︙


1690
1691
1692
1693
1694
1695
1696
1697


1698
1699
1700
1701
1702
1703
1704

1690
1691
1692
1693
1694
1695
1696

1697
1698
1699
1700
1701
1702
1703
1704
1705








-
+
+








                  (prev-seen (make-hash-table))) ;; catch duplicates
             (if user-info
              (begin
               (for-each
              (lambda (listener)
                (let ((host-port (car listener))
                      (attrib (val->alist (cadr listener))))
                  (if (and (equal? msg "time-to-die") (not (can-user-kill-listner user-info attrib)))
                  (if (and (equal? msg "time-to-die")
			   (not (can-user-kill-listner user-info attrib)))
                   (begin
                      (debug:print-error 0 *default-log-port* "User " (car user-info) " is not allowed to send message '" msg"'")
                      (exit 1)))
                  (print "sending " msg " to " host-port )
                  (open-send-close-nn host-port msg attrib timeout: time-out )))
              listeners))
              (begin




︙


1718
1719
1720
1721
1722
1723
1724
1725


1726
1727
1728
1729
1730
1731
1732

1719
1720
1721
1722
1723
1724
1725

1726
1727
1728
1729
1730
1731
1732
1733
1734








-
+
+








                  (prev-seen (make-hash-table))) ;; catch duplicates
             (if user-info
              (begin
               (for-each
              (lambda (listener)
                (let ((host-port (car listener))
                      (attrib (val->alist (cadr listener))))
                  (if (and (equal? msg "time-to-die") (not (can-user-kill-listner user-info attrib)))
                  (if (and (equal? msg "time-to-die")
			   (not (can-user-kill-listner user-info attrib)))
                   (begin
                      (debug:print-error 0 *default-log-port* "User " (car user-info) " is not allowed to send message '" msg"'")
                      (exit 1)))
                  (print "sending " msg " to " host-port )
                  (open-send-receive-nn host-port msg attrib timeout: time-out )))
              listeners))
              (begin




︙







Modified rmt.scm
from [ed2cbd88f2]
to [e8352fc67e].




︙


673
674
675
676
677
678
679

680

681
682
683
684
685
686
687

673
674
675
676
677
678
679
680

681
682
683
684
685
686
687
688








+
-
+








(define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname)
  (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt)))
    (apply append 
	   (map (lambda (run-id)
		  (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname)))
	   run-ids))))

;; NOTE: rmt functions can NEVER have key params as they might be called as local
(define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f))
(define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmaps #f))
  (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps)))

(define (rmt:get-count-tests-running-for-run-id run-id)
  (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id)))

(define (rmt:get-not-completed-cnt run-id)
  (rmt:send-receive 'get-not-completed-cnt run-id (list run-id)))




︙







Modified runs.scm
from [2583922f1c]
to [78e08647d1].




︙


58
59
60
61
62
63
64
65





66
67
68
69
70
71
72

58
59
60
61
62
63
64

65
66
67
68
69
70
71
72
73
74
75
76








-
+
+
+
+
+








  (last-load-check-time    0)
  (last-jobs-check-time    0)
  )

(defstruct runs:testdat
  hed tal reg reruns  test-record
  test-name item-path jobgroup
  waitons testmode  newtal itemmaps prereqs-not-met)
  waitons testmode  newtal
  itemmaps
  (prereqs-not-met #f)
  (last-update 0) ;; 
  )
  
;; look in the $MT_RUN_AREA_HOME/.softlocks directory for key-host-pid.softlock files
;;  - remove any that are over 3600 seconds old
;;  - if there are any that are younger than 10 seconds
;;      * sleep 10 seconds
;;      * touch my key-host-pid.softlock file
;;      * return




︙


884
885
886
887
888
889
890
















891
892
893
894
895
896
897
898
899
900


901
902

903
904
905
906
907
908
909
910

911
912
913
914
915
916
917
918

888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919

920
921
922

923








924

925
926
927
928
929
930
931








+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+









-
+
+

-
+
-
-
-
-
-
-
-
-
+
-








;;    => review of a previously seen test is higher priority of never visited test
;; reg - list of previously visited tests
;; tal - list of never visited tests
;;   prefer next hed to be from reg than tal.

(define runs:nothing-left-in-queue-count 0)

(define (runs:lazy-get-prereqs-not-met  testdat run-id waitons hed item-path #!key (mode '(normal))(itemmaps #f)) ;; mode: testmode itemmaps: itemmaps)
  (if (and (runs:testdat-prereqs-not-met testdat)
	   (< (- (current-seconds) (runs:testdat-last-update testdat)) 10)) ;; only refresh for this test if it has been at least 10 seconds
      (runs:testdat-prereqs-not-met testdat)
      (let* ((res (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode itemmaps)))
		    (if (list? res)
			res
			(begin
			  (debug:print 0 *default-log-port*
				       "ERROR: rmt:get-prereqs-not-met returned non-list!\n"
				       "  res=" res " run-id=" run-id " waitons=" waitons " hed=" hed " item-path=" item-path " testmode=" mode " itemmaps=" itemmaps)
			  '())))))
	(runs:testdat-prereqs-not-met-set! testdat res)
	(runs:testdat-last-update-set! testdat (current-seconds))
	res)))
	   
;;======================================================================
;; runs:expand-items is called by runs:run-tests-queue
;;======================================================================
;;
;; return value of runs:expand-items is passed back to runs-tests-queue and is fed to named loop with this signature:
;;    (let loop ((hed         (car sorted-test-names))
;;	         (tal         (cdr sorted-test-names))
;;	         (reg         '()) ;; registered, put these at the head of tal 
;;	         (reruns      '()))
(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps)
(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record
			   can-run-more items runname tconfig reglen test-registry test-records itemmaps testdat)
  (let* ((loop-list       (list hed tal reg reruns))
	 (prereqs-not-met (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)))
	 (prereqs-not-met (runs:lazy-get-prereqs-not-met testdat run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
			    (if (list? res)
				res
				(begin
				  (debug:print 0 *default-log-port*
					       "ERROR: rmt:get-prereqs-not-met returned non-list!\n"
					       "  res=" res " run-id=" run-id " waitons=" waitons " hed=" hed " item-path=" item-path " testmode=" testmode " itemmaps=" itemmaps)
				  '()))))
         (have-itemized (not (null? (lset-intersection eq? testmode '(itemmatch itemwait)))))
	 (have-itemized   (not (null? (lset-intersection eq? testmode '(itemmatch itemwait)))))
	 ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
	 (fails           (runs:calc-fails prereqs-not-met))
	 (prereq-fails    (runs:calc-prereq-fail prereqs-not-met))
	 (non-completed   (runs:calc-not-completed prereqs-not-met))
	 (runnables       (runs:calc-runnable prereqs-not-met))
         (unexpanded-prereqs
          (filter (lambda (testname)
                    (let* ((test-rec (hash-table-ref test-records testname))




︙


1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165

1163
1164
1165
1166
1167
1168
1169


1170
1171
1172
1173
1174
1175
1176








-
-








	 (run-limits-info        (runs:dat-can-run-more-tests runsdat))
	 ;; (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running
	 (have-resources         (car run-limits-info))
	 (num-running            (list-ref run-limits-info 1))
	 (num-running-in-jobgroup(list-ref run-limits-info 2)) 
	 (max-concurrent-jobs    (list-ref run-limits-info 3))
	 (job-group-limit        (list-ref run-limits-info 4))
	 ;; (prereqs-not-met        (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
	 ;; (prereqs-not-met         (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
	 (fails                  (if (list? prereqs-not-met) ;; TODO: rename fails to failed-prereqs
				      (runs:calc-fails prereqs-not-met)
				      (begin
					(debug:print-error 0 *default-log-port* "prereqs-not-met is not a list! " prereqs-not-met)
					'())))
	 (non-completed           (filter (lambda (x)             ;; remove hed from not completed list, duh, of course it is not completed!
					    (not (equal? x hed)))




︙


1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565

1562
1563
1564
1565
1566
1567
1568

1569
1570
1571
1572
1573
1574
1575








-








                   registry-mutex: registry-mutex
                   flags: flags
                   keyvals: keyvals
                   run-info: run-info
                   ;; newtal: newtal
                   all-tests-registry: all-tests-registry
                   ;; itemmaps: itemmaps
                   ;; prereqs-not-met: (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)
                   ;; can-run-more-tests: (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs) ;; look at the test jobgroup and tot jobs running
                   )))

    ;; Initialize the test-registery hash with tests that already have a record
    ;; convert state to symbol and use that as the hash value
    (for-each (lambda (trec)
		(let ((id (db:test-get-id        trec))




︙


1770
1771
1772
1773
1774
1775
1776


1777

1778
1779
1780
1781
1782
1783
1784

1780
1781
1782
1783
1784
1785
1786
1787
1788

1789
1790
1791
1792
1793
1794
1795
1796








+
+
-
+








				  ;; wait for load here
				  (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))
				  (loop-can-run-more (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)
						     (- remtries 1)))))))
		       )))))

	  ;; I'm not clear on why prereqs are gathered here TODO: verfiy this is needed
	  (runs:lazy-get-prereqs-not-met testdat run-id waitons hed item-path
					 mode: testmode
	  (runs:testdat-prereqs-not-met-set! testdat (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
					 itemmaps: itemmaps)

	  ;; I'm not clear on why we'd capture running job counts here TODO: verify this is needed
	  (runs:dat-can-run-more-tests-set! runsdat (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs))

	  (let ((loop-list (runs:process-expanded-tests runsdat testdat))) ;; in process-expanded-tests ultimately run:test -> launch-test -> test actually running
            (if loop-list (apply loop loop-list))))





︙


1841
1842
1843
1844
1845
1846
1847
1848

1849
1850
1851
1852
1853
1854
1855

1853
1854
1855
1856
1857
1858
1859

1860
1861
1862
1863
1864
1865
1866
1867








-
+








	 ;;    - but only do that if resources exist to kick off the job
	 ;; EXPAND ITEMS
	 ((or (procedure? items)(eq? items 'have-procedure))
          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-4")
	  (let ((can-run-more    #f)) ;; (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)))
	    (if (not can-run-more) #;(and (list? can-run-more)
		(car can-run-more))
		(let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps))) ;; itemized test expanded here
		(let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps testdat))) ;; itemized test expanded here
		  (if loop-list
		      (apply loop loop-list)
                      (debug:print-info 4 *default-log-port* " -- Can't expand hed="hed)
                      )
                  )
		;; if can't run more just loop with next possible test
		(loop (car newtal)(cdr newtal) reg reruns))))




︙







Deleted sauth-common.scm version [5771575e2e].



1
2
3
4
5
6
7
8
9
10
11
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
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
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
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
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
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328










































































































































































































































































































































-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-

;;  Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest 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 General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.


;; Create the sqlite db
(define (sauthorize:db-do proc) 
      (if (or (not *db-path*)
              (not (file-exists? *db-path*))) 
	(begin
	  (print 0 "[database]\nlocation " *db-path* " \n\n Is missing from the config file!")
	  (exit 1)))
    (if (and *db-path*
	     (directory? *db-path*)
	     (file-read-access? *db-path*))
	(let* ((dbpath    (conc *db-path* "/sauthorize.db"))
	       (writeable (file-write-access? dbpath))
	       (dbexists  (file-exists? dbpath)))
	  (handle-exceptions
	   exn
	   (begin
	     (print 2 "ERROR: problem accessing db " dbpath
			  ((condition-property-accessor 'exn 'message) exn))
	     (exit 1))
            ;(print  "calling proc " proc "db path " dbpath )
	   (call-with-database
            dbpath
	    (lambda (db)
	       ;(print 0 "calling proc " proc " on db " db)
	      (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
	      (if (not dbexists)(sauthorize:initialize-db db))
	      (proc db)))))
	(print 0 "ERROR: invalid path for storing database: " *db-path*)))

;;execute a query
(define (sauthorize:db-qry db qry)
  ;(print qry)
  (exec (sql db  qry)))


(define (sauthorize:do-as-calling-user proc)
  (let ((eid (current-effective-user-id))
        (cid (current-user-id)))
    (if (not (eq? eid cid)) ;; running suid
            (set! (current-effective-user-id) cid))
     ;(print 0 "cid " cid " eid:" eid)
    (proc)
    (if (not (eq? eid cid))
        (set! (current-effective-user-id) eid))))


(define (run-cmd cmd arg-list)
  ; (print (current-effective-user-id))
   ;(handle-exceptions
;	     exn
;	     (print 0 "ERROR: failed to run script " cmd " with params " arg-list " " (exn assert))
	     (let ((pid (process-run cmd arg-list)))
	       (process-wait pid))
)
;)


(define (regster-log inl usr-id  area-id  cmd)
  (sauth-common:shell-do-as-adm
        (lambda ()
         (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sretrieve " inl "'," usr-id ","  area-id ", 'cat' )")))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Check user types
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;check if a user is an admin
(define (is-admin username)
   (let* ((admin #f))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM  users where users.username = '" username "'")))))
        (if (not (null? data-row))
             (let ((col  (car data-row)))
             (if (equal? col "yes")
                   (set! admin #t)))))))  	        
admin))


;;check if a user is an read-admin
(define (is-read-admin username)
   (let* ((admin #f))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM  users where users.username = '" username "'")))))
        (if (not (null? data-row))
             (let ((col  (car data-row)))
             (if (equal? col "read-admin")
                   (set! admin #t)))))))  	        
admin))


;;check if user has specifc role for a area
(define (is-user role username area)
  (let* ((has-access #f))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT  permissions.access_type, permissions.expiration FROM  users ,  areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "' and areas.code = '" area "'")))))
        (if (not (null? data-row))
           (begin
               (let* ((access-type  (car data-row))
                    (exdate (cadr data-row)))
               (if (not (null? exdate)) 
               (begin 
                  (let ((valid (is-access-valid  exdate)))
                   ;(print valid) 
                  (if (and (equal? access-type role)
                        (equal? valid #t))
                   (set! has-access #t))))
                (print "Access expired"))))))))
 ;(print has-access)
has-access))

(define (is-access-valid exp-str)
    (let* ((ret-val #f )
           (date-parts  (string-split exp-str "/"))
           (yr (string->number (car date-parts)))
           (month (string->number(car (cdr date-parts)))) 
           (day (string->number(caddr date-parts)))
           (exp-date (make-date 0 0 0 0 day month yr )))
             ;(print  exp-date)
             ;(print (current-date))   
            (if (> (date-compare exp-date  (current-date)) 0)
             (set! ret-val #t))
   ;(print ret-val)
   ret-val))


;check if area exists
(define (area-exists area)
   (let* ((area-defined #f))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  areas where areas.code = '" area "'")))))
           (if (not (null? data-row))
                 (set! area-defined #t)))))
area-defined))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Get Record from database
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;gets area id by code 
(define (get-area area)
   (let* ((area-defined '()))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  areas where areas.code = '" area "'")))))
          (set!  area-defined data-row))))
area-defined))

;get id of users table by user name 
(define (get-user user)
  (let* ((user-defined '()))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  users where users.username = '" user "'")))))
          (set!  user-defined data-row))))
user-defined))

;get permissions id by userid and area id 
(define (get-perm userid areaid)
  (let* ((user-defined '()))
    (sauthorize:db-do  (lambda (db)
          (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  permissions where user_id = " userid " and area_id = " areaid)))))
         (set!  user-defined data-row))))

user-defined))

(define (get-restrictions base-path usr)
(let* ((user-defined '()))
    (sauthorize:db-do  (lambda (db)
          (let* ((data-row (query fetch (sql db (conc "SELECT  restriction FROM areas, users, permissions where  areas.id = permissions.area_id and users.id =  permissions.user_id and  users.username = '" usr "' and areas.basepath = '" base-path "'")))))
         ;(print data-row) 
         (set!  user-defined data-row))))
    ;   (print user-defined)
  (if (null? user-defined)
      ""
      (car user-defined))))


(define (get-obj-by-path path)
   (let* ((obj '()))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT  code,exe_name, id, basepath FROM  areas where areas.basepath = '" path "'")))))
         (set!  obj data-row))))
obj))

(define (get-obj-by-code code )
  (let* ((obj '()))
    (sauthorize:db-do  (lambda (db)
        ;(print (conc "SELECT  code, exe_name,  id, basepath, required_grps  FROM  areas where areas.code = '" code "'"))
        (let* ((data-row (query fetch (sql db (conc "SELECT  code, exe_name,  id, basepath, required_grps  FROM  areas where areas.code = '" code "'")))))
         ;(print data-row)
         (set!  obj data-row)
         ;(print obj) 
        )))
    (if (not (null? obj))
          (begin
          (let* ((req-grp (caddr (cddr obj))))
            (sauthorize:do-as-calling-user
             (lambda ()
 (sauth-common:check-user-groups req-grp))))))
obj))

(define (sauth-common:check-user-groups req-grp)
(let* ((current-groups  (get-groups) )
        (req-grp-list (string-split req-grp ",")))
        ;(print req-grp-list)
        (for-each (lambda (grp)
	  (let ((grp-info (group-information grp)))
               ;(print grp-info " " grp)
               (if (not (equal? grp-info #f))
               (begin
                 (if (not (member  (caddr grp-info) current-groups))
                  (begin 
                    (sauth:print-error (conc "Please wash " grp " group in your xterm!! " ))
                     (exit 1)))))))
	     req-grp-list)))

(define (get-obj-by-code-no-grp-validation code )
  (let* ((obj '()))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT  code, exe_name,  id, basepath  FROM  areas where areas.code = '" code "'")))))
         (set!  obj data-row))))
;(print obj)
obj))


(define (sauth-common:src-size path)
  (let ((output (with-input-from-pipe (conc "/usr/bin/du -s " path  "  | awk '{print $1}'")  
                 (lambda()
                  (read-line)))))
      (string->number output)))  

(define (sauth-common:space-left-at-dest path)
   (let* ((output  (run/string (pipe (df ,path ) (tail -1))))
         (size (caddr (cdr (string-split output " ")))))
  (string->number size)))

;; function to validate the users input for target path and resolve the path
;; TODO: Check for restriction in subpath 
(define (sauth-common:resolve-path  new current allowed-sheets)
   (let* ((target-path (append  current (string-split new "/")))
          (target-path-string (string-join target-path "/"))
          (normal-path (normalize-pathname target-path-string))
          (normal-list (string-split normal-path "/"))
           (ret '()))
   (if (string-contains   normal-path "..")
    (begin
      (print "ERROR: Path  " new " resolved outside target area ")
      #f)
    (if(equal? normal-path ".")
      ret  
    (if (not (member  (car normal-list) allowed-sheets))
      (begin
      (print "ERROR: Permision denied to  " new )
       #f)
    normal-list)))))

(define (sauth-common:get-target-path base-path-list ext-path top-areas base-path)
  (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas ))
          (usr (current-user-name) ) )
          (if (not (equal? resolved-path #f))
           (if (null? resolved-path) 
             #f
           (let* ((sheet (car resolved-path))
                   (restricted-areas (get-restrictions base-path usr))
                   (restrictions (conc ".*" (string-join (string-split restricted-areas ",") ".*|.*") ".*"))
           	   (target-path (if (null? (cdr resolved-path)) 
                                     base-path 
                                     (conc base-path "/" (string-join (cdr resolved-path) "/")))))
                    
	              
                           (if (and (not (equal? restricted-areas "" ))
                             (string-match (regexp  restrictions) target-path)) 
                           (begin
                              (sauth:print-error (conc "Access denied to " (string-join resolved-path "/")))
                              ;(exit 1)   
                            #f)
                             target-path)
                            
))
             #f)))

(define (sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list)
    (if (and (null? base-path-list) (equal? ext-path "") )
      (print (string-intersperse top-areas " "))
  (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas )))
           ;(print resolved-path)
           (if (not (equal? resolved-path #f))
           (if (null? resolved-path) 
             (print (string-intersperse top-areas " "))
           (let* ((target-path (sauth-common:get-target-path  base-path-list  ext-path top-areas base-path)))
                (print target-path)
                (if (not (equal? target-path #f))
                (begin 
                (cond
		  ((null? tail-cmd-list)
		     (run (pipe
      	      	      (ls "-lrt" ,target-path))))
		  ((not (equal? (car tail-cmd-list) "|"))
                         (print "ls cmd cannot accept " (string-join tail-cmd-list) " as an argument!!"))
                  (else  
                    (run (pipe
      	      	      (ls "-lrt" ,target-path)
                      (begin (system (string-join (cdr tail-cmd-list))))))))))))))))

(define (sauth:print-error msg)
  (with-output-to-port (current-error-port)
	(lambda ()
	       (print (conc "ERROR: " msg)))))









Added sauth-src/sauth-common.scm version [5771575e2e].












































































































































































































































































































































1
2
3
4
5
6
7
8
9
10
11
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
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
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
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
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
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;;  Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest 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 General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.


;; Create the sqlite db
(define (sauthorize:db-do proc) 
      (if (or (not *db-path*)
              (not (file-exists? *db-path*))) 
	(begin
	  (print 0 "[database]\nlocation " *db-path* " \n\n Is missing from the config file!")
	  (exit 1)))
    (if (and *db-path*
	     (directory? *db-path*)
	     (file-read-access? *db-path*))
	(let* ((dbpath    (conc *db-path* "/sauthorize.db"))
	       (writeable (file-write-access? dbpath))
	       (dbexists  (file-exists? dbpath)))
	  (handle-exceptions
	   exn
	   (begin
	     (print 2 "ERROR: problem accessing db " dbpath
			  ((condition-property-accessor 'exn 'message) exn))
	     (exit 1))
            ;(print  "calling proc " proc "db path " dbpath )
	   (call-with-database
            dbpath
	    (lambda (db)
	       ;(print 0 "calling proc " proc " on db " db)
	      (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
	      (if (not dbexists)(sauthorize:initialize-db db))
	      (proc db)))))
	(print 0 "ERROR: invalid path for storing database: " *db-path*)))

;;execute a query
(define (sauthorize:db-qry db qry)
  ;(print qry)
  (exec (sql db  qry)))


(define (sauthorize:do-as-calling-user proc)
  (let ((eid (current-effective-user-id))
        (cid (current-user-id)))
    (if (not (eq? eid cid)) ;; running suid
            (set! (current-effective-user-id) cid))
     ;(print 0 "cid " cid " eid:" eid)
    (proc)
    (if (not (eq? eid cid))
        (set! (current-effective-user-id) eid))))


(define (run-cmd cmd arg-list)
  ; (print (current-effective-user-id))
   ;(handle-exceptions
;	     exn
;	     (print 0 "ERROR: failed to run script " cmd " with params " arg-list " " (exn assert))
	     (let ((pid (process-run cmd arg-list)))
	       (process-wait pid))
)
;)


(define (regster-log inl usr-id  area-id  cmd)
  (sauth-common:shell-do-as-adm
        (lambda ()
         (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sretrieve " inl "'," usr-id ","  area-id ", 'cat' )")))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Check user types
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;check if a user is an admin
(define (is-admin username)
   (let* ((admin #f))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM  users where users.username = '" username "'")))))
        (if (not (null? data-row))
             (let ((col  (car data-row)))
             (if (equal? col "yes")
                   (set! admin #t)))))))  	        
admin))


;;check if a user is an read-admin
(define (is-read-admin username)
   (let* ((admin #f))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM  users where users.username = '" username "'")))))
        (if (not (null? data-row))
             (let ((col  (car data-row)))
             (if (equal? col "read-admin")
                   (set! admin #t)))))))  	        
admin))


;;check if user has specifc role for a area
(define (is-user role username area)
  (let* ((has-access #f))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT  permissions.access_type, permissions.expiration FROM  users ,  areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "' and areas.code = '" area "'")))))
        (if (not (null? data-row))
           (begin
               (let* ((access-type  (car data-row))
                    (exdate (cadr data-row)))
               (if (not (null? exdate)) 
               (begin 
                  (let ((valid (is-access-valid  exdate)))
                   ;(print valid) 
                  (if (and (equal? access-type role)
                        (equal? valid #t))
                   (set! has-access #t))))
                (print "Access expired"))))))))
 ;(print has-access)
has-access))

(define (is-access-valid exp-str)
    (let* ((ret-val #f )
           (date-parts  (string-split exp-str "/"))
           (yr (string->number (car date-parts)))
           (month (string->number(car (cdr date-parts)))) 
           (day (string->number(caddr date-parts)))
           (exp-date (make-date 0 0 0 0 day month yr )))
             ;(print  exp-date)
             ;(print (current-date))   
            (if (> (date-compare exp-date  (current-date)) 0)
             (set! ret-val #t))
   ;(print ret-val)
   ret-val))


;check if area exists
(define (area-exists area)
   (let* ((area-defined #f))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  areas where areas.code = '" area "'")))))
           (if (not (null? data-row))
                 (set! area-defined #t)))))
area-defined))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Get Record from database
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;gets area id by code 
(define (get-area area)
   (let* ((area-defined '()))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  areas where areas.code = '" area "'")))))
          (set!  area-defined data-row))))
area-defined))

;get id of users table by user name 
(define (get-user user)
  (let* ((user-defined '()))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  users where users.username = '" user "'")))))
          (set!  user-defined data-row))))
user-defined))

;get permissions id by userid and area id 
(define (get-perm userid areaid)
  (let* ((user-defined '()))
    (sauthorize:db-do  (lambda (db)
          (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  permissions where user_id = " userid " and area_id = " areaid)))))
         (set!  user-defined data-row))))

user-defined))

(define (get-restrictions base-path usr)
(let* ((user-defined '()))
    (sauthorize:db-do  (lambda (db)
          (let* ((data-row (query fetch (sql db (conc "SELECT  restriction FROM areas, users, permissions where  areas.id = permissions.area_id and users.id =  permissions.user_id and  users.username = '" usr "' and areas.basepath = '" base-path "'")))))
         ;(print data-row) 
         (set!  user-defined data-row))))
    ;   (print user-defined)
  (if (null? user-defined)
      ""
      (car user-defined))))


(define (get-obj-by-path path)
   (let* ((obj '()))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT  code,exe_name, id, basepath FROM  areas where areas.basepath = '" path "'")))))
         (set!  obj data-row))))
obj))

(define (get-obj-by-code code )
  (let* ((obj '()))
    (sauthorize:db-do  (lambda (db)
        ;(print (conc "SELECT  code, exe_name,  id, basepath, required_grps  FROM  areas where areas.code = '" code "'"))
        (let* ((data-row (query fetch (sql db (conc "SELECT  code, exe_name,  id, basepath, required_grps  FROM  areas where areas.code = '" code "'")))))
         ;(print data-row)
         (set!  obj data-row)
         ;(print obj) 
        )))
    (if (not (null? obj))
          (begin
          (let* ((req-grp (caddr (cddr obj))))
            (sauthorize:do-as-calling-user
             (lambda ()
 (sauth-common:check-user-groups req-grp))))))
obj))

(define (sauth-common:check-user-groups req-grp)
(let* ((current-groups  (get-groups) )
        (req-grp-list (string-split req-grp ",")))
        ;(print req-grp-list)
        (for-each (lambda (grp)
	  (let ((grp-info (group-information grp)))
               ;(print grp-info " " grp)
               (if (not (equal? grp-info #f))
               (begin
                 (if (not (member  (caddr grp-info) current-groups))
                  (begin 
                    (sauth:print-error (conc "Please wash " grp " group in your xterm!! " ))
                     (exit 1)))))))
	     req-grp-list)))

(define (get-obj-by-code-no-grp-validation code )
  (let* ((obj '()))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT  code, exe_name,  id, basepath  FROM  areas where areas.code = '" code "'")))))
         (set!  obj data-row))))
;(print obj)
obj))


(define (sauth-common:src-size path)
  (let ((output (with-input-from-pipe (conc "/usr/bin/du -s " path  "  | awk '{print $1}'")  
                 (lambda()
                  (read-line)))))
      (string->number output)))  

(define (sauth-common:space-left-at-dest path)
   (let* ((output  (run/string (pipe (df ,path ) (tail -1))))
         (size (caddr (cdr (string-split output " ")))))
  (string->number size)))

;; function to validate the users input for target path and resolve the path
;; TODO: Check for restriction in subpath 
(define (sauth-common:resolve-path  new current allowed-sheets)
   (let* ((target-path (append  current (string-split new "/")))
          (target-path-string (string-join target-path "/"))
          (normal-path (normalize-pathname target-path-string))
          (normal-list (string-split normal-path "/"))
           (ret '()))
   (if (string-contains   normal-path "..")
    (begin
      (print "ERROR: Path  " new " resolved outside target area ")
      #f)
    (if(equal? normal-path ".")
      ret  
    (if (not (member  (car normal-list) allowed-sheets))
      (begin
      (print "ERROR: Permision denied to  " new )
       #f)
    normal-list)))))

(define (sauth-common:get-target-path base-path-list ext-path top-areas base-path)
  (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas ))
          (usr (current-user-name) ) )
          (if (not (equal? resolved-path #f))
           (if (null? resolved-path) 
             #f
           (let* ((sheet (car resolved-path))
                   (restricted-areas (get-restrictions base-path usr))
                   (restrictions (conc ".*" (string-join (string-split restricted-areas ",") ".*|.*") ".*"))
           	   (target-path (if (null? (cdr resolved-path)) 
                                     base-path 
                                     (conc base-path "/" (string-join (cdr resolved-path) "/")))))
                    
	              
                           (if (and (not (equal? restricted-areas "" ))
                             (string-match (regexp  restrictions) target-path)) 
                           (begin
                              (sauth:print-error (conc "Access denied to " (string-join resolved-path "/")))
                              ;(exit 1)   
                            #f)
                             target-path)
                            
))
             #f)))

(define (sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list)
    (if (and (null? base-path-list) (equal? ext-path "") )
      (print (string-intersperse top-areas " "))
  (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas )))
           ;(print resolved-path)
           (if (not (equal? resolved-path #f))
           (if (null? resolved-path) 
             (print (string-intersperse top-areas " "))
           (let* ((target-path (sauth-common:get-target-path  base-path-list  ext-path top-areas base-path)))
                (print target-path)
                (if (not (equal? target-path #f))
                (begin 
                (cond
		  ((null? tail-cmd-list)
		     (run (pipe
      	      	      (ls "-lrt" ,target-path))))
		  ((not (equal? (car tail-cmd-list) "|"))
                         (print "ls cmd cannot accept " (string-join tail-cmd-list) " as an argument!!"))
                  (else  
                    (run (pipe
      	      	      (ls "-lrt" ,target-path)
                      (begin (system (string-join (cdr tail-cmd-list))))))))))))))))

(define (sauth:print-error msg)
  (with-output-to-port (current-error-port)
	(lambda ()
	       (print (conc "ERROR: " msg)))))









Added sauth-src/sauthorize.scm version [b4d2f08e65].















































































































































































































































































































































































































































































































































































































































































1
2
3
4
5
6
7
8
9
10
11
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
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
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
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
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
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
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
545
546
547
548
549
550
551
552
553
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
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+


;; Copyright 2006-2013, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest 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 General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

(use defstruct)
(use scsh-process)

(use srfi-18)
(use srfi-19)
(use refdb)

(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
;(declare (uses common))
;(declare (uses configf))
(declare (uses margs))

(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm. 
(include "sauth-paths.scm")
(include "sauth-common.scm")

;;
;; GLOBALS
;;
(define *verbosity* 1)
(define *logging* #f)
(define *exe-name* (pathname-file (car (argv))))
(define *sretrieve:current-tab-number* 0)
(define *args-hash* (make-hash-table))
(define sauthorize:help (conc "Usage: " *exe-name* " [action [params ...]]

  list                   		 			: list areas $USER's can access
  log                    		 			: get listing of recent activity.
  sauth  list-area-user <area code> 			: list the users that can access the area.
  sauth open <path> --group <grpname>                      : Open up an area. User needs to be the owner of the area to open it. 
              --code <unique short identifier for an area> 
              --retrieve|--publish [--additional-grps <comma separated unix grps requierd to get to the path>]
  sauth update <area code>  --retrieve|--publish             : update the binaries with the lates changes
  sauth grant <username> --area <area identifier>          : Grant permission to read or write to a area that is alrady opend up.    
             --expiration yyyy/mm/dd --retrieve|--publish 
             [--restrict <comma separated directory names> ]  
  sauth read-shell <area identifier>                       :  Open sretrieve shell for reading.  
  sauth write-shell <area identifier>                      :  Open spublish shell for writing.
   
Part of the Megatest tool suite.
Learn more at http://www.kiatoa.com/fossils/megatest

Version: " megatest-fossil-hash)) ;; "

;;======================================================================
;; RECORDS
;;======================================================================

;;======================================================================
;; DB
;;======================================================================

;; replace (strftime('%s','now')), with datetime('now'))
(define (sauthorize:initialize-db db)
  (for-each
   (lambda (qry)
     (exec (sql db qry)))
   (list 
    "CREATE TABLE IF NOT EXISTS actions
         (id           INTEGER PRIMARY KEY,
          cmd       TEXT NOT NULL,
          user_id      INTEGER NOT NULL,
          datetime     TIMESTAMP DEFAULT (datetime('now','localtime')),
          area_id      INTEGER NOT NULL,
          comment      TEXT DEFAULT '' NOT NULL,
          action_type  TEXT NOT NULL);"
        "CREATE TABLE IF NOT EXISTS users
         (id           INTEGER PRIMARY KEY,
          username     TEXT NOT NULL,
          is_admin     TEXT NOT NULL,
          datetime     TIMESTAMP DEFAULT (datetime('now','localtime'))
          );" 
          "CREATE TABLE IF NOT EXISTS areas
         (id           INTEGER PRIMARY KEY,
          basepath     TEXT NOT NULL,
          code         TEXT NOT NULL,
          exe_name     TEXT NOT NULL,
          required_grps TEXT DEFAULT '' NOT NULL,
          datetime     TIMESTAMP DEFAULT (datetime('now','localtime'))
          );" 
         "CREATE TABLE IF NOT EXISTS permissions
         (id              INTEGER PRIMARY KEY,
          access_type     TEXT NOT NULL,
          user_id         INTEGER NOT NULL,
          datetime        TIMESTAMP DEFAULT (datetime('now','localtime')),
          area_id         INTEGER NOT NULL,
          restriction     TEXT DEFAULT '' NOT NULL,
          expiration       TIMESTAMP DEFAULT NULL);"
    )))




(define (get-access-type args)
   (let loop ((hed (car args))
		 (tal (cdr args)))
                   (cond
                   ((equal? hed "--retrieve")
                      "retrieve") 
                   ((equal? hed "--publish")
                      "publish") 
                   ((equal? hed "--area-admin")
                      "area-admin")
                   ((equal? hed "--writer-admin")
                      "writer-admin")
                   ((equal? hed "--read-admin")
                      "read-admin")

                   ((null? tal)
                      #f) 
                   (else 
		  	(loop (car tal)(cdr tal))))))



;; check if user can gran access to an area
(define (can-grant-perm username access-type area)
   (let* ((isadmin (is-admin username))
          (is-area-admin (is-user "area-admin" username area ))
          (is-read-admin (is-user "read-admin" username area) )
          (is-writer-admin (is-user "writer-admin" username area) ) )
   (cond
   ((equal? isadmin  #t)
     #t)
   ((equal? is-area-admin #t ) 
     #t)
   ((and (equal? is-writer-admin #t ) (equal? access-type "retrieve"))
     #t)
   ((and (equal? is-read-admin #t ) (equal? access-type "retrieve"))
     #t)

   (else  
    #f))))

(define (sauthorize:list-areausers  area )
  (sauthorize:db-do  (lambda (db)
				     (print "Users having access to " area ":")
				     (query (for-each-row
					     (lambda (row)
                                               (let* ((exp-date (cadr row)))
                                                (if  (is-access-valid  exp-date)   
					        (apply print (intersperse row " | "))))))
					    (sql db (conc "SELECT users.username, permissions.expiration, permissions.access_type  FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and areas.code = '" area "'"))))))




; check if executable exists
(define (exe-exist exe access-type)
    (let* ((filepath (conc *exe-path* "/" access-type "/" exe)))
    ; (print filepath)
     (if (file-exists? filepath)
       #t
       #f)))

(define (copy-exe access-type exe-name group)
  (run-cmd "/bin/chmod" (list "g+w" (conc *exe-path* "/" access-type)))
  (let* ((spath (conc *exe-src*  "/s" access-type))
         (dpath (conc *exe-path* "/" access-type "/" exe-name)))
         (sauthorize:do-as-calling-user
        (lambda ()
            (run-cmd "/bin/cp" (list spath dpath )) 
            (if (equal? access-type "publish")
              (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
              (begin
               (if (equal? group "none")
                 (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
                 (begin   
                     (run-cmd "/bin/chgrp" (list group dpath))
                       (run-cmd "/bin/chmod" (list "g+s,o+rx" dpath))))))))
	(run-cmd "chmod" (list "g-w" (conc *exe-path* "/" access-type)))))

(define (get-exe-name path group)
   (let ((name ""))
   (sauthorize:do-as-calling-user
        (lambda ()
        (if (equal? (current-effective-user-id) (file-owner path)) 
          (set! name (conc (current-user-name) "_" group))
          (begin
            (print "You cannot open areas that you dont own!!")  
             (exit 1)))))
name))

(define (sauthorize:valid-unix-user username)
    (let* ((ret-val #f))
    (let-values (((inp oup pid)
              (process "/usr/bin/id" (list username))))
        (let loop ((inl (read-line inp)))
          (if (string? inl) 
          (if (string-contains inl  "No such user") 
            (set! ret-val #f)
             (set! ret-val #t)))   
          (if (eof-object? inl)
              (begin
                   (close-input-port inp)
                  (close-output-port oup))
            (loop (read-line inp)))))
            ret-val))


;check if a paths/codes are vaid and if area is alrady open  
(define (open-area group path code access-type other-grps)
   (let* ((exe-name (get-exe-name path group))
           (path-obj (get-obj-by-path path))
           (code-obj (get-obj-by-code-no-grp-validation code)))
           ;(print path-obj)   
          (cond
            ((not (null? path-obj))
                (if (equal? code (car path-obj))
                  (begin
                     (if (equal? exe-name (cadr path-obj))
                        (begin
                            (if (not (exe-exist exe-name  access-type))
                                 (copy-exe access-type exe-name group)
                                 (begin 
                                  (print "Area already open!!")
                                  (exit 1))))   
			(begin
                           (if (not (exe-exist exe-name  access-type))
                                 (copy-exe access-type exe-name group))
                           ;; update exe-name  in db 
                      (sauthorize:db-do   (lambda (db)
                         (sauthorize:db-qry db (conc "update areas set exe_name = '" exe-name "' where id = " (caddr path-obj)))))
                        )))
                   (begin
                       (print "Path " path " is registered with --code " (car path-obj) ". To open this area please execute following cmd: \n  sauthorize open " path " --group " group " --code " (car path-obj) " --" access-type )
                       (exit 1))))
                      
            ((not (null? code-obj))
                   (print "Code " code " is used for diffrent path. Please try diffrent value of --code" ) 
                   (exit 1))
            (else
               ; (print (exe-exist exe-name  access-type))
                (if (not (exe-exist exe-name  access-type))
                        (copy-exe access-type exe-name group))
                (sauthorize:db-do   (lambda (db)
               (print conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') ") 
             (sauthorize:db-qry db (conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') "))))))))

(define (user-has-open-perm user path access)
  (let* ((has-access #f)
         (eid (current-user-id)))
    (cond
     ((is-admin  user)
       (set! has-access #t ))
     ((and (is-read-admin  user) (equal? access "retrieve"))
       (set! has-access #t ))
     (else
        (print "User " user " does not have permission to open areas")))
        has-access))


;;check if user has group access
(define (is-group-washed req_grpid current-grp-list)
  (let loop ((hed (car current-grp-list))
		 (tal (cdr current-grp-list)))
                   (cond
                   ((equal? hed req_grpid)
                    #t)    
                   ((null? tal)
                      #f)
                   (else 
		  	(loop (car tal)(cdr tal))))))

;create executables with appropriate suids
(define (sauthorize:open user path group code access-type other-groups)
   (let* ((gpid (group-information group))
         (req_grpid (if (equal? group "none")
                      group 
                      (if (equal? gpid #f)
                           #f      
                     (caddr gpid))))
         (current-grp-list (get-groups))
         (valid-grp (if (equal? group "none")
                     group
                    (is-group-washed req_grpid current-grp-list))))
   (if (and (not (equal? group "none")) (equal? valid-grp #f ))
       (begin
       (print "Group " group " is not washed in the current xterm!!") 
       (exit 1)))) 
   (if (not (file-write-access? path))
     (begin
       (print "You can open areas owned by yourself. You do not have permissions to open path." path)
        (exit 1)))
   (if (user-has-open-perm user path access-type)
      (begin 
       ;(print "here")   
       (open-area group path code access-type other-groups)
       (sauthorize:grant user user code "2017/12/25"  "read-admin" "") 
       (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize open " path " --code " code " --group " group " --" access-type "'," (car (get-user user)) "," (car (get-area code)) ", 'open' )"))))
         (print "Area has " path "  been opened for " access-type ))))

(define (sauthorize:update username exe area access-type)
  (let* ((parts (string-split exe "_"))
         (owner (car parts))
         (group (cadr parts))
         (gpid (group-information group))
         (req_grpid (if (equal? group "none")
                      group 
                      (if (equal? gpid #f)
                           #f      
                     (caddr gpid))))
 
         (current-grp-list (get-groups))
         (valid-grp (if (equal? group "none")
                     group
                    (is-group-washed req_grpid current-grp-list))))
         (if (not (equal? username owner))
            (begin
              (print "You cannot update " area ". Only " owner " can update this area!!") 
               (exit 1)))
          (copy-exe access-type exe group)
           (print "recording action..")    
          (sauthorize:db-do   (lambda (db)
             
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize update " area " --" access-type "'," (car (get-user username)) "," (car (get-area area)) ", 'update' )"))))
         (print "Area has " area "  been update!!" )))

(define (sauthorize:grant auser guser area exp-date access-type restrict)
    ; check if user exist in db
    (let* ((area-obj (get-area area))
           (auser-obj (get-user auser)) 
           (user-obj (get-user guser)))
          
        (if (null? user-obj)
           (begin
            ;; is guser a valid unix user
            (if (not (sauthorize:valid-unix-user guser))
               (begin  
                (print "User " guser " is Invalid unix user!!")
                 (exit 1)))
            (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "insert into users (username, is_admin) values ('" guser "', 'no') "))))
             (set! user-obj (get-user guser))))
        (let* ((perm-obj (get-perm (car user-obj) (car area-obj))))
          (if(null? perm-obj)
          (begin   
            ;; insert permissions
            (sauthorize:db-do   (lambda (db)
            (sauthorize:db-qry db (conc "insert into permissions (access_type, user_id, area_id, restriction, expiration ) values ('" access-type "', " (car user-obj) ", " (car area-obj) ", '" restrict "', '" exp-date "')")))))
          (begin 
             ;update permissions
             (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "update permissions set access_type = '" access-type "' , restriction = '" restrict "', expiration =  '" exp-date "' where user_id = " (car user-obj) " and area_id = " (car area-obj)))))))
             (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize grant " guser " --area " area " --expiration " exp-date " --" access-type " --restrict " restrict "'," (car auser-obj) "," (car area-obj) ", 'grant' )"))))  
             (print "Permission has been sucessfully granted to user " guser))))

(define (sauthorize:process-action  username action . args)
   (case (string->symbol action)
   ((grant)
      (if (< (length args) 6)
         (begin 
	     (print  "ERROR: Missing arguments; " (string-intersperse args ", "))
	     (exit 1)))
       (let* ((remargs     (args:get-args args '("--area" "--expiration" "--restrict") '() args:arg-hash 0))
              (guser     (car args))
	      (restrict         (or (args:get-arg "--restrict") ""))
              (area         (or (args:get-arg "--area") ""))  
              (exp-date        (or (args:get-arg "--expiration") ""))
              (access-type (get-access-type remargs)))
	; (print  "version " guser " restrict " restrict )
        ; (print "area " area " exp-date " exp-date " access-type " access-type)
        (cond
           ((equal? guser "")
              (print "Username not found!! Try \"sauthorize help\" for useage ")
               (exit 1))   
           ((equal? area "")
              (print "Area not found!! Try \"sauthorize help\" for useage ")
              (exit 1)) 
           ((equal? access-type #f)
              (print "Access type not found!! Try \"sauthorize help\" for useage ")
               (exit 1)) 
           ((equal? exp-date "")
              (print "Date of expiration not found!! Try \"sauthorize help\" for useage ")
              (exit 1)))
           (if (not (area-exists area))
              (begin
              (print "Area does not exisit!!")
              (exit 1)))   
           (if (can-grant-perm username access-type area)
	   (begin
             (print "calling sauthorize:grant ") 
              (sauthorize:grant username guser area exp-date access-type restrict))   
           (begin
              (print "User " username " does not have permission to grant permissions to area " area "!!")
              (exit 1)))))
       ((list-area-user)
          (if (not (equal? (length args) 1))
              (begin
              (print "Missing argument area code to list-area-user ") 
              (exit 1)))
           (let* ((area (car args)))
           (if (not (area-exists area))
              (begin
              (print "Area does not exisit!!")
              (exit 1))) 
                                
                (sauthorize:list-areausers  area )
              ))
      ((read-shell)
          (if (not (equal? (length args) 1))
              (begin
              (print "Missing argument area code to read-shell ") 
              (exit 1)))
           (let* ((area (car args))
                  (code-obj (get-obj-by-code area)))
           (if (or (null? code-obj)
                   (not (exe-exist (cadr code-obj)  "retrieve")))
              (begin
              (print "Area " area " is not open for reading!!")
              (exit 1))) 
              (sauthorize:do-as-calling-user
             (lambda ()
                (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (list "shell" area ))))))
      ((write-shell)
          (if (not (equal? (length args) 1))
              (begin
              (print "Missing argument area code to read-shell ") 
              (exit 1)))
           (let* ((area (car args))
                  (code-obj (get-obj-by-code area)))
           (if (or (null? code-obj)
                   (not (exe-exist (cadr code-obj)  "publish")))
              (begin
              (print "Area " area " is not open for Writing!!")
              (exit 1))) 
              (sauthorize:do-as-calling-user
             (lambda ()
                (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (list "shell" area))))))
      ((publish)
          (if (< (length args) 2)
              (begin
              (print "Missing argument to publish. \n publish <action> <area> [opts] ") 
              (exit 1)))
            
           (let* ((action (car args))
                  (area (cadr args))
                  (cmd-args (cddr args)) 
                  (code-obj (get-obj-by-code area)))
           ;(print "area " area)
           ;(print "code: " code-obj)  
           ;(print (exe-exist (cadr code-obj)  "publish")) 
           (if (or (null? code-obj)
                   (not (exe-exist (cadr code-obj)  "publish")))
              (begin
              (print "Area " area " is not open for writing!!")
              (exit 1)))
              ;(print "hear") 
              (sauthorize:do-as-calling-user
             (lambda ()
               ; (print  *exe-path* "/publish/" (cadr code-obj) action area cmd-args  )
                (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (append (list action area ) cmd-args))))))
      
     ((retrieve)
          (if (< (length args) 2)
              (begin
              (print "Missing argument to publish. \n publish <action> <area> [opts] ") 
              (exit 1)))
           (let* ((action (car args))
                  (area (cadr args))
                  (cmd-args (cddr args)) 
                  (code-obj (get-obj-by-code area)))
           (if (or (null? code-obj)
                   (not (exe-exist (cadr code-obj)  "retrieve")))
              (begin
              (print "Area " area " is not open for reading!!")
              (exit 1))) 
               ;(print (conc *exe-path* "/retrieve/" (cadr code-obj) " " action " " area " " (string-join cmd-args)))
              (sauthorize:do-as-calling-user
             (lambda ()
                (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (append (list action area ) cmd-args))))))

 
 
      ((open)
         (if (< (length args) 6)
              (begin
              (print "sauthorize open cmd takes 6 arguments!! \n Useage: sauthorize open <path> --group <grpname> --code <unique short identifier for an area> --retrieve|--publish") 
              (exit 1)))
         (let* ((remargs     (args:get-args args '("--group" "--code" "--additional-grps") '() args:arg-hash 0))
              (path     (car args))
	      (group         (or (args:get-arg "--group") ""))
              (area         (or (args:get-arg "--code") ""))
              (other-grps          (or (args:get-arg "--additional-grps") ""))     
              (access-type (get-access-type remargs)))
                
              (cond
                ((equal? path "")
                  (print "path not found!! Try \"sauthorize help\" for useage ")
                  (exit 1))   
                ((equal? area "")
                  (print "--code not found!! Try \"sauthorize help\" for useage ")
                  (exit 1)) 
                ((equal? access-type #f)
                  (print "Access type not found!! Try \"sauthorize help\" for useage ")
                  (exit 1)) 
                ((and (not (equal? access-type "publish")) 
                  (not (equal? access-type "retrieve")))
                  (print "Access type can be eiter --retrieve or --publish !! Try \"sauthorize help\" for useage ")
                  (exit 1)))
                ; (print other-grps) 
                (sauthorize:open username path group area access-type other-grps)))
         ((update)
            (if (< (length args) 2)
              (begin
              (print "sauthorize update cmd takes 2 arguments!! \n Useage: sauthorize update <area-code> --retrieve|--publish") 
              (exit 1)))
              (let* ((area (car args))
                     (code-obj (get-obj-by-code area))
                    (access-type (get-access-type (cdr args))))
               (if  (and (not (equal? access-type "publish")) (not (equal? access-type "retrieve")))
                  (begin 
                  (print "Access type can be --retrieve|--publish ")
                  (exit 1)))
              (if (or (null? code-obj)
                   (not (exe-exist (cadr code-obj)  access-type)))
              (begin
              (print "Area " area " is not open for reading!!")
              (exit 1))) 
              (sauthorize:update username (cadr code-obj) area access-type ))) 
         ((area-admin)
           (let* ((usr (car args))
                  (usr-obj (get-user usr))
                  (user-id (car (get-user username))))
           
                (if (is-admin  username)
                (begin
                  ; (print usr-obj) 
                  (if (null? usr-obj)
                    (begin
                        (sauthorize:db-do   (lambda (db)
              ;(print (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )"))
             (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )")))))
               (begin
                ; (print (conc "update users set is_admin = 'no' where id = " (car usr-obj) ))
                 (sauthorize:db-do   (lambda (db)
                (sauthorize:db-qry db (conc "update users set is_admin = 'read-admin' where id = " (car usr-obj)))))))
                (print "User " usr " is updated with area-admin access!"))
                (print "Admin only function"))
                (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('area-admin " usr " ', " user-id ",0, 'area-admin ')" )))))) 
          ((mk-admin)
           (let* ((usr (car args))
                  (usr-obj (get-user usr))
                  (user-id (car (get-user username))))
                (if (not (sauthorize:valid-unix-user usr))
               (begin  
                (print "User " usr " is Invalid unix user!!")
                 (exit 1)))

                (if (member  username  *super-users*)
                (begin
                  (if (null? usr-obj)
                    (begin
                        (sauthorize:db-do   (lambda (db)
                           (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'yes' )")))))
               (begin
                 (sauthorize:db-do   (lambda (db)
                (sauthorize:db-qry db (conc "update users set is_admin = 'yes' where id = " (car usr-obj)))))))
                (print "User " usr " is updated with admin access!"))
                (print "Super-Admin only function"))
                (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('mk-admin " usr " ', " user-id ",0, 'mk-admin ')" )))))) 

         ((register-log)
            (if (< (length args) 4)
                (print "Invalid arguments"))
             ;(print args)
             (let* ((cmd-line (car args))
                     (user-id (cadr args))
                     (area-id (caddr args))
                     (user-obj (get-user username))
                      (cmd (cadddr args)))
                
               (if (and (not (null? user-obj)) (equal? user-id (number->string(car user-obj))))
                (begin 
                (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('" cmd-line"', " user-id "," area-id ", '" cmd "')" )))))
                (print "You ar not authorised to run this cmd")

)))     

       
      (else (print 0 "Unrecognised command " action))))
  
(define (main)
  (let* ((args      (argv))
	 (prog      (car args))
	 (rema      (cdr args))
         (username     (current-user-name)))
    ;; preserve the exe data in the config file
    (cond
     ;; one-word commands
     ((eq? (length rema) 1)
      (case (string->symbol (car rema))
	((help -h -help --h --help)
	 (print sauthorize:help))
	((list)
            
          (sauthorize:db-do  (lambda (db)
				     (print "My Area accesses: ")
				     (query (for-each-row
					     (lambda (row)
                                               (let* ((exp-date (car row)))
                                                (if  (is-access-valid  exp-date)     
					           (apply print (intersperse (cdr row) " | "))))))
					    (sql db (conc "SELECT permissions.expiration, areas.basepath, areas.code, permissions.access_type  FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "'"))))))
         
	((log)
	 (sauthorize:db-do  (lambda (db)
				     (print "Logs : ")
				     (query (for-each-row
					     (lambda (row)
                                                   
					       (apply print (intersperse row " | "))))
					    (sql db "SELECT actions.cmd, users.username, actions.action_type, actions.datetime, areas.code  FROM actions, users, areas where actions.user_id = users.id and actions.area_id = areas.id ")))))
	(else
	 (print "ERROR: Unrecognised command. Try \"sauthorize help\""))))
     ;; multi-word commands
     ((null? rema)(print sauthorize:help))
     ((>= (length rema) 2)
      (apply sauthorize:process-action username (car rema)(cdr rema)))
     (else (debug:print 0 "ERROR: Unrecognised command. Try \"sauthorize help\"")))))

(main)


      








Deleted sauthorize.scm version [b4d2f08e65].



1
2
3
4
5
6
7
8
9
10
11
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
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
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
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
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
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
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
545
546
547
548
549
550
551
552
553
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
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651













































































































































































































































































































































































































































































































































































































































































-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-


;; Copyright 2006-2013, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest 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 General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

(use defstruct)
(use scsh-process)

(use srfi-18)
(use srfi-19)
(use refdb)

(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
;(declare (uses common))
;(declare (uses configf))
(declare (uses margs))

(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm. 
(include "sauth-paths.scm")
(include "sauth-common.scm")

;;
;; GLOBALS
;;
(define *verbosity* 1)
(define *logging* #f)
(define *exe-name* (pathname-file (car (argv))))
(define *sretrieve:current-tab-number* 0)
(define *args-hash* (make-hash-table))
(define sauthorize:help (conc "Usage: " *exe-name* " [action [params ...]]

  list                   		 			: list areas $USER's can access
  log                    		 			: get listing of recent activity.
  sauth  list-area-user <area code> 			: list the users that can access the area.
  sauth open <path> --group <grpname>                      : Open up an area. User needs to be the owner of the area to open it. 
              --code <unique short identifier for an area> 
              --retrieve|--publish [--additional-grps <comma separated unix grps requierd to get to the path>]
  sauth update <area code>  --retrieve|--publish             : update the binaries with the lates changes
  sauth grant <username> --area <area identifier>          : Grant permission to read or write to a area that is alrady opend up.    
             --expiration yyyy/mm/dd --retrieve|--publish 
             [--restrict <comma separated directory names> ]  
  sauth read-shell <area identifier>                       :  Open sretrieve shell for reading.  
  sauth write-shell <area identifier>                      :  Open spublish shell for writing.
   
Part of the Megatest tool suite.
Learn more at http://www.kiatoa.com/fossils/megatest

Version: " megatest-fossil-hash)) ;; "

;;======================================================================
;; RECORDS
;;======================================================================

;;======================================================================
;; DB
;;======================================================================

;; replace (strftime('%s','now')), with datetime('now'))
(define (sauthorize:initialize-db db)
  (for-each
   (lambda (qry)
     (exec (sql db qry)))
   (list 
    "CREATE TABLE IF NOT EXISTS actions
         (id           INTEGER PRIMARY KEY,
          cmd       TEXT NOT NULL,
          user_id      INTEGER NOT NULL,
          datetime     TIMESTAMP DEFAULT (datetime('now','localtime')),
          area_id      INTEGER NOT NULL,
          comment      TEXT DEFAULT '' NOT NULL,
          action_type  TEXT NOT NULL);"
        "CREATE TABLE IF NOT EXISTS users
         (id           INTEGER PRIMARY KEY,
          username     TEXT NOT NULL,
          is_admin     TEXT NOT NULL,
          datetime     TIMESTAMP DEFAULT (datetime('now','localtime'))
          );" 
          "CREATE TABLE IF NOT EXISTS areas
         (id           INTEGER PRIMARY KEY,
          basepath     TEXT NOT NULL,
          code         TEXT NOT NULL,
          exe_name     TEXT NOT NULL,
          required_grps TEXT DEFAULT '' NOT NULL,
          datetime     TIMESTAMP DEFAULT (datetime('now','localtime'))
          );" 
         "CREATE TABLE IF NOT EXISTS permissions
         (id              INTEGER PRIMARY KEY,
          access_type     TEXT NOT NULL,
          user_id         INTEGER NOT NULL,
          datetime        TIMESTAMP DEFAULT (datetime('now','localtime')),
          area_id         INTEGER NOT NULL,
          restriction     TEXT DEFAULT '' NOT NULL,
          expiration       TIMESTAMP DEFAULT NULL);"
    )))




(define (get-access-type args)
   (let loop ((hed (car args))
		 (tal (cdr args)))
                   (cond
                   ((equal? hed "--retrieve")
                      "retrieve") 
                   ((equal? hed "--publish")
                      "publish") 
                   ((equal? hed "--area-admin")
                      "area-admin")
                   ((equal? hed "--writer-admin")
                      "writer-admin")
                   ((equal? hed "--read-admin")
                      "read-admin")

                   ((null? tal)
                      #f) 
                   (else 
		  	(loop (car tal)(cdr tal))))))



;; check if user can gran access to an area
(define (can-grant-perm username access-type area)
   (let* ((isadmin (is-admin username))
          (is-area-admin (is-user "area-admin" username area ))
          (is-read-admin (is-user "read-admin" username area) )
          (is-writer-admin (is-user "writer-admin" username area) ) )
   (cond
   ((equal? isadmin  #t)
     #t)
   ((equal? is-area-admin #t ) 
     #t)
   ((and (equal? is-writer-admin #t ) (equal? access-type "retrieve"))
     #t)
   ((and (equal? is-read-admin #t ) (equal? access-type "retrieve"))
     #t)

   (else  
    #f))))

(define (sauthorize:list-areausers  area )
  (sauthorize:db-do  (lambda (db)
				     (print "Users having access to " area ":")
				     (query (for-each-row
					     (lambda (row)
                                               (let* ((exp-date (cadr row)))
                                                (if  (is-access-valid  exp-date)   
					        (apply print (intersperse row " | "))))))
					    (sql db (conc "SELECT users.username, permissions.expiration, permissions.access_type  FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and areas.code = '" area "'"))))))




; check if executable exists
(define (exe-exist exe access-type)
    (let* ((filepath (conc *exe-path* "/" access-type "/" exe)))
    ; (print filepath)
     (if (file-exists? filepath)
       #t
       #f)))

(define (copy-exe access-type exe-name group)
  (run-cmd "/bin/chmod" (list "g+w" (conc *exe-path* "/" access-type)))
  (let* ((spath (conc *exe-src*  "/s" access-type))
         (dpath (conc *exe-path* "/" access-type "/" exe-name)))
         (sauthorize:do-as-calling-user
        (lambda ()
            (run-cmd "/bin/cp" (list spath dpath )) 
            (if (equal? access-type "publish")
              (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
              (begin
               (if (equal? group "none")
                 (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
                 (begin   
                     (run-cmd "/bin/chgrp" (list group dpath))
                       (run-cmd "/bin/chmod" (list "g+s,o+rx" dpath))))))))
	(run-cmd "chmod" (list "g-w" (conc *exe-path* "/" access-type)))))

(define (get-exe-name path group)
   (let ((name ""))
   (sauthorize:do-as-calling-user
        (lambda ()
        (if (equal? (current-effective-user-id) (file-owner path)) 
          (set! name (conc (current-user-name) "_" group))
          (begin
            (print "You cannot open areas that you dont own!!")  
             (exit 1)))))
name))

(define (sauthorize:valid-unix-user username)
    (let* ((ret-val #f))
    (let-values (((inp oup pid)
              (process "/usr/bin/id" (list username))))
        (let loop ((inl (read-line inp)))
          (if (string? inl) 
          (if (string-contains inl  "No such user") 
            (set! ret-val #f)
             (set! ret-val #t)))   
          (if (eof-object? inl)
              (begin
                   (close-input-port inp)
                  (close-output-port oup))
            (loop (read-line inp)))))
            ret-val))


;check if a paths/codes are vaid and if area is alrady open  
(define (open-area group path code access-type other-grps)
   (let* ((exe-name (get-exe-name path group))
           (path-obj (get-obj-by-path path))
           (code-obj (get-obj-by-code-no-grp-validation code)))
           ;(print path-obj)   
          (cond
            ((not (null? path-obj))
                (if (equal? code (car path-obj))
                  (begin
                     (if (equal? exe-name (cadr path-obj))
                        (begin
                            (if (not (exe-exist exe-name  access-type))
                                 (copy-exe access-type exe-name group)
                                 (begin 
                                  (print "Area already open!!")
                                  (exit 1))))   
			(begin
                           (if (not (exe-exist exe-name  access-type))
                                 (copy-exe access-type exe-name group))
                           ;; update exe-name  in db 
                      (sauthorize:db-do   (lambda (db)
                         (sauthorize:db-qry db (conc "update areas set exe_name = '" exe-name "' where id = " (caddr path-obj)))))
                        )))
                   (begin
                       (print "Path " path " is registered with --code " (car path-obj) ". To open this area please execute following cmd: \n  sauthorize open " path " --group " group " --code " (car path-obj) " --" access-type )
                       (exit 1))))
                      
            ((not (null? code-obj))
                   (print "Code " code " is used for diffrent path. Please try diffrent value of --code" ) 
                   (exit 1))
            (else
               ; (print (exe-exist exe-name  access-type))
                (if (not (exe-exist exe-name  access-type))
                        (copy-exe access-type exe-name group))
                (sauthorize:db-do   (lambda (db)
               (print conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') ") 
             (sauthorize:db-qry db (conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') "))))))))

(define (user-has-open-perm user path access)
  (let* ((has-access #f)
         (eid (current-user-id)))
    (cond
     ((is-admin  user)
       (set! has-access #t ))
     ((and (is-read-admin  user) (equal? access "retrieve"))
       (set! has-access #t ))
     (else
        (print "User " user " does not have permission to open areas")))
        has-access))


;;check if user has group access
(define (is-group-washed req_grpid current-grp-list)
  (let loop ((hed (car current-grp-list))
		 (tal (cdr current-grp-list)))
                   (cond
                   ((equal? hed req_grpid)
                    #t)    
                   ((null? tal)
                      #f)
                   (else 
		  	(loop (car tal)(cdr tal))))))

;create executables with appropriate suids
(define (sauthorize:open user path group code access-type other-groups)
   (let* ((gpid (group-information group))
         (req_grpid (if (equal? group "none")
                      group 
                      (if (equal? gpid #f)
                           #f      
                     (caddr gpid))))
         (current-grp-list (get-groups))
         (valid-grp (if (equal? group "none")
                     group
                    (is-group-washed req_grpid current-grp-list))))
   (if (and (not (equal? group "none")) (equal? valid-grp #f ))
       (begin
       (print "Group " group " is not washed in the current xterm!!") 
       (exit 1)))) 
   (if (not (file-write-access? path))
     (begin
       (print "You can open areas owned by yourself. You do not have permissions to open path." path)
        (exit 1)))
   (if (user-has-open-perm user path access-type)
      (begin 
       ;(print "here")   
       (open-area group path code access-type other-groups)
       (sauthorize:grant user user code "2017/12/25"  "read-admin" "") 
       (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize open " path " --code " code " --group " group " --" access-type "'," (car (get-user user)) "," (car (get-area code)) ", 'open' )"))))
         (print "Area has " path "  been opened for " access-type ))))

(define (sauthorize:update username exe area access-type)
  (let* ((parts (string-split exe "_"))
         (owner (car parts))
         (group (cadr parts))
         (gpid (group-information group))
         (req_grpid (if (equal? group "none")
                      group 
                      (if (equal? gpid #f)
                           #f      
                     (caddr gpid))))
 
         (current-grp-list (get-groups))
         (valid-grp (if (equal? group "none")
                     group
                    (is-group-washed req_grpid current-grp-list))))
         (if (not (equal? username owner))
            (begin
              (print "You cannot update " area ". Only " owner " can update this area!!") 
               (exit 1)))
          (copy-exe access-type exe group)
           (print "recording action..")    
          (sauthorize:db-do   (lambda (db)
             
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize update " area " --" access-type "'," (car (get-user username)) "," (car (get-area area)) ", 'update' )"))))
         (print "Area has " area "  been update!!" )))

(define (sauthorize:grant auser guser area exp-date access-type restrict)
    ; check if user exist in db
    (let* ((area-obj (get-area area))
           (auser-obj (get-user auser)) 
           (user-obj (get-user guser)))
          
        (if (null? user-obj)
           (begin
            ;; is guser a valid unix user
            (if (not (sauthorize:valid-unix-user guser))
               (begin  
                (print "User " guser " is Invalid unix user!!")
                 (exit 1)))
            (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "insert into users (username, is_admin) values ('" guser "', 'no') "))))
             (set! user-obj (get-user guser))))
        (let* ((perm-obj (get-perm (car user-obj) (car area-obj))))
          (if(null? perm-obj)
          (begin   
            ;; insert permissions
            (sauthorize:db-do   (lambda (db)
            (sauthorize:db-qry db (conc "insert into permissions (access_type, user_id, area_id, restriction, expiration ) values ('" access-type "', " (car user-obj) ", " (car area-obj) ", '" restrict "', '" exp-date "')")))))
          (begin 
             ;update permissions
             (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "update permissions set access_type = '" access-type "' , restriction = '" restrict "', expiration =  '" exp-date "' where user_id = " (car user-obj) " and area_id = " (car area-obj)))))))
             (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize grant " guser " --area " area " --expiration " exp-date " --" access-type " --restrict " restrict "'," (car auser-obj) "," (car area-obj) ", 'grant' )"))))  
             (print "Permission has been sucessfully granted to user " guser))))

(define (sauthorize:process-action  username action . args)
   (case (string->symbol action)
   ((grant)
      (if (< (length args) 6)
         (begin 
	     (print  "ERROR: Missing arguments; " (string-intersperse args ", "))
	     (exit 1)))
       (let* ((remargs     (args:get-args args '("--area" "--expiration" "--restrict") '() args:arg-hash 0))
              (guser     (car args))
	      (restrict         (or (args:get-arg "--restrict") ""))
              (area         (or (args:get-arg "--area") ""))  
              (exp-date        (or (args:get-arg "--expiration") ""))
              (access-type (get-access-type remargs)))
	; (print  "version " guser " restrict " restrict )
        ; (print "area " area " exp-date " exp-date " access-type " access-type)
        (cond
           ((equal? guser "")
              (print "Username not found!! Try \"sauthorize help\" for useage ")
               (exit 1))   
           ((equal? area "")
              (print "Area not found!! Try \"sauthorize help\" for useage ")
              (exit 1)) 
           ((equal? access-type #f)
              (print "Access type not found!! Try \"sauthorize help\" for useage ")
               (exit 1)) 
           ((equal? exp-date "")
              (print "Date of expiration not found!! Try \"sauthorize help\" for useage ")
              (exit 1)))
           (if (not (area-exists area))
              (begin
              (print "Area does not exisit!!")
              (exit 1)))   
           (if (can-grant-perm username access-type area)
	   (begin
             (print "calling sauthorize:grant ") 
              (sauthorize:grant username guser area exp-date access-type restrict))   
           (begin
              (print "User " username " does not have permission to grant permissions to area " area "!!")
              (exit 1)))))
       ((list-area-user)
          (if (not (equal? (length args) 1))
              (begin
              (print "Missing argument area code to list-area-user ") 
              (exit 1)))
           (let* ((area (car args)))
           (if (not (area-exists area))
              (begin
              (print "Area does not exisit!!")
              (exit 1))) 
                                
                (sauthorize:list-areausers  area )
              ))
      ((read-shell)
          (if (not (equal? (length args) 1))
              (begin
              (print "Missing argument area code to read-shell ") 
              (exit 1)))
           (let* ((area (car args))
                  (code-obj (get-obj-by-code area)))
           (if (or (null? code-obj)
                   (not (exe-exist (cadr code-obj)  "retrieve")))
              (begin
              (print "Area " area " is not open for reading!!")
              (exit 1))) 
              (sauthorize:do-as-calling-user
             (lambda ()
                (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (list "shell" area ))))))
      ((write-shell)
          (if (not (equal? (length args) 1))
              (begin
              (print "Missing argument area code to read-shell ") 
              (exit 1)))
           (let* ((area (car args))
                  (code-obj (get-obj-by-code area)))
           (if (or (null? code-obj)
                   (not (exe-exist (cadr code-obj)  "publish")))
              (begin
              (print "Area " area " is not open for Writing!!")
              (exit 1))) 
              (sauthorize:do-as-calling-user
             (lambda ()
                (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (list "shell" area))))))
      ((publish)
          (if (< (length args) 2)
              (begin
              (print "Missing argument to publish. \n publish <action> <area> [opts] ") 
              (exit 1)))
            
           (let* ((action (car args))
                  (area (cadr args))
                  (cmd-args (cddr args)) 
                  (code-obj (get-obj-by-code area)))
           ;(print "area " area)
           ;(print "code: " code-obj)  
           ;(print (exe-exist (cadr code-obj)  "publish")) 
           (if (or (null? code-obj)
                   (not (exe-exist (cadr code-obj)  "publish")))
              (begin
              (print "Area " area " is not open for writing!!")
              (exit 1)))
              ;(print "hear") 
              (sauthorize:do-as-calling-user
             (lambda ()
               ; (print  *exe-path* "/publish/" (cadr code-obj) action area cmd-args  )
                (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (append (list action area ) cmd-args))))))
      
     ((retrieve)
          (if (< (length args) 2)
              (begin
              (print "Missing argument to publish. \n publish <action> <area> [opts] ") 
              (exit 1)))
           (let* ((action (car args))
                  (area (cadr args))
                  (cmd-args (cddr args)) 
                  (code-obj (get-obj-by-code area)))
           (if (or (null? code-obj)
                   (not (exe-exist (cadr code-obj)  "retrieve")))
              (begin
              (print "Area " area " is not open for reading!!")
              (exit 1))) 
               ;(print (conc *exe-path* "/retrieve/" (cadr code-obj) " " action " " area " " (string-join cmd-args)))
              (sauthorize:do-as-calling-user
             (lambda ()
                (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (append (list action area ) cmd-args))))))

 
 
      ((open)
         (if (< (length args) 6)
              (begin
              (print "sauthorize open cmd takes 6 arguments!! \n Useage: sauthorize open <path> --group <grpname> --code <unique short identifier for an area> --retrieve|--publish") 
              (exit 1)))
         (let* ((remargs     (args:get-args args '("--group" "--code" "--additional-grps") '() args:arg-hash 0))
              (path     (car args))
	      (group         (or (args:get-arg "--group") ""))
              (area         (or (args:get-arg "--code") ""))
              (other-grps          (or (args:get-arg "--additional-grps") ""))     
              (access-type (get-access-type remargs)))
                
              (cond
                ((equal? path "")
                  (print "path not found!! Try \"sauthorize help\" for useage ")
                  (exit 1))   
                ((equal? area "")
                  (print "--code not found!! Try \"sauthorize help\" for useage ")
                  (exit 1)) 
                ((equal? access-type #f)
                  (print "Access type not found!! Try \"sauthorize help\" for useage ")
                  (exit 1)) 
                ((and (not (equal? access-type "publish")) 
                  (not (equal? access-type "retrieve")))
                  (print "Access type can be eiter --retrieve or --publish !! Try \"sauthorize help\" for useage ")
                  (exit 1)))
                ; (print other-grps) 
                (sauthorize:open username path group area access-type other-grps)))
         ((update)
            (if (< (length args) 2)
              (begin
              (print "sauthorize update cmd takes 2 arguments!! \n Useage: sauthorize update <area-code> --retrieve|--publish") 
              (exit 1)))
              (let* ((area (car args))
                     (code-obj (get-obj-by-code area))
                    (access-type (get-access-type (cdr args))))
               (if  (and (not (equal? access-type "publish")) (not (equal? access-type "retrieve")))
                  (begin 
                  (print "Access type can be --retrieve|--publish ")
                  (exit 1)))
              (if (or (null? code-obj)
                   (not (exe-exist (cadr code-obj)  access-type)))
              (begin
              (print "Area " area " is not open for reading!!")
              (exit 1))) 
              (sauthorize:update username (cadr code-obj) area access-type ))) 
         ((area-admin)
           (let* ((usr (car args))
                  (usr-obj (get-user usr))
                  (user-id (car (get-user username))))
           
                (if (is-admin  username)
                (begin
                  ; (print usr-obj) 
                  (if (null? usr-obj)
                    (begin
                        (sauthorize:db-do   (lambda (db)
              ;(print (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )"))
             (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )")))))
               (begin
                ; (print (conc "update users set is_admin = 'no' where id = " (car usr-obj) ))
                 (sauthorize:db-do   (lambda (db)
                (sauthorize:db-qry db (conc "update users set is_admin = 'read-admin' where id = " (car usr-obj)))))))
                (print "User " usr " is updated with area-admin access!"))
                (print "Admin only function"))
                (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('area-admin " usr " ', " user-id ",0, 'area-admin ')" )))))) 
          ((mk-admin)
           (let* ((usr (car args))
                  (usr-obj (get-user usr))
                  (user-id (car (get-user username))))
                (if (not (sauthorize:valid-unix-user usr))
               (begin  
                (print "User " usr " is Invalid unix user!!")
                 (exit 1)))

                (if (member  username  *super-users*)
                (begin
                  (if (null? usr-obj)
                    (begin
                        (sauthorize:db-do   (lambda (db)
                           (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'yes' )")))))
               (begin
                 (sauthorize:db-do   (lambda (db)
                (sauthorize:db-qry db (conc "update users set is_admin = 'yes' where id = " (car usr-obj)))))))
                (print "User " usr " is updated with admin access!"))
                (print "Super-Admin only function"))
                (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('mk-admin " usr " ', " user-id ",0, 'mk-admin ')" )))))) 

         ((register-log)
            (if (< (length args) 4)
                (print "Invalid arguments"))
             ;(print args)
             (let* ((cmd-line (car args))
                     (user-id (cadr args))
                     (area-id (caddr args))
                     (user-obj (get-user username))
                      (cmd (cadddr args)))
                
               (if (and (not (null? user-obj)) (equal? user-id (number->string(car user-obj))))
                (begin 
                (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('" cmd-line"', " user-id "," area-id ", '" cmd "')" )))))
                (print "You ar not authorised to run this cmd")

)))     

       
      (else (print 0 "Unrecognised command " action))))
  
(define (main)
  (let* ((args      (argv))
	 (prog      (car args))
	 (rema      (cdr args))
         (username     (current-user-name)))
    ;; preserve the exe data in the config file
    (cond
     ;; one-word commands
     ((eq? (length rema) 1)
      (case (string->symbol (car rema))
	((help -h -help --h --help)
	 (print sauthorize:help))
	((list)
            
          (sauthorize:db-do  (lambda (db)
				     (print "My Area accesses: ")
				     (query (for-each-row
					     (lambda (row)
                                               (let* ((exp-date (car row)))
                                                (if  (is-access-valid  exp-date)     
					           (apply print (intersperse (cdr row) " | "))))))
					    (sql db (conc "SELECT permissions.expiration, areas.basepath, areas.code, permissions.access_type  FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "'"))))))
         
	((log)
	 (sauthorize:db-do  (lambda (db)
				     (print "Logs : ")
				     (query (for-each-row
					     (lambda (row)
                                                   
					       (apply print (intersperse row " | "))))
					    (sql db "SELECT actions.cmd, users.username, actions.action_type, actions.datetime, areas.code  FROM actions, users, areas where actions.user_id = users.id and actions.area_id = areas.id ")))))
	(else
	 (print "ERROR: Unrecognised command. Try \"sauthorize help\""))))
     ;; multi-word commands
     ((null? rema)(print sauthorize:help))
     ((>= (length rema) 2)
      (apply sauthorize:process-action username (car rema)(cdr rema)))
     (else (debug:print 0 "ERROR: Unrecognised command. Try \"sauthorize help\"")))))

(main)


      








Modified server.scm
from [5b645d5dff]
to [2a515d5d65].




︙


33
34
35
36
37
38
39
40

41
42
43
44
45
46
47

33
34
35
36
37
38
39

40
41
42
43
44
45
46
47








-
+








;;(declare (uses rpc-transport))
(declare (uses launch))
;; (declare (uses daemon))

(include "common_records.scm")
(include "db_records.scm")

(define (server:make-server-url hostport)
#;(define (server:make-server-url hostport)
  (if (not hostport)
      #f
      (conc "http://" (car hostport) ":" (cadr hostport))))

(define  *server-loop-heart-beat* (current-seconds))

;;======================================================================




︙


357
358
359
360
361
362
363
364

365
366
367
368
369
370
371

357
358
359
360
361
362
363

364
365
366
367
368
369
370
371








-
+








   #f)
  (match-let (((mod-time host port start-time server-id pid)
	       servr))
    (if (and host port)
	(conc host ":" port)
	#f))))

(define (server:get-client-signature) ;; BB> why is this proc named "get-"?  it returns nothing -- set! has not return value.
#;(define (server:get-client-signature) ;; BB> why is this proc named "get-"?  it returns nothing -- set! has not return value.
  (if *my-client-signature* *my-client-signature*
      (let ((sig (server:mk-signature)))
        (set! *my-client-signature* sig)
        *my-client-signature*)))

;; wait for server=start-last to be three seconds old
;;




︙


546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568

546
547
548
549
550
551
552









553
554
555
556
557
558
559








-
-
-
-
-
-
-
-
-








       (if (eof-object? inl)
	   (case (string->symbol res)
	     ((NOREPLY)  #f)
	     ((LOGIN_OK) #t)
	     (else       #f))
	   (loop (read-line) inl))))))

;; NOT USED (well, ok, reference in rpc-transport but otherwise not used).
;;
(define (server:login toppath)
  (lambda (toppath)
    (set! *db-last-access* (current-seconds)) ;; might not be needed.
    (if (equal? *toppath* toppath)
	#t
	#f)))

;; timeout is hms string: 1h 5m 3s, default is 1 minute
;;
(define (server:expiration-timeout)
  (let ((tmo (configf:lookup *configdat* "server" "timeout")))
    (if (and (string? tmo)
	     (common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below
        (* 3600 (string->number tmo))




︙







Deleted show-uncalled-procedures.scm version [0afd5cabda].



1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
































-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-

;;  Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest 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 General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;
(include "codescanlib.scm")

(define (show-danglers)
  (let* ((all-scm-files (glob "*.scm"))
         (xref (get-xref all-scm-files))
         (dangling-procs
          (map car (filter (lambda (x) (equal? 1 (length x))) xref))))
    (for-each print dangling-procs) ;; our product.
    ))

(show-danglers)

    








Modified tasks.scm
from [a73c5b318e]
to [e04991d46c].




︙


177
178
179
180
181
182
183
184

185
186

187
188
189
190
191
192
193

177
178
179
180
181
182
183

184
185

186
187
188
189
190
191
192
193








-
+

-
+








;; Server and client management
;;======================================================================

;; make-vector-record tasks hostinfo id interface port pubport transport pid hostname
(define (tasks:hostinfo-get-id          vec)    (vector-ref  vec 0))
(define (tasks:hostinfo-get-interface   vec)    (vector-ref  vec 1))
(define (tasks:hostinfo-get-port        vec)    (vector-ref  vec 2))
(define (tasks:hostinfo-get-pubport     vec)    (vector-ref  vec 3))
;; (define (tasks:hostinfo-get-pubport     vec)    (vector-ref  vec 3))
(define (tasks:hostinfo-get-transport   vec)    (vector-ref  vec 4))
(define (tasks:hostinfo-get-pid         vec)    (vector-ref  vec 5))
;; (define (tasks:hostinfo-get-pid         vec)    (vector-ref  vec 5))
(define (tasks:hostinfo-get-hostname    vec)    (vector-ref  vec 6))

(define (tasks:need-server run-id)
  (equal? (configf:lookup *configdat* "server" "required") "yes"))

;; no elegance here ...
;;




︙







Modified tdb.scm
from [6edff6262d]
to [107bd93069].




︙


373
374
375
376
377
378
379
380

381
382
383
384
385
386
387

373
374
375
376
377
378
379

380
381
382
383
384
385
386
387








-
+








		     (<   (tdb:step-get-id a)        (tdb:step-get-id b)))
		    (else #f)))))
    res))

;;
;; Move to steps.scm
;;
(define (tdb:get-compressed-steps comprsteps) ;; from tdb:get-steps-table
#;(define (tdb:get-compressed-steps comprsteps) ;; from tdb:get-steps-table
  (map (lambda (x)
	 ;; take advantage of the \n on time->string
	 (vector
	  (vector-ref x 0)
	  (let ((s (vector-ref x 1)))
	    (if (number? s)(seconds->time-string s) s))
	  (let ((s (vector-ref x 2)))




︙







Deleted trackback.scm version [b547b4460b].



1
2
3
4
5
6
7
8
9
10
11
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























































-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-

;;  Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest 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 General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

(include "codescanlib.scm")

;; show call paths for named procedure
(define (traceback-proc in-procname)
  (letrec* ((all-scm-files (glob "*.scm"))
            (xref (get-xref all-scm-files))
            (have (alist-ref (string->symbol in-procname) xref eq? #f))
            (lookup (lambda (path procname depth)
                      (let* ((upcone-temp (filter (lambda (x)
                                                    (eq? procname (car x)))
                                                  xref))
                             (upcone-temp2 (cond
                                            ((null? upcone-temp) '())
                                            (else (cdar upcone-temp))))
                             (upcone (filter
                                      (lambda (x) (not (eq? x procname)))
                                      upcone-temp2))
                             (uppath (cons procname path))
                             (updepth (add1 depth)))
                        (if (null? upcone)
                            (print  uppath)
                            (for-each (lambda (x)
                                        (if (not (member procname path))
                                            (lookup uppath x updepth) ))
                                      upcone))))))
           (if have
               (lookup '() (string->symbol in-procname) 0)
               (print "no such func - "in-procname))))


(if (eq? 1 (length (command-line-arguments)))
    (traceback-proc (car (command-line-arguments)))
    (print "Usage: trackback <procedure name>"))

(exit 0)
    








Added utils/Makefile.utils version [df13f8bb7e].











1
2
3
4
5
6
7

+
+
+
+
+
+
+

all : show-uncalled-procedures trackback

show-uncalled-procedures : show-uncalled-procedures.scm codescanlib.scm
	csc show-uncalled-procedures.scm

trackback : trackback.scm codescanlib.scm
	csc trackback.scm








Added utils/codescanlib.scm version [6e625610ce].




















































































































































1
2
3
4
5
6
7
8
9
10
11
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
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;;  Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest 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 General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

;; gotta compile with csc, doesn't work with csi -s for whatever reason

(use srfi-69)
(use matchable)
(use utils)
(use ports)
(use extras)
(use srfi-1)
(use posix)
(use srfi-12)

;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define (<procname> <args>) <body> )
(define (load-scm-file scm-file)
  ;;(print "load "scm-file)
  (handle-exceptions
   exn
   '()
   (with-input-from-string
       (conc "("
             (with-input-from-file scm-file read-all)
             ")" )
     read)))

;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file
;;   -- be advised:
;;      * this may be fooled by macros, since this code does not take them into account.
;;      * this code does only checks for form (define (<procname> ... ) <body>)
;;           so it excludes from reckoning
;;               - generated functions, as in things like foo-set! from defstructs,
;;               - define-inline, (
;;               - define procname (lambda ..
;;               - etc...
(define (get-toplevel-procs+file+args+body filename)
  (let* ((scm-tree (load-scm-file filename))
         (procs
          (filter identity
                  (map
                   (match-lambda 
                    [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ...
                    [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ...
                    [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ...
                    [('define (defname args ...) body ...) ;; match (define (procname <args>) <body>)
                     (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??)
                         (list defname filename args body)
                         #f)]
                    [else #f] ) scm-tree))))
    procs))


;; given a sexp, return a flat list of atoms in that sexp
(define (get-atoms-in-body body)
  (cond
   ((null? body) '())
   ((atom? body) (list body))
   (else
    (apply append (map get-atoms-in-body body)))))

;;  given a file, return a list of procname, file, list of atoms in said procname
(define (get-procs+file+atoms file)
  (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file))
         (res
          (map
           (lambda (item)
             (let* ((proc (car item))
                    (file (cadr item))
                    (args (caddr item))
                    (body (cadddr item))
                    (atoms (append (get-atoms-in-body args) (get-atoms-in-body body))))
               (list proc file atoms)))
           toplevel-proc-items)))
    res))

;; uniquify a list of atoms 
(define (unique-atoms lst)
  (let loop ((lst (flatten lst)) (res '()))
    (if (null? lst)
        (reverse res)
        (let ((c (car lst)))
          (loop (cdr lst) (if (member c res) res (cons c res)))))))

;; given a list of procname, filename, list of procs called from procname, cross reference and reverse
;; returning alist mapping procname to procname that calls said procname
(define (get-callers-alist all-procs+file+calls)
  (let* ((all-procs (map car all-procs+file+calls))
         (caller-ht (make-hash-table))) 
    ;; let's cross reference with a hash table
    (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs)
    (for-each (lambda (item)
               (let* ((proc (car item))
                      (file (cadr item))
                      (calls (caddr item)))
                 (for-each (lambda (callee)
                             (hash-table-set! caller-ht callee
                                              (cons proc
                                                    (hash-table-ref caller-ht callee))))
                           calls)))
              all-procs+file+calls)
    (map (lambda (x)
           (let ((k (car x))
                 (r (unique-atoms (cdr x))))
             (cons k r)))                    
         (hash-table->alist caller-ht))))

;; create a handy cross-reference of callees to callers in the form of an alist.
(define (get-xref all-scm-files)
  (let* ((all-procs+file+atoms
          (apply append (map get-procs+file+atoms all-scm-files)))
         (all-procs (map car all-procs+file+atoms))
         (all-procs+file+calls  ; proc calls things in calls list
          (map (lambda (item)
                 (let* ((proc (car item))
                        (file (cadr item))
                        (atoms (caddr item))
                        (calls
                         (filter identity
                                 (map
                                  (lambda (x)
                                    (if (and ;; (not (equal? x proc))  ;; uncomment to prevent listing self
                                         (member x all-procs))
                                        x
                                        #f))
                                  atoms))))
                   (list proc file calls)))
               all-procs+file+atoms))
         (callers (get-callers-alist all-procs+file+calls))) 
    callers))








Added utils/show-uncalled-procedures.scm version [9e9d6c8594].
































































































































































































1
2
3
4
5
6
7
8
9
10
11
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
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
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

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;;  Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest 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 General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

;; gotta compile with csc, doesn't work with csi -s for whatever reason

(use srfi-69)
(use matchable)
(use utils)
(use ports)
(use extras)
(use srfi-1)
(use posix)
(use srfi-12)

;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define (<procname> <args>) <body> )

(define (load-scm-file scm-file)
  ;;(print "load "scm-file)
  (handle-exceptions
   exn
   '()
   (with-input-from-string
       (conc "("
             (with-input-from-file scm-file read-all)
             ")" )
     read)))

;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file
;;   -- be advised:
;;      * this may be fooled by macros, since this code does not take them into account.
;;      * this code does only checks for form (define (<procname> ... ) <body>)
;;           so it excludes from reckoning
;;               - generated functions, as in things like foo-set! from defstructs,
;;               - define-inline, (
;;               - define procname (lambda ..
;;               - etc...
(define (get-toplevel-procs+file+args+body filename)
  (let* ((scm-tree (load-scm-file filename))
         (procs
          (filter identity
                  (map
                   (match-lambda 
                    [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ...
                    [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ...
                    [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ...
                    [('define (defname args ...) body ...) ;; match (define (procname <args>) <body>)
                     (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??)
                         (list defname filename args body)
                         #f)]
                    [else #f] ) scm-tree))))
    procs))


;; given a sexp, return a flat list of atoms in that sexp
(define (get-atoms-in-body body)
  (cond
   ((null? body) '())
   ((atom? body) (list body))
   (else
    (apply append (map get-atoms-in-body body)))))

;;  given a file, return a list of procname, file, list of atoms in said procname
(define (get-procs+file+atoms file)
  (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file))
         (res
          (map
           (lambda (item)
             (let* ((proc (car item))
                    (file (cadr item))
                    (args (caddr item))
                    (body (cadddr item))
                    (atoms (append (get-atoms-in-body args) (get-atoms-in-body body))))
               (list proc file atoms)))
           toplevel-proc-items)))
    res))

;; uniquify a list of atoms 
(define (unique-atoms lst)
  (let loop ((lst (flatten lst)) (res '()))
    (if (null? lst)
        (reverse res)
        (let ((c (car lst)))
          (loop (cdr lst) (if (member c res) res (cons c res)))))))

;; given a list of procname, filename, list of procs called from procname, cross reference and reverse
;; returning alist mapping procname to procname that calls said procname
(define (get-callers-alist all-procs+file+calls)
  (let* ((all-procs (map car all-procs+file+calls))
         (caller-ht (make-hash-table))) 
    ;; let's cross reference with a hash table
    (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs)
    (for-each (lambda (item)
               (let* ((proc (car item))
                      (file (cadr item))
                      (calls (caddr item)))
                 (for-each (lambda (callee)
                             (hash-table-set! caller-ht callee
                                              (cons proc
                                                    (hash-table-ref caller-ht callee))))
                           calls)))
              all-procs+file+calls)
    (map (lambda (x)
           (let ((k (car x))
                 (r (unique-atoms (cdr x))))
             (cons k r)))                    
         (hash-table->alist caller-ht))))

;; create a handy cross-reference of callees to callers in the form of an alist.
(define (get-xref all-scm-files)
  (let* ((all-procs+file+atoms
          (apply append (map get-procs+file+atoms all-scm-files)))
         (all-procs (map car all-procs+file+atoms))
         (all-procs+file+calls  ; proc calls things in calls list
          (map (lambda (item)
                 (let* ((proc (car item))
                        (file (cadr item))
                        (atoms (caddr item))
                        (calls
                         (filter identity
                                 (map
                                  (lambda (x)
                                    (if (and ;; (not (equal? x proc))  ;; uncomment to prevent listing self
                                         (member x all-procs))
                                        x
                                        #f))
                                  atoms))))
                   (list proc file calls)))
               all-procs+file+atoms))
         (callers (get-callers-alist all-procs+file+calls))) 
    callers))

(define (get-danglers)
  (let* ((all-scm-files (glob "*.scm"))
         (xref (get-xref all-scm-files))
         (dangling-procs
          (map car (filter (lambda (x) (equal? 1 (length x))) xref))))
    dangling-procs))

(define (read-ignore-file fname)
  (let ((ht (make-hash-table)))
    (if (file-exists? fname)
	(for-each
	 (lambda (x)
	   (hash-table-set! ht x #t))
	 (with-input-from-file fname
	   read-lines)))
    ht))

(define (show-danglers)
  (let ((ignores     (read-ignore-file "danglers-to-ignore.txt"))
	(danglers    (map get-stats (get-danglers))))
    ;; (print "ignores: " (hash-table->alist ignores))
    (for-each (lambda (dangler)
		(let* ((fnname (conc (cadr dangler))))
		  ;; (print "fnname="fnname" member: "(member fnname ignore-list))
		  (if (not (hash-table-exists? ignores fnname))
		      (apply print (intersperse  dangler "\t"))
		      #;(print "skipping "fnname))))
	      (sort danglers (lambda (a b)(< (car a)(car b)))))))

    ;; (for-each print dangling-procs) ;; our product.

(define (get-stats fn)
  (let* ((data  (with-input-from-pipe (conc "grep '"fn"' *.scm") read-lines))
	 (files (delete-duplicates
		 (map (lambda (entry)
			(car (string-split entry ":")))
		      data))))
    (list (length data) fn files)))

(show-danglers)

    








Added utils/trackback.scm version [b547b4460b].

























































1
2
3
4
5
6
7
8
9
10
11
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

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;;  Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest 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 General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

(include "codescanlib.scm")

;; show call paths for named procedure
(define (traceback-proc in-procname)
  (letrec* ((all-scm-files (glob "*.scm"))
            (xref (get-xref all-scm-files))
            (have (alist-ref (string->symbol in-procname) xref eq? #f))
            (lookup (lambda (path procname depth)
                      (let* ((upcone-temp (filter (lambda (x)
                                                    (eq? procname (car x)))
                                                  xref))
                             (upcone-temp2 (cond
                                            ((null? upcone-temp) '())
                                            (else (cdar upcone-temp))))
                             (upcone (filter
                                      (lambda (x) (not (eq? x procname)))
                                      upcone-temp2))
                             (uppath (cons procname path))
                             (updepth (add1 depth)))
                        (if (null? upcone)
                            (print  uppath)
                            (for-each (lambda (x)
                                        (if (not (member procname path))
                                            (lookup uppath x updepth) ))
                                      upcone))))))
           (if have
               (lookup '() (string->symbol in-procname) 0)
               (print "no such func - "in-procname))))


(if (eq? 1 (length (command-line-arguments)))
    (traceback-proc (car (command-line-arguments)))
    (print "Usage: trackback <procedure name>"))

(exit 0)
    











This page was generated in about
0.145s by
Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00