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 @@ -364,11 +364,11 @@ (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix))) (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 0 *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: #f)) 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 @@ -653,16 +653,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)) @@ -2474,11 +2474,12 @@ )) ;;====================================================================== ;; 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**"))))) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -2245,11 +2245,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) 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 ;; @@ -1690,11 +1690,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 ))) @@ -1718,11 +1719,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 ))) 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)) 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")) 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) +