Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -31,11 +31,11 @@ ;; ;;====================================================================== ;; 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 @@ -389,11 +389,11 @@ (debug:print-info 0 *default-log-port* "To restore megatest.db run megatest -archive replicacte-db -source archive-dir -time-stamp . 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:")) Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -31,12 +31,12 @@ (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*))) DELETED codescanlib.scm Index: codescanlib.scm ================================================================== --- codescanlib.scm +++ /dev/null @@ -1,144 +0,0 @@ -;; 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 . -;; - -;; 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 ( ) ) -(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 ( ... ) ) -;; 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 ) ) - (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)) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -663,16 +663,16 @@ ;;====================================================================== ;; 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)) @@ -2627,11 +2627,11 @@ ;;====================================================================== ;; 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**"))))) @@ -3611,14 +3611,14 @@ #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")) @@ -3634,11 +3634,11 @@ ;; ;;(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*) @@ -3661,11 +3661,11 @@ ;; (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 ADDED danglers-to-ignore.txt Index: danglers-to-ignore.txt ================================================================== --- /dev/null +++ danglers-to-ignore.txt @@ -0,0 +1,4 @@ +spublish:lst->path +megatest-param->mtutil-param +add-target-mapper +add-runname-mapper ADDED datashare-src/datashare.scm Index: datashare-src/datashare.scm ================================================================== --- /dev/null +++ datashare-src/datashare.scm @@ -0,0 +1,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 . + +(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 : List versions available in + options : -full, -vpatt patt + + publish : Publish data for area and with version + + get : Get a link to data, put the link in destpath + options : -i iteration + + update : 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 Index: datashare.scm ================================================================== --- datashare.scm +++ /dev/null @@ -1,825 +0,0 @@ - -;; 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 . - -(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 : List versions available in - options : -full, -vpatt patt - - publish : Publish data for area and with version - - get : Get a link to data, put the link in destpath - options : -i iteration - - update : 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) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1997,11 +1997,11 @@ ;; 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) @@ -2302,11 +2302,11 @@ 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) @@ -3321,11 +3321,11 @@ ;; 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) @@ -3452,11 +3452,11 @@ (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)))) @@ -3464,11 +3464,11 @@ 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))) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -102,11 +102,11 @@ #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? Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -55,11 +55,11 @@ ;; 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 ;; @@ -1692,11 +1692,12 @@ (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 ))) @@ -1720,11 +1721,12 @@ (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 ))) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -675,11 +675,12 @@ (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)))) -(define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f)) +;; 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 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))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -60,11 +60,15 @@ ) (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 @@ -886,31 +890,40 @@ ;; 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))) - (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))))) - ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) + (prereqs-not-met (runs:lazy-get-prereqs-not-met testdat run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) + (have-itemized (not (null? (lset-intersection eq? testmode '(itemmatch itemwait))))) (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 @@ -1152,12 +1165,10 @@ (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) '()))) @@ -1553,11 +1564,10 @@ 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 @@ -1772,11 +1782,13 @@ (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:testdat-prereqs-not-met-set! testdat (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) + (runs:lazy-get-prereqs-not-met testdat run-id waitons hed item-path + mode: testmode + 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 @@ -1843,11 +1855,11 @@ ((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) ) ) DELETED sauth-common.scm Index: sauth-common.scm ================================================================== --- sauth-common.scm +++ /dev/null @@ -1,328 +0,0 @@ -;; 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 . - - -;; 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 Index: sauth-src/sauth-common.scm ================================================================== --- /dev/null +++ sauth-src/sauth-common.scm @@ -0,0 +1,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 . + + +;; 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 Index: sauth-src/sauthorize.scm ================================================================== --- /dev/null +++ sauth-src/sauthorize.scm @@ -0,0 +1,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 . +;; + +(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 : list the users that can access the area. + sauth open --group : Open up an area. User needs to be the owner of the area to open it. + --code + --retrieve|--publish [--additional-grps ] + sauth update --retrieve|--publish : update the binaries with the lates changes + sauth grant --area : Grant permission to read or write to a area that is alrady opend up. + --expiration yyyy/mm/dd --retrieve|--publish + [--restrict ] + sauth read-shell : Open sretrieve shell for reading. + sauth write-shell : 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 [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 [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 --group --code --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 --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 Index: sauthorize.scm ================================================================== --- sauthorize.scm +++ /dev/null @@ -1,651 +0,0 @@ - -;; 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 . -;; - -(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 : list the users that can access the area. - sauth open --group : Open up an area. User needs to be the owner of the area to open it. - --code - --retrieve|--publish [--additional-grps ] - sauth update --retrieve|--publish : update the binaries with the lates changes - sauth grant --area : Grant permission to read or write to a area that is alrady opend up. - --expiration yyyy/mm/dd --retrieve|--publish - [--restrict ] - sauth read-shell : Open sretrieve shell for reading. - sauth write-shell : 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 [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 [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 --group --code --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 --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) - - - Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -35,11 +35,11 @@ ;; (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)) @@ -359,11 +359,11 @@ 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*))) DELETED show-uncalled-procedures.scm Index: show-uncalled-procedures.scm ================================================================== --- show-uncalled-procedures.scm +++ /dev/null @@ -1,30 +0,0 @@ -;; 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 . -;; -(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) - - Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -179,13 +179,13 @@ ;; 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")) Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -375,11 +375,11 @@ 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))) DELETED trackback.scm Index: trackback.scm ================================================================== --- trackback.scm +++ /dev/null @@ -1,53 +0,0 @@ -;; 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 . - -(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 ")) - -(exit 0) - ADDED utils/Makefile.utils Index: utils/Makefile.utils ================================================================== --- /dev/null +++ utils/Makefile.utils @@ -0,0 +1,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 Index: utils/codescanlib.scm ================================================================== --- /dev/null +++ utils/codescanlib.scm @@ -0,0 +1,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 . +;; + +;; 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 ( ) ) +(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 ( ... ) ) +;; 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 ) ) + (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 Index: utils/show-uncalled-procedures.scm ================================================================== --- /dev/null +++ utils/show-uncalled-procedures.scm @@ -0,0 +1,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 . +;; + +;; 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 ( ) ) + +(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 ( ... ) ) +;; 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 ) ) + (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 Index: utils/trackback.scm ================================================================== --- /dev/null +++ utils/trackback.scm @@ -0,0 +1,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 . + +(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 ")) + +(exit 0) +