Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -20,11 +20,11 @@ SHELL=/bin/bash PREFIX=$(PWD) CSCOPTS= INSTALL=install SRCFILES = common.scm items.scm launch.scm runconfig.scm \ - server.scm configf.scm db.scm keys.scm margs.scm \ + server.scm configf.scm db.scm margs.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ http-transport.scm filedb.scm tdb.scm client.scm mt.scm \ ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.scm \ subrun.scm portlogger.scm archive.scm env.scm \ diff-report.scm cgisetup/models/pgdb.scm @@ -111,11 +111,10 @@ configf.o \ db.o \ env.o \ http-transport.o \ items.o \ - keys.o \ launch.o \ lock-queue.o \ margs.o \ mt.o \ portlogger.o \ @@ -151,61 +150,76 @@ fossil wiki export java-script-lib > $(PREFIX)/share/js/jquery-3.1.0.slim.min.js $(PREFIX)/share/db/mt-pg.sql : mt-pg.sql mkdir -p $(PREFIX)/share/db $(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql + +# Include the generated dependency file +# include build.inc # Special dependencies for the module includes $(MOFILE) $(MOIMPFILES) : megatest-fossil-hash.scm -megatest.o : $(MOIMPFILES) -mofiles/commonmod.o : megatest-fossil-hash.scm -mofiles/dbmod.o \ - mofiles/servermod.o \ - mofiles/apimod.o \ - mofiles/dcommonmod.o \ - mofiles/ods.o : mofiles/commonmod.o mofiles/configfmod.o - -mofiles/dcommonmod.o : mofiles/configfmod.o mofiles/dbmod.o -mofiles/configfmod.o : mofiles/commonmod.o -# mofiles/dbmod.o : mofiles/configfmod.o -mofiles/rmtmod.o : mofiles/apimod.o -mofiles/servermod.o : mofiles/dbmod.o -common.o : mofiles/commonmod.o - -# commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm - -tests.o db.o launch.o runs.o dashboard-tests.o \ +# we are going to generate this by running make without -j +# and only adding the needed deps. The full deps have too many +# circular deps and can not (yet) be resolved. + +mofiles/configfmod.o mofiles/ods.o : mofiles/commonmod.o +mofiles/dbmod.o : mofiles/commonmod.o mofiles/ods.o mofiles/configfmod.o + +dcommon.o : mofiles/dcommonmod.o + + +# megatest.o : $(MOIMPFILES) +# mofiles/commonmod.o : megatest-fossil-hash.scm +# mofiles/dbmod.o \ +# mofiles/servermod.o \ +# mofiles/apimod.o \ +# mofiles/dcommonmod.o \ +# mofiles/ods.o : mofiles/commonmod.o mofiles/configfmod.o +# +# mofiles/dcommonmod.o : mofiles/configfmod.o mofiles/dbmod.o +# mofiles/configfmod.o : mofiles/commonmod.o +# # mofiles/dbmod.o : mofiles/configfmod.o +# mofiles/rmtmod.o : mofiles/apimod.o +# # mofiles/servermod.o : mofiles/dbmod.o +# common.o : mofiles/commonmod.o +# +# # commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm +# +# tests.o db.o launch.o runs.o dashboard-tests.o \ + dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o \ monitor.o dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm -dashboard.o : mofiles/apimod.o +# dashboard.o : mofiles/apimod.o tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o : run_records.scm -db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm +db.o ezsteps.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.scm -api.o rmt.o db.o : mofiles/apimod.o mofiles/dbmod.o mofiles/rmtmod.o mofiles/ods.o +# api.o rmt.o db.o : mofiles/apimod.o mofiles/dbmod.o mofiles/rmtmod.o mofiles/ods.o -megatest.o : megatest-fossil-hash.scm megatest-version.scm +mofiles/commonmod.o common.o megatest.o dashboard.o : megatest-fossil-hash.scm megatest-version.scm -rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm +# rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm common_records.scm : altdb.scm # mofiles/stml2.o : mofiles/cookie.o # configf.o : mofiles/commonmod.o vg.o dashboard.o : vg_records.scm megatest-version.scm -dcommon.o : mofiles/dcommonmod.o run_records.scm +dcommon.o : run_records.scm +# mofiles/dcommonmod.o mofiles/stml2.o : mofiles/cookie.o -mofiles/dbmod.o : mofiles/ods.o -mofiles/rmtmod.o : mofiles/dbmod.o +# mofiles/dbmod.o : mofiles/ods.o +# mofiles/rmtmod.o : mofiles/dbmod.o # # special include based modules # mofiles/pkts.o : pkts/pkts.scm # mofiles/stml2.o : cookie.o # # mofiles/mtargs.o : mtargs/mtargs.scm @@ -217,11 +231,11 @@ # Temporary while transitioning to new routine # runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm # for the modularized stuff -mofiles/rmtmod.o : mofiles/commonmod.o +# mofiles/rmtmod.o : mofiles/commonmod.o megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi @@ -475,12 +489,12 @@ fi if csi -ne '(use postgresql)';then \ echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\ fi -portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o - csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o +portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o launch.o lock-queue.o margs.o mt.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o + csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o launch.o lock-queue.o margs.o mt.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o # create a pdf dot graphviz diagram from notations in rmt.scm rmt.pdf : rmt.scm grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf ADDED attic/portlogger-example.scm Index: attic/portlogger-example.scm ================================================================== --- /dev/null +++ attic/portlogger-example.scm @@ -0,0 +1,21 @@ +;; 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 . + + +(declare (uses portlogger)) + +(print (apply portlogger:main (cdr (argv)))) ADDED build.inc Index: build.inc ================================================================== --- /dev/null +++ build.inc @@ -0,0 +1,288 @@ +# To regenerate this file do: +# (cd utils/;ck52 csc gendeps.scm) && ./utils/gendeps allunits *scm +# cp allunits.inc build.inc +# + +mofiles/apimod.o : mofiles/commonmod.o +api.o : rmt.o +api.o : db.o +api.o : tasks.o +api.o : mofiles/commonmod.o +api.o : mofiles/apimod.o +api.o : mofiles/dbmod.o +archive.o : db.o +archive.o : common.o +archive.o : mofiles/configfmod.o +archive.o : mofiles/commonmod.o +archive.o : mofiles/dbmod.o +client.o : common.o +client.o : db.o +client.o : mofiles/commonmod.o +client.o : mofiles/dbmod.o +client.o : rmt.o +client.o : mofiles/servermod.o +common.o : mofiles/commonmod.o +common.o : mofiles/dbmod.o +common.o : mofiles/configfmod.o +common.o : mofiles/servermod.o +mofiles/configfmod.o : mofiles/commonmod.o +configf.o : process.o +configf.o : env.o +configf.o : mofiles/commonmod.o +configf.o : mofiles/configfmod.o +dashboard-context-menu.o : common.o +dashboard-context-menu.o : db.o +dashboard-context-menu.o : gutils.o +dashboard-context-menu.o : rmt.o +dashboard-context-menu.o : ezsteps.o +dashboard-context-menu.o : subrun.o +dashboard-context-menu.o : mofiles/commonmod.o +dashboard-context-menu.o : mofiles/configfmod.o +dashboard-context-menu.o : mofiles/dbmod.o +dashboard-guimonitor.o : common.o +dashboard-guimonitor.o : db.o +dashboard-guimonitor.o : tasks.o +dashboard-guimonitor.o : mofiles/commonmod.o +dashboard-guimonitor.o : mofiles/dbmod.o +dashboard.o : common.o +dashboard.o : margs.o +dashboard.o : items.o +dashboard.o : db.o +dashboard.o : configf.o +dashboard.o : process.o +dashboard.o : launch.o +dashboard.o : runs.o +dashboard.o : dashboard-tests.o +dashboard.o : dashboard-guimonitor.o +dashboard.o : tree.o +dashboard.o : dcommon.o +dashboard.o : dashboard-context-menu.o +dashboard.o : vg.o +dashboard.o : subrun.o +dashboard.o : mt.o +dashboard.o : mofiles/commonmod.o +# dashboard.o : commonmod.import.o +dashboard.o : mofiles/configfmod.o +# dashboard.o : configfmod.import.o +dashboard.o : mofiles/dcommonmod.o +# dashboard.o : dcommonmod.import.o +dashboard.o : mofiles/apimod.o +dashboard.o : mofiles/dbmod.o +dashboard.o : mofiles/servermod.o +dashboard-tests.o : common.o +dashboard-tests.o : db.o +dashboard-tests.o : gutils.o +dashboard-tests.o : rmt.o +dashboard-tests.o : ezsteps.o +dashboard-tests.o : subrun.o +dashboard-tests.o : mofiles/commonmod.o +dashboard-tests.o : mofiles/configfmod.o +dashboard-tests.o : mofiles/dbmod.o +mofiles/dbmod.o : mofiles/commonmod.o +mofiles/dbmod.o : ods.o +mofiles/dbmod.o : mofiles/configfmod.o +db.o : common.o +db.o : client.o +db.o : mt.o +db.o : mofiles/commonmod.o +db.o : mofiles/configfmod.o +db.o : mofiles/dbmod.o +db.o : mofiles/servermod.o +mofiles/dcommonmod.o : mofiles/commonmod.o +mofiles/dcommonmod.o : mofiles/configfmod.o +dcommon.o : gutils.o +dcommon.o : db.o +dcommon.o : mofiles/commonmod.o +dcommon.o : mofiles/dbmod.o +dcommon.o : mofiles/configfmod.o +dcommon.o : mofiles/dcommonmod.o +dcommon.o : mofiles/servermod.o +diff-report.o : common.o +diff-report.o : rmt.o +diff-report.o : mofiles/commonmod.o +env.o : mofiles/commonmod.o +ezsteps.o : db.o +ezsteps.o : common.o +ezsteps.o : items.o +ezsteps.o : runconfig.o +ezsteps.o : mofiles/commonmod.o +ezsteps.o : mofiles/configfmod.o +ezsteps.o : mofiles/dbmod.o +genexample.o : mofiles/commonmod.o +http-transport.o : common.o +http-transport.o : db.o +http-transport.o : portlogger.o +http-transport.o : rmt.o +http-transport.o : mofiles/commonmod.o +http-transport.o : mofiles/configfmod.o +http-transport.o : mofiles/dbmod.o +http-transport.o : mofiles/servermod.o +index-tree.o : lock-queue.o +index-tree.o : db.o +index-tree.o : common.o +index-tree.o : items.o +index-tree.o : runconfig.o +index-tree.o : mofiles/commonmod.o +items.o : common.o +items.o : mofiles/commonmod.o +items.o : mofiles/configfmod.o +launch.o : subrun.o +launch.o : common.o +launch.o : configf.o +launch.o : db.o +launch.o : ezsteps.o +launch.o : mofiles/commonmod.o +launch.o : mofiles/configfmod.o +launch.o : mofiles/dbmod.o +lock-queue.o : common.o +lock-queue.o : tasks.o +lock-queue.o : mofiles/commonmod.o +megatest.o : common.o +megatest.o : margs.o +megatest.o : runs.o +megatest.o : launch.o +megatest.o : server.o +megatest.o : client.o +megatest.o : tests.o +megatest.o : genexample.o +megatest.o : db.o +megatest.o : tdb.o +megatest.o : mt.o +megatest.o : api.o +megatest.o : env.o +megatest.o : diff-report.o +megatest.o : mofiles/commonmod.o +# megatest.o : commonmod.import.o +megatest.o : mofiles/configfmod.o +# megatest.o : configfmod.import.o +megatest.o : ods.o +# megatest.o : ods.import.o +megatest.o : mofiles/dbmod.o +# megatest.o : dbmod.import.o +megatest.o : mofiles/servermod.o +# megatest.o : servermod.import.o +megatest.o : mofiles/apimod.o +# megatest.o : apimod.import.o +megatest.o : mofiles/rmtmod.o +# megatest.o : rmtmod.import.o +mlaunch.o : db.o +mlaunch.o : common.o +monitor.o : db.o +monitor.o : common.o +monitor.o : items.o +monitor.o : runconfig.o +mtexec.o : margs.o +mtexec.o : configf.o +mtexec.o : mofiles/configfmod.o +mt.o : db.o +mt.o : common.o +mt.o : tests.o +mt.o : rmt.o +mt.o : mofiles/commonmod.o +mt.o : mofiles/configfmod.o +mt.o : mofiles/dbmod.o +mtut.o : common.o +mtut.o : margs.o +mtut.o : configf.o +mtut.o : mofiles/commonmod.o +mtut.o : mofiles/configfmod.o +newdashboard.o : common.o +newdashboard.o : megatest-version.o +newdashboard.o : margs.o +newdashboard.o : mofiles/commonmod.o +newdashboard.o : mofiles/dbmod.o +newdashboard.o : dcommon.o +newdashboard.o : mofiles/configfmod.o +ods.o : mofiles/commonmod.o +portlogger.o : db.o +portlogger.o : mofiles/commonmod.o +portlogger.o : mofiles/configfmod.o +portlogger.o : mofiles/dbmod.o +process.o : mofiles/commonmod.o +mofiles/rmtmod.o : mofiles/commonmod.o +mofiles/rmtmod.o : mofiles/apimod.o +mofiles/rmtmod.o : mofiles/dbmod.o +rmt.o : api.o +rmt.o : http-transport.o +rmt.o : mofiles/commonmod.o +rmt.o : mofiles/apimod.o +rmt.o : mofiles/rmtmod.o +rmt.o : mofiles/dbmod.o +rmt.o : mofiles/configfmod.o +rmt.o : mofiles/servermod.o +runconfig.o : common.o +runconfig.o : mofiles/commonmod.o +runs.o : db.o +runs.o : common.o +runs.o : items.o +runs.o : runconfig.o +runs.o : tests.o +runs.o : server.o +runs.o : mt.o +runs.o : archive.o +runs.o : mofiles/commonmod.o +runs.o : mofiles/configfmod.o +runs.o : mofiles/dbmod.o +runs.o : mofiles/servermod.o +mofiles/servermod.o : mofiles/commonmod.o +mofiles/servermod.o : mofiles/configfmod.o +mofiles/servermod.o : mofiles/dbmod.o +server.o : common.o +server.o : db.o +server.o : http-transport.o +server.o : launch.o +server.o : mofiles/commonmod.o +server.o : mofiles/dbmod.o +server.o : mofiles/configfmod.o +server.o : mofiles/servermod.o +sharedat.o : configf.o +sharedat.o : margs.o +sharedat.o : megatest-version.o +spublish.o : margs.o +subrun.o : db.o +subrun.o : common.o +subrun.o : mt.o +subrun.o : mofiles/commonmod.o +subrun.o : mofiles/configfmod.o +subrun.o : mofiles/dbmod.o +synchash.o : db.o +synchash.o : server.o +synchash.o : mofiles/dbmod.o +tasks.o : db.o +tasks.o : rmt.o +tasks.o : common.o +tasks.o : cgisetup/models/pgdb.o +tasks.o : mofiles/commonmod.o +tasks.o : mofiles/configfmod.o +tasks.o : mofiles/dbmod.o +tcmt.o : margs.o +tcmt.o : rmt.o +tcmt.o : common.o +tcmt.o : mofiles/commonmod.o +tdb.o : common.o +tdb.o : client.o +tdb.o : mt.o +tdb.o : db.o +tdb.o : mofiles/commonmod.o +tdb.o : mofiles/dbmod.o +tdb.o : ods.o +tests.o : lock-queue.o +tests.o : db.o +tests.o : tdb.o +tests.o : common.o +tests.o : items.o +tests.o : runconfig.o +tests.o : server.o +tests.o : mofiles/commonmod.o +tests.o : mofiles/dbmod.o +tests.o : mofiles/configfmod.o +tests.o : mofiles/servermod.o +tree.o : margs.o +tree.o : launch.o +tree.o : gutils.o +tree.o : db.o +tree.o : server.o +tree.o : dcommon.o +tree.o : mofiles/commonmod.o +tree.o : mofiles/dbmod.o +ulex.o : pkts.o Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -1579,10 +1579,12 @@ (or ovrd '())))) (define (common:get-fields cfgdat) (let ((fields (hash-table-ref/default cfgdat "fields" '()))) (map car fields))) + +(define keys:config-get-fields common:get-fields) ;;====================================================================== ;; looking only (at least for now) at the MT_ variables craft the full testname ;; (define (common:get-full-test-name) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -24,11 +24,10 @@ (use regex regex-case matchable) ;; directory-utils) (declare (unit configf)) (declare (uses process)) (declare (uses env)) -(declare (uses keys)) (declare (uses commonmod)) (import commonmod) (declare (uses configfmod)) Index: dashboard-guimonitor.scm ================================================================== --- dashboard-guimonitor.scm +++ dashboard-guimonitor.scm @@ -31,11 +31,10 @@ (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) (declare (unit dashboard-guimonitor)) (declare (uses common)) -(declare (uses keys)) (declare (uses db)) (declare (uses tasks)) (declare (uses commonmod)) (import commonmod) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -31,11 +31,10 @@ (import (prefix sqlite3 sqlite3:)) (declare (uses common)) (declare (uses margs)) -(declare (uses keys)) (declare (uses items)) (declare (uses db)) (declare (uses configf)) (declare (uses process)) (declare (uses launch)) 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) ADDED datashare/datashare.scm Index: datashare/datashare.scm ================================================================== --- /dev/null +++ datashare/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) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -30,12 +30,10 @@ (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (declare (unit db)) (declare (uses common)) -(declare (uses keys)) -;; (declare (uses ods)) (declare (uses client)) (declare (uses mt)) (declare (uses commonmod)) (import commonmod) Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -201,50 +201,10 @@ (define-inline (db:test-data-set-units! vec val)(vector-set! vec 7 val)) (define-inline (db:test-data-set-comment! vec val)(vector-set! vec 8 val)) (define-inline (db:test-data-set-status! vec val)(vector-set! vec 9 val)) (define-inline (db:test-data-set-type! vec val)(vector-set! vec 10 val)) -;;====================================================================== -;; S T E P S -;;====================================================================== -;; Run steps -;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time -(define (make-db:step)(make-vector 9)) -(define-inline (tdb:step-get-id vec) (vector-ref vec 0)) -(define-inline (tdb:step-get-test_id vec) (vector-ref vec 1)) -(define-inline (tdb:step-get-stepname vec) (vector-ref vec 2)) -(define-inline (tdb:step-get-state vec) (vector-ref vec 3)) -(define-inline (tdb:step-get-status vec) (vector-ref vec 4)) -(define-inline (tdb:step-get-event_time vec) (vector-ref vec 5)) -(define-inline (tdb:step-get-logfile vec) (vector-ref vec 6)) -(define-inline (tdb:step-get-comment vec) (vector-ref vec 7)) -(define-inline (tdb:step-get-last_update vec) (vector-ref vec 8)) -(define-inline (tdb:step-set-id! vec val)(vector-set! vec 0 val)) -(define-inline (tdb:step-set-test_id! vec val)(vector-set! vec 1 val)) -(define-inline (tdb:step-set-stepname! vec val)(vector-set! vec 2 val)) -(define-inline (tdb:step-set-state! vec val)(vector-set! vec 3 val)) -(define-inline (tdb:step-set-status! vec val)(vector-set! vec 4 val)) -(define-inline (tdb:step-set-event_time! vec val)(vector-set! vec 5 val)) -(define-inline (tdb:step-set-logfile! vec val)(vector-set! vec 6 val)) -(define-inline (tdb:step-set-comment! vec val)(vector-set! vec 7 val)) - - -;; The steps table -(define (make-db:steps-table)(make-vector 5)) -(define-inline (tdb:steps-table-get-stepname vec) (vector-ref vec 0)) -(define-inline (tdb:steps-table-get-start vec) (vector-ref vec 1)) -(define-inline (tdb:steps-table-get-end vec) (vector-ref vec 2)) -(define-inline (tdb:steps-table-get-status vec) (vector-ref vec 3)) -(define-inline (tdb:steps-table-get-runtime vec) (vector-ref vec 4)) -(define-inline (tdb:steps-table-get-log-file vec) (vector-ref vec 5)) - -(define-inline (tdb:step-stable-set-stepname! vec val)(vector-set! vec 0 val)) -(define-inline (tdb:step-stable-set-start! vec val)(vector-set! vec 1 val)) -(define-inline (tdb:step-stable-set-end! vec val)(vector-set! vec 2 val)) -(define-inline (tdb:step-stable-set-status! vec val)(vector-set! vec 3 val)) -(define-inline (tdb:step-stable-set-runtime! vec val)(vector-set! vec 4 val)) - ;; The data structure for handing off requests via wire (define (make-cdb:packet)(make-vector 6)) (define-inline (cdb:packet-get-client-sig vec) (vector-ref vec 0)) (define-inline (cdb:packet-get-qtype vec) (vector-ref vec 1)) (define-inline (cdb:packet-get-immediate vec) (vector-ref vec 2)) DELETED fs-transport.scm Index: fs-transport.scm ================================================================== --- fs-transport.scm +++ /dev/null @@ -1,58 +0,0 @@ - -;; Copyright 2006-2012, 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 . - -(require-extension (srfi 18) extras tcp s11n) - -(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) -(import (prefix sqlite3 sqlite3:)) - -(use spiffy uri-common intarweb http-client spiffy-request-vars) - -(tcp-buffer-size 2048) - -(declare (unit fs-transport)) - -(declare (uses common)) -(declare (uses db)) -(declare (uses tests)) -(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. - -(declare (uses commonmod)) -(import commonmod) - -(declare (uses dbmod)) -(import dbmod) - -(include "common_records.scm") -(include "db_records.scm") - - -;;====================================================================== -;; F S T R A N S P O R T S E R V E R -;;====================================================================== - -;; There is no "server" per se but a convience routine to make it non -;; necessary to be reopening the db over and over again. -;; - -(define (fs:process-queue-item packet) - (if (not *dbstruct-db*) ;; we will require that (setup-for-run) has already been called - (set! *dbstruct-db* (db:setup-db))) - (debug:print-info 11 *default-log-port* "fs:process-queue-item called with packet=" packet) - (db:process-queue-item *dbstruct-db* packet)) - Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -28,13 +28,12 @@ (declare (unit http-transport)) (declare (uses common)) (declare (uses db)) -(declare (uses tests)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. -(declare (uses server)) +;; (declare (uses server)) ;; (declare (uses daemon)) (declare (uses portlogger)) (declare (uses rmt)) (declare (uses commonmod)) @@ -49,13 +48,14 @@ (declare (uses servermod)) (import servermod) (include "common_records.scm") (include "db_records.scm") -(include "js-path.scm") +;; (include "js-path.scm") -(require-library stml) +;; (require-library stml) + (define (http-transport:make-server-url hostport) (if (not hostport) #f (conc "http://" (car hostport) ":" (cadr hostport)))) @@ -647,97 +647,7 @@ ;; "exit on ^C timer"))) ;; (thread-start! th2) ;; (thread-start! th1) ;; (thread-join! th2)))) -;;=============================================== -;; Java script -;;=============================================== -(define (http-transport:show-jquery) - (let* ((data (tests:readlines *java-script-lib*))) -(string-join data "\n"))) - - - -;;====================================================================== -;; web pages -;;====================================================================== - -(define (http-transport:html-test-log $) - (let* ((run-id ($ 'runid)) - (test-item ($ 'testname)) - (parts (string-split test-item ":")) - (test-name (car parts)) - - (item-name (if (equal? (length parts) 1) - "" - (cadr parts)))) - ;(print $) -(tests:get-test-log run-id test-name item-name))) - - -(define (http-transport:html-dboard $) - (let* ((page ($ 'page)) - (oup (open-output-string)) - (bdy "--------------------------") - - (ret (tests:dynamic-dboard page))) - (s:output-new oup ret) - (close-output-port oup) - - (set! bdy (get-output-string oup)) - (conc "

Dashboard

" bdy "

" ))) - -(define (http-transport:main-page) - (let ((linkpath (root-path))) - (conc "

" (pathname-strip-directory *toppath*) "

" - "" - "Run area: " *toppath* - "

Server Stats

" - (http-transport:stats-table) - "
" - (http-transport:runs linkpath) - "
" - ;; (http-transport:run-stats) - "" - ))) - -(define (http-transport:stats-table) - (mutex-lock! *heartbeat-mutex*) - (let ((res - (conc "" - ;; "" - "" - "" - "" - ;; "" - "" - "
Max cached queries " *max-cache-size* "
Number of cached writes " *number-of-writes* "
Average cached write time " (if (eq? *number-of-writes* 0) - "n/a (no writes)" - (/ *writes-total-delay* - *number-of-writes*)) - " ms
Number non-cached queries " *number-non-write-queries* "
Average non-cached time " (if (eq? *number-non-write-queries* 0) - ;; "n/a (no queries)" - ;; (/ *total-non-write-delay* - ;; *number-non-write-queries*)) - " ms
Last access" (seconds->time-string *db-last-access*) "
"))) - (mutex-unlock! *heartbeat-mutex*) - res)) - -(define (http-transport:runs linkpath) - (conc "

Runs

" - (string-intersperse - (let ((files (map pathname-strip-directory (glob (conc linkpath "/*"))))) - (map (lambda (p) - (conc "" p "
")) - files)) - " "))) - -#;(define (http-transport:run-stats) - (let ((stats (open-run-close db:get-running-stats #f))) - (conc "" - (string-intersperse - (map (lambda (stat) - (conc "")) - stats) - " ") - "
" (car stat) "" (cadr stat) "
"))) + + DELETED keys.scm Index: keys.scm ================================================================== --- keys.scm +++ /dev/null @@ -1,40 +0,0 @@ - -;; Copyright 2006-2012, 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 . -;; - -;;====================================================================== -;; Run keys, these are used to hierarchially organise tests and run areas -;;====================================================================== - -(use sqlite3 srfi-1 posix regex regex-case srfi-69) -(import (prefix sqlite3 sqlite3:)) - -(declare (unit keys)) -(declare (uses common)) - -(declare (uses commonmod)) -(import commonmod) - -(include "key_records.scm") -(include "common_records.scm") - -;;====================================================================== -;; config file related routines -;;====================================================================== - -(define keys:config-get-fields common:get-fields) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -21,15 +21,15 @@ (import (prefix sqlite3 sqlite3:)) (declare (unit mt)) (declare (uses db)) (declare (uses common)) -(declare (uses items)) -(declare (uses runconfig)) +;; (declare (uses items)) +;; (declare (uses runconfig)) (declare (uses tests)) -(declare (uses server)) -(declare (uses runs)) +;; (declare (uses server)) +;; (declare (uses runs)) (declare (uses rmt)) ;; (declare (uses filedb)) (declare (uses commonmod)) (import commonmod) Index: ods.scm ================================================================== --- ods.scm +++ ods.scm @@ -17,11 +17,10 @@ ;; (use csv-xml regex) (declare (unit ods)) (declare (uses commonmod)) -;; (declare (uses common)) (module ods * (import scheme chicken data-structures extras files ports) DELETED portlogger-example.scm Index: portlogger-example.scm ================================================================== --- portlogger-example.scm +++ /dev/null @@ -1,21 +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 . - - -(declare (uses portlogger)) - -(print (apply portlogger:main (cdr (argv)))) DELETED sample-sauth-paths.scm Index: sample-sauth-paths.scm ================================================================== --- sample-sauth-paths.scm +++ /dev/null @@ -1,22 +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 . -;; -(define *db-path* "/path/to/db") -(define *exe-path* "/path/to/store/suids") -(define *exe-src* "/path/to/spublish/and/sretrieve/executables") -(define *sauth-path* "/path/to/production/sauthorize/exe") -(define *super-users* '("user1" "user2")) 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/sample-sauth-paths.scm Index: sauth/sample-sauth-paths.scm ================================================================== --- /dev/null +++ sauth/sample-sauth-paths.scm @@ -0,0 +1,22 @@ +;; 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 . +;; +(define *db-path* "/path/to/db") +(define *exe-path* "/path/to/store/suids") +(define *exe-src* "/path/to/spublish/and/sretrieve/executables") +(define *sauth-path* "/path/to/production/sauthorize/exe") +(define *super-users* '("user1" "user2")) ADDED sauth/sauth-common.scm Index: sauth/sauth-common.scm ================================================================== --- /dev/null +++ sauth/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/sauthorize.scm Index: sauth/sauthorize.scm ================================================================== --- /dev/null +++ sauth/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) + + + ADDED sauth/sretrieve.scm Index: sauth/sretrieve.scm ================================================================== --- /dev/null +++ sauth/sretrieve.scm @@ -0,0 +1,1112 @@ + +;; 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") + +(define (toplevel-command . args) #f) +(use readline) + + + + +;; +;; 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 sretrieve:help (conc "Usage: " *exe-name* " [action [params ...]] + + ls : list contents of target area + get : retrieve path to the data within + -m \"message\" : why retrieved? + shell : start a shell-like interface + +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 (sretrieve:initialize-db db) +; (for-each +; (lambda (qry) +; (exec (sql db qry))) +; (list +; "CREATE TABLE IF NOT EXISTS actions +; (id INTEGER PRIMARY KEY, +; action TEXT NOT NULL, +; retriever TEXT NOT NULL, +; datetime TIMESTAMP DEFAULT (datetime('now','localtime')), +; srcpath TEXT NOT NULL, +; comment TEXT DEFAULT '' NOT NULL, +; state TEXT DEFAULT 'new');" +; "CREATE TABLE IF NOT EXISTS bundles +; (id INTEGER PRIMARY KEY, +; bundle TEXT NOT NULL, +; release TEXT NOT NULL, +; status TEXT NOT NULL, +; event_date TEXT NOT NULL);" +; ))) +; +;(define (sretrieve:register-action db action submitter source-path comment) +; ; (print "(sretrieve:register-action db " db " action " action " submitter " submitter " source-path " source-path " comment " comment) +; (exec (sql db "INSERT INTO actions (action,retriever,srcpath,comment) +; VALUES(?,?,?,?)") +; action +; submitter +; source-path +; (or comment ""))) + +;; (call-with-database +;; (lambda (db) +;; (set-busy-handler! db (busy-timeout 10000)) ; 10 second timeout +;; ...)) + +;; Create the sqlite db +;(define (sretrieve:db-do configdat proc) +; (let ((path (configf:lookup configdat "database" "location"))) +; (if (not path) +; (begin +; (debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!") +; (exit 1))) +; (if (and path +; (directory? path) +; (file-read-access? path)) +; (let* ((dbpath (conc path "/" *exe-name* ".db")) +; (writeable (file-write-access? dbpath)) +; (dbexists (file-exists? dbpath))) +; (handle-exceptions +; exn +; (begin +; (debug:print 2 "ERROR: problem accessing db " dbpath +; ((condition-property-accessor 'exn 'message) exn)) +; (exit 1)) +; ;;(debug:print 0 "calling proc " proc "db path " dbpath ) +; (call-with-database +; dbpath +; (lambda (db) +; ;;(debug:print 0 "calling proc " proc " on db " db) +; (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout +; (if (not dbexists)(sretrieve:initialize-db db)) +; (proc db))))) +; (debug:print 0 "ERROR: invalid path for storing database: " path)))) + +;; copy in directory to dest, validation is done BEFORE calling this +;; +;(define (sretrieve:get configdat retriever version comment) +; (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) +; (datadir (conc base-dir "/" version))) +; (if (or (not base-dir) +; (not (file-exists? base-dir))) +; (begin +; (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found") +; (exit 1))) +; (print datadir) +; (if (not (file-exists? datadir)) +; (begin +; (debug:print 0 "ERROR: Bad version (" version "), no data found at " datadir "." ) +; (exit 1))) +; +; (sretrieve:db-do +; configdat +; (lambda (db) +; (sretrieve:register-action db "get" retriever datadir comment))) +; (sretrieve:do-as-calling-user +; (lambda () +; (if (directory? datadir) +; (begin +; (change-directory datadir) +; (let ((files (filter (lambda (x) +; (not (member x '("." "..")))) +; (glob "*" ".*")))) +; (print "files: " files) +; (process-execute "/bin/tar" (append (append (list "chfv" "-") files) (list "--ignore-failed-read"))))) +; (begin +; (let* ((parent-dir (pathname-directory datadir) ) +; (filename (conc(pathname-file datadir) "." (pathname-extension datadir)))) +; (change-directory parent-dir) +; (process-execute "/bin/tar" (list "chfv" "-" filename)) +; ))) +;)))) +; +; +;;; copy in file to dest, validation is done BEFORE calling this +;;; +;(define (sretrieve:cp configdat retriever file comment) +; (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) +; (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths")) +; (datadir (conc base-dir "/" file)) +; (filename (conc(pathname-file datadir) "." (pathname-extension datadir)))) +; (if (or (not base-dir) +; (not (file-exists? base-dir))) +; (begin +; (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found") +; (exit 1))) +; (print datadir) +; (if (not (file-exists? datadir)) +; (begin +; (debug:print 0 "ERROR: File (" file "), not found at " base-dir "." ) +; (exit 1))) +; (if (directory? datadir) +; (begin +; (debug:print 0 "ERROR: (" file ") is a dirctory!! cp cmd works only on files ." ) +; (exit 1))) +; (if(not (string-match (regexp allowed-sub-paths) file)) +; (begin +; (debug:print 0 "ERROR: Access denied to file (" file ")!! " ) +; (exit 1))) +; +; (sretrieve:db-do +; configdat +; (lambda (db) +; (sretrieve:register-action db "cp" retriever datadir comment))) +; (sretrieve:do-as-calling-user +; ;; (debug:print 0 "ph: "(pathname-directory datadir) "!! " ) +; (change-directory (pathname-directory datadir)) +; ;;(debug:print 0 "ph: /bin/tar" (list "chfv" "-" filename) ) +; (process-execute "/bin/tar" (list "chfv" "-" filename))) +; )) +; +;;; ls in file to dest, validation is done BEFORE calling this +;;; +;(define (sretrieve:ls configdat retriever file comment) +; (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) +; (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths")) +; (datadir (conc base-dir "/" file)) +; (filename (conc(pathname-file datadir) "." (pathname-extension datadir)))) +; (if (or (not base-dir) +; (not (file-exists? base-dir))) +; (begin +; (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found") +; (exit 1))) +; (print datadir) +; (if (not (file-exists? datadir)) +; (begin +; (debug:print 0 "ERROR: File (" file "), not found at " base-dir "." ) +; (exit 1))) +; (if(not (string-match (regexp allowed-sub-paths) file)) +; (begin +; (debug:print 0 "ERROR: Access denied to file (" file ")!! " ) +; (exit 1))) +; +; (sretrieve:do-as-calling-user +; (lambda () +; (process-execute "/bin/ls" (list "-ls" "-lrt" datadir )) +; )))) + + + +(define (sretrieve:validate target-dir targ-mk) + (let* ((normal-path (normalize-pathname targ-mk)) + (targ-path (conc target-dir "/" normal-path))) + (if (string-contains normal-path "..") + (begin + (debug:print 0 "ERROR: Path " targ-mk " resolved outside target area " target-dir ) + (exit 1))) + + (if (not (string-contains targ-path target-dir)) + (begin + (debug:print 0 "ERROR: You cannot update data outside " target-dir ".") + (exit 1))) + (debug:print 0 "Path " targ-mk " is valid.") + )) + + +;(define (sretrieve: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)))) +; +; +;(define (sretrieve:lst->path pathlst) +; (conc "/" (string-intersperse (map conc pathlst) "/"))) +; +;(define (sretrieve:path->lst path) +; (string-split path "/")) +; +;(define (sretrieve:pathdat-apply-heuristics configdat path) +; (cond +; ((file-exists? path) "found") +; (else (conc path " not installed")))) + +;;====================================================================== +;; MISC +;;====================================================================== + +(define (sretrieve: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)) + ;; (debug:print 0 "running as " (current-effective-user-id)) + (proc) + (if (not (eq? eid cid)) + (set! (current-effective-user-id) eid)))) + +(define (sretrieve:find name paths) + (if (null? paths) + #f + (let loop ((hed (car paths)) + (tal (cdr paths))) + (if (file-exists? (conc hed "/" name)) + hed + (if (null? tal) + #f + (loop (car tal)(cdr tal))))))) + +(define (sretrieve:stderr-print . args) + (with-output-to-port (current-error-port) + (lambda () + (apply print args)))) + +;;====================================================================== +;; SHELL +;;====================================================================== + +;; Create the sqlite db for shell +;(define (sretrieve:shell-db-do path proc) +; (if (not path) +; (begin +; (debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!") +; (exit 1))) +; (if (and path +; (directory? path) +; (file-read-access? path)) +; (let* ((dbpath (conc path "/" *exe-name* ".db")) +; (writeable (file-write-access? dbpath)) +; (dbexists (file-exists? dbpath))) +; (handle-exceptions +; exn +; (begin +; (debug:print 2 "ERROR: problem accessing db " dbpath +; ((condition-property-accessor 'exn 'message) exn)) +; (exit 1)) +; ;;(debug:print 0 "calling proc " proc "db path " dbpath ) +; (call-with-database +; dbpath +; (lambda (db) +; ;;(debug:print 0 "calling proc " proc " on db " db) +; (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout +; (if (not dbexists)(sretrieve:initialize-db db)) +; (proc db))))) +; (debug:print 0 "ERROR: invalid path for storing database: " path))) + + + +;; function to find sheets to which use has access +(define (sretrieve:has-permission area) + (let ((username (current-user-name))) + (cond + ((is-admin username) + #t) + ((is-user "retrieve" username area) + #t) + ((is-user "publish" username area) + #t) + ((is-user "writer-admin" username area) + #t) + ((is-user "read-admin" username area) + #t) + ((is-user "area-admin" username area) + #t) + (else + #f)))) + + +(define (sretrieve:get-accessable-projects area) + (let* ((projects `())) + + (if (sretrieve:has-permission area) + (set! projects (cons area projects)) + (begin + (sauth:print-error (conc "User cannot access area " area "!!")) + (exit 1))) + ; (print projects) + projects)) + +(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 "Resolved path: " target-path) + (if (not (equal? target-path #f)) + (begin + (if (symbolic-link? target-path) + (set! target-path (conc 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 (sretrieve:shell-cat-cmd base-pathlist ext-path top-areas base-path tail-cmd-list) + (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas )) + (data "") ) + (if (not (equal? resolved-path #f)) + (if (null? resolved-path) + (print "Path could not be resolved!!") + (let* ((target-path (sauth-common:get-target-path base-pathlist ext-path top-areas base-path))) + (if (not (equal? target-path #f)) + (if (or (not (file-exists? target-path)) (directory? target-path)) + (print "Target path does not exist or is a directory!") + (begin + (cond + ((null? tail-cmd-list) + (run (pipe + (cat ,target-path)))) + ((not (equal? (car tail-cmd-list) "|")) + (print "cat cmd cannot accept "(string-join tail-cmd-list) " as an argument!!")) + (else + (run (pipe + (cat ,target-path) + (begin (system (string-join (cdr tail-cmd-list)))))))))) +))) + (print "Path could not be resolved!!")))) + +(define (get-options cmd-list split-str) + (if (null? cmd-list) + (list '() '()) + (let loop ((hed (car cmd-list)) + (tal (cdr cmd-list)) + (res '())) + (cond + ((equal? hed split-str) + (list res tal)) + ((null? tal) + (list (cons hed res) tal)) + (else + (loop (car tal)(cdr tal)(cons hed res))))))) + + +(define (sretrieve:shell-grep-cmd base-pathlist ext-path top-areas base-path tail-cmd-list) + (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas )) + (pattern (car tail-cmd-list)) + (pipe-cmd-list (get-options (cdr tail-cmd-list) "|")) + (options (string-join (car pipe-cmd-list))) + (pipe-cmd (cadr pipe-cmd-list)) + (redirect-split (string-split (string-join tail-cmd-list) ">")) ) + (if(and ( > (length redirect-split) 2 )) + (print "sgrep cmd cannot accept > " (string-join redirect-split) " as an argument!!" ) + (if (not (equal? resolved-path #f)) + (if (null? resolved-path) + (print "Path could not be resolved!!") + (let* ((target-path (sauth-common:get-target-path base-pathlist ext-path top-areas base-path)) + (restrictions (if (equal? target-path #f) + "" + (sretrieve:shell-lookup base-path))) + (rest-str (string-split (conc " --exclude-dir=" (string-join (string-split restrictions ",") " --exclude-dir=") )))) + (if (not (file-exists? target-path)) + (print "Target path does not exist!") + (begin + (cond + ((and (null? pipe-cmd) (string-null? options)) + (run (pipe + (grep ,pattern ,target-path )))) + ((and (null? pipe-cmd) (not (string-null? options))) + (run (pipe + (begin (process-execute "/usr/bin/grep" (append (list options pattern target-path) rest-str)))))) + ((and (not (null? pipe-cmd)) (string-null? options)) + (run (pipe + (grep ,exclude-dir ,pattern ,target-path) + (begin (system (string-join pipe-cmd)))))) + (else + (run (pipe + ;(grep ,options ,exclude-dir ,pattern ,target-path) + (begin (process-execute "/usr/bin/grep" (append (list options pattern target-path) rest-str))) + + (begin (system (string-join pipe-cmd))))))) +)))) + (print "Path could not be resolved!!"))))) + + +(define (sretrieve:shell-less-cmd base-pathlist ext-path top-areas base-path) + (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas ))) + (if (not (equal? resolved-path #f)) + (if (null? resolved-path) + (print "Path could not be resolved!!") + (let* ((target-path (sauth-common:get-target-path base-pathlist ext-path top-areas base-path))) + (if (not (equal? target-path #f)) + (if (or (not (file-exists? target-path)) (directory? target-path)) + (print "Target path does not exist or is a directory!") + (begin + ;(sretrieve:shell-db-do + ; db-location + ; (lambda (db) + ; (sretrieve:register-action db "less" (current-user-name) target-path (conc "Executing cmd: less " target-path)))) + + (setenv "LESSSECURE" "1") + (run (pipe + (less ,target-path)))))))) + (print "Path could not be resolved!!")))) + + + +(define (sretrieve:shell-lookup base-path) + (let* ((usr (current-user-name)) + (value (get-restrictions base-path usr))) + value)) + + +(define (sretrieve:load-shell-config fname) + (if (file-exists? fname) + (read-config fname #f #f) + )) + + +(define (is_directory target-path) + (let* ((retval #f)) + (sretrieve:do-as-calling-user + (lambda () + ;(print (current-effective-user-id) ) + (if (directory? target-path) + (set! retval #t)))) + ;(print (current-effective-user-id)) + retval)) + +(define (make-exclude-pattern restriction-list ) + (if (null? restriction-list) + "" + (let loop ((hed (car restriction-list)) + (tal (cdr restriction-list)) + (ret-str "")) + (cond + ((null? tal) + (conc ret-str ".+" hed ".*")) + (else + (loop (car tal)(cdr tal)(conc ret-str ".+" hed ".*|")))))) ) + +(define (sretrieve:get-shell-cmd target-path base-path restrictions iport) + (if (not (file-exists? target-path)) + (sauth:print-error "Target path does not exist!") + (begin + (if (not (equal? target-path #f)) + (begin + (if (is_directory target-path) + (begin + (let* ((tmpfile (conc "/tmp/" (current-user-name) "/my-pipe")) + (parent-dir target-path) + (last-dir-name (if (pathname-extension target-path) + (conc(pathname-file target-path) "." (pathname-extension target-path)) + (pathname-file target-path))) + (curr-dir (current-directory)) + (start-dir (conc (current-directory) "/" last-dir-name)) + (execlude (make-exclude-pattern (string-split restrictions ",")))) + ; (print tmpfile) + (if (file-exists? start-dir) + (begin + (print last-dir-name " already exist in your work dir. Do you want to over write it? [y|n]") + (let* ((inl (read-line iport))) + (if (equal? inl "y") + (begin + (change-directory parent-dir) + (create-fifo tmpfile) + (process-fork + (lambda() + (sleep 1) + (with-output-to-file tmpfile + (lambda () + (sretrieve:make_file parent-dir execlude parent-dir))))) + + (run (pipe + (tar "chfv" "-" "-T" ,tmpfile ) + (begin (system (conc "cd " start-dir ";tar xUf - " ))))) + (change-directory curr-dir) + (system (conc "rm " tmpfile)) ) + (begin + (print "Nothing has been retrieved!! "))))) + (begin + (sretrieve:do-as-calling-user + (lambda () + (create-directory start-dir #t))) + (change-directory parent-dir) + ; (print execlude) + (create-fifo tmpfile) + (process-fork + (lambda() + (sleep 1) + (with-output-to-file tmpfile + (lambda () + (sretrieve:make_file parent-dir execlude parent-dir))))) + + (run (pipe + (tar "chfv" "-" "-T" ,tmpfile) + (begin (system (conc "cd " start-dir ";tar xUf - " ))))) + (change-directory curr-dir) + (system (conc "rm " tmpfile)))))) + (begin + (let*((parent-dir (pathname-directory target-path)) + (start-dir (current-directory)) + (filename (if (pathname-extension target-path) + (conc(pathname-file target-path) "." (pathname-extension target-path)) + (pathname-file target-path))) + (work-dir-file (conc (current-directory) "/" filename))) + (if (file-exists? work-dir-file) + (begin + (print filename " already exist in your work dir. Do you want to over write it? [y|n]") + (let* ((inl (read-line iport))) + (if (equal? inl "y") + (begin + (change-directory parent-dir) + (run (pipe + (tar "chfv" "-" ,filename) + (begin (system (conc "cd " start-dir ";tar xUf - " ))))) + (change-directory start-dir)) + (begin + (print "Nothing has been retrieved!! "))))) + (begin + (change-directory parent-dir) + (run (pipe + (tar "chfv" "-" ,filename) + (begin (system (conc "cd " start-dir ";tar xUf -"))))) + (change-directory start-dir))))))))))) + +(define (sretrieve:get-shell-cmd-line target-path base-path restrictions iport) + (handle-exceptions + exn + (begin + (sauth:print-error (conc "Problem fetching the data. Sauth provieds sudo access to only one unix group. Please ensure you have washed all the remaining groups. System Error: " + ((condition-property-accessor 'exn 'message) exn))) + (exit 1)) + + (if (not (file-exists? target-path)) + (sauth:print-error "Error:Target path does not exist!") + (begin + (if (not (equal? target-path #f)) + (begin + (if (is_directory target-path) + (begin + (let* ((parent-dir target-path) + (last-dir-name (if (pathname-extension target-path) + (conc(pathname-file target-path) "." (pathname-extension target-path)) + (pathname-file target-path))) + (curr-dir (current-directory)) + (start-dir (conc (current-directory) "/" last-dir-name)) + (execlude (make-exclude-pattern (string-split restrictions ","))) + (tmpfile (conc "/tmp/my-pipe-" (current-process-id)))) + (if (file-exists? start-dir) + (begin + (sauth:print-error (conclast-dir-name " already exist in your work dir.")) + (sauth:print-error "Nothing has been retrieved!! ")) + (begin + ; (sretrieve:do-as-calling-user + ; (lambda () + ; (print tmpfile) + ;(if (not (file-exists? (conc "/tmp/" (current-user-name)))) + ; (create-directory (conc "/tmp/" (current-user-name)) #t)) + (change-directory parent-dir) + (create-fifo tmpfile) + (process-fork + (lambda() + (sleep 1) + (with-output-to-file tmpfile + (lambda () + (sretrieve:make_file parent-dir execlude parent-dir))))) + + (process-execute "/bin/tar" (append (list "chfv" "-" "-T" tmpfile) (list "--ignore-failed-read"))) + ;(run (pipe + ;(tar "chfv" "-" "." ) + ;(begin (system (conc "cd " start-dir ";tar xUf - " execlude ))))) + (system (conc "rm " tmpfile)) + (change-directory curr-dir))))) + (begin + (let*((parent-dir (pathname-directory target-path)) + (start-dir (current-directory)) + (filename (if (pathname-extension target-path) + (conc(pathname-file target-path) "." (pathname-extension target-path)) + (pathname-file target-path))) + (work-dir-file (conc (current-directory) "/" filename))) + (if (file-exists? work-dir-file) + (begin + (print filename " already exist in your work dir.") + (print "Nothing has been retrieved!! ")) + (begin + (change-directory parent-dir) + (process-execute "/bin/tar" (append (append (list "chfv" "-") (list filename)) (list "--ignore-failed-read"))) + ;(run (pipe + ; (tar "chfv" "-" ,filename) + ; (begin (system (conc "cd " start-dir ";tar xUf -"))))) + (change-directory start-dir)))))))))))) + +(define (sretrieve:make_file path exclude base_path) + (find-files + path + action: (lambda (p res) + (cond + ((symbolic-link? p) + (if (directory?(read-symbolic-link p)) + (sretrieve:make_file p exclude base_path) + (print (string-substitute (conc base_path "/") "" p "-")))) + ((directory? p) + ;;do nothing for dirs) + ) + (else + + (if (not (string-match (regexp exclude) p )) + (print (string-substitute (conc base_path "/") "" p "-")))))) + dotfiles: #t)) + +(define (sretrieve:shell-help) +(conc "Usage: " *exe-name* " [action [params ...]] + + ls [target path] : list contents of target area. The output of the cmd can be piped into other system cmd. eg ls | grep txt + cd : To change the current directory within the sretrive shell. + pwd : Prints the full pathname of the current directory within the sretrive shell. + get : download directory/files into the directory where sretrieve shell cmd was invoked + less : Read input file to allows backward movement in the file as well as forward movement + cat : show the contents of a file. The output of the cmd can be piped into other system cmd. + + sgrep [options] : Similar to unix grep cmd But with diffrent parameter ordering. The output of the cmd can be piped into other system cmd. +Part of the Megatest tool suite. +Learn more at http://www.kiatoa.com/fossils/megatest + +Version: " megatest-fossil-hash) +) +;(define (toplevel-command . args) #f) +(define (sretrieve:shell area) + ; (print area) + (use readline) + (let* ((path '()) + (prompt "sretrieve> ") + (args (argv)) + (usr (current-user-name) ) + (top-areas (sretrieve:get-accessable-projects area)) + (close-port #f) + (area-obj (get-obj-by-code area)) + (user-obj (get-user usr)) + (base-path (if (null? area-obj) + "" + (caddr (cdr area-obj)))) + (iport (make-readline-port prompt))) + (if (null? area-obj) + (begin + (print "Area " area " does not exist") + (exit 1))) + (let loop ((inl (read-line iport))) + ;(print 1) + (if (not (or (or (eof-object? inl) + (equal? inl "exit")) (port-closed? iport))) + (let* ((parts (string-split inl)) + (cmd (if (null? parts) #f (car parts)))) + ; (print "2") + (if (and (not cmd) (not (port-closed? iport))) + (loop (read-line)) + (case (string->symbol cmd) + ((cd) + (if (> (length parts) 1) ;; have a parameter + (begin + (let*((arg (cadr parts)) + (resolved-path (sauth-common:resolve-path arg path top-areas)) + (target-path (sauth-common:get-target-path path arg top-areas base-path))) + (if (not (equal? target-path #f)) + (if (or (equal? resolved-path #f) (not (file-exists? target-path))) + (print "Invalid argument " arg ".. ") + (begin + (set! path resolved-path) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cd")))) + ))))) + (set! path '()))) + ((pwd) + (if (null? path) + (print "/") + (print "/" (string-join path "/")))) + ((ls) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + `())) + (plen (length thepath))) + (cond + ((null? thepath) + (sauth-common:shell-ls-cmd path "" top-areas base-path '()) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))) ) + ((< plen 2) + + (sauth-common:shell-ls-cmd path (car thepath) top-areas base-path '()) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls"))))) + (else + (if (equal? (car thepath) "|") + (sauth-common:shell-ls-cmd path "" top-areas base-path thepath) + (sauth-common:shell-ls-cmd path (car thepath) top-areas base-path (cdr thepath))) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))))))) + ((cat) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + `())) + (plen (length thepath))) + (cond + ((null? thepath) + (print "Error: Missing argument to cat")) + ((< plen 2) + (sretrieve:shell-cat-cmd path (car thepath) top-areas base-path '()) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cat"))))) + + (else + (sretrieve:shell-cat-cmd path (car thepath) top-areas base-path (cdr thepath)) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cat")))) +)))) + ((sgrep) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + `())) + (plen (length thepath))) + (cond + ((null? thepath) + (print "Error: Missing arguments to grep!! Useage: grep [options] ")) + ((< plen 2) + (print "Error: Missing arguments to grep!! Useage: grep [options] ")) + (else + (sretrieve:shell-grep-cmd path (car thepath) top-areas base-path (cdr thepath)) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "grep")))))))) + + ((less) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + `())) + (plen (length thepath))) + (cond + ((null? thepath) + (print "Error: Missing argument to less")) + ((< plen 2) + (sretrieve:shell-less-cmd path (car thepath) top-areas base-path) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "less"))))) + (else + (print "less cmd takes only one () argument!!"))))) + ((get) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + `())) + (plen (length thepath))) + (cond + ((null? thepath) + (print "Error: Missing argument to get")) + ((< plen 2) + (let* ((target-path (sauth-common:get-target-path path (car thepath) top-areas base-path)) + (restrictions (if (equal? target-path #f) + "" + (sretrieve:shell-lookup base-path)))) + (if (not (equal? target-path #f)) + (begin + (sretrieve:get-shell-cmd target-path base-path restrictions iport) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "get")))))))) + (else + (print "Error: get cmd takes only one argument "))))) + ((exit) + (print "got exit")) + ((help) + (print (sretrieve:shell-help))) + (else + (print "Got command: " inl)))) + (loop (read-line iport))))))) +;;)) + + +;;====================================================================== +;; MAIN +;;====================================================================== +;;(define *default-log-port* (current-error-port)) + +;(define (sretrieve:load-config exe-dir exe-name) +; (let* ((fname (conc exe-dir "/." exe-name ".config"))) +; ;; (ini:property-separator-patt " * *") +; ;; (ini:property-separator #\space) +; (if (file-exists? fname) +; ;; (ini:read-ini fname) +; (read-config fname #f #f) +; (make-hash-table)))) + +;; package-type is "megatest", "builds", "kits" etc. +;; + +;(define (sretrieve:load-packages configdat exe-dir package-type) +; (push-directory exe-dir) +; (let* ((packages-metadir (configf:lookup configdat "settings" "packages-metadir")) +; (conversion-script (configf:lookup configdat "settings" "conversion-script")) +; (upstream-file (configf:lookup configdat "settings" "upstream-file")) +; (package-config (conc packages-metadir "/" package-type ".config"))) +; (if (file-exists? upstream-file) +; (if (or (not (file-exists? package-config)) ;; if not created call the updater, otherwise call only if upstream newer +; (> (file-modification-time upstream-file)(file-modification-time package-config))) +; (handle-exceptions +; exn +; (debug:print 0 "ERROR: failed to run script " conversion-script " with params " upstream-file " " package-config) +; (let ((pid (process-run conversion-script (list upstream-file package-config)))) +; (process-wait pid))) +; (debug:print 0 "Skipping update of " package-config " from " upstream-file)) +; (debug:print 0 "Skipping update of " package-config " as " upstream-file " not found")) +; (let ((res (if (file-exists? package-config) +; (begin +; (debug:print 0 "Reading package config " package-config) +; (read-config package-config #f #t)) +; (make-hash-table)))) +; (pop-directory) +; res))) + +(define (toplevel-command . args) #f) +(define (sretrieve:process-action action . args) + ; (print action) + ; (use readline) + (case (string->symbol action) + ((get) + (if (< (length args) 2) + (begin + (sauth:print-error "Missing arguments; " ) + (exit 1))) + (let* ((remargs (args:get-args args '("-m" ) '() args:arg-hash 0)) + (iport (make-readline-port ">")) + (area (car args)) + (usr (current-user-name)) + (area-obj (get-obj-by-code area)) + (user-obj (get-user usr)) + (top-areas (sretrieve:get-accessable-projects area)) + (base-path (if (null? area-obj) + "" + (caddr (cdr area-obj)))) + (sub-path (if (null? remargs) + "" + (car remargs)))) + + (if (null? area-obj) + (begin + (sauth:print-error (conc "Area " area " does not exist")) + (exit 1))) + (let* ((target-path (sauth-common:get-target-path '() (conc area "/" sub-path) top-areas base-path)) + (restrictions (if (equal? target-path #f) + "" + (sretrieve:shell-lookup base-path)))) + (if (not (equal? target-path #f)) + (begin + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "get " area " " sub-path) (number->string (car user-obj)) (number->string (caddr area-obj)) "get")))) + (sretrieve:get-shell-cmd-line target-path base-path restrictions iport)))))) + ((cp) + (if (< (length args) 2) + (begin + (sauth:print-error "Missing arguments; " ) + (exit 1))) + (let* ((remargs (args:get-args args '("-m" ) '() args:arg-hash 0)) + (iport (make-readline-port ">")) + (area (car args)) + (usr (current-user-name)) + (area-obj (get-obj-by-code area)) + (user-obj (get-user usr)) + (top-areas (sretrieve:get-accessable-projects area)) + (base-path (if (null? area-obj) + "" + (caddr (cdr area-obj)))) + (sub-path (if (null? remargs) + "" + (car remargs)))) + ; (print args) + (if (null? area-obj) + (begin + (sauth:print-error (conc "Area " area " does not exist")) + (exit 1))) + (let* ((target-path (sauth-common:get-target-path '() (conc area "/" sub-path) top-areas base-path)) + (restrictions (if (equal? target-path #f) + "" + (sretrieve:shell-lookup base-path)))) + ;(print target-path) + (if (not (equal? target-path #f)) + (begin + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "get " area " " sub-path) (number->string (car user-obj)) (number->string (caddr area-obj)) "get")))) + (sretrieve:get-shell-cmd-line target-path base-path restrictions iport)))))) + ((cat) + (if (< (length args) 2) + (begin + (sauth:print-error "Missing arguments; " ) + (exit 1))) + (let* ((remargs (args:get-args args '("-m" ) '() args:arg-hash 0)) + (area (car args)) + (usr (current-user-name)) + (area-obj (get-obj-by-code area)) + (user-obj (get-user usr)) + (top-areas (sretrieve:get-accessable-projects area)) + (base-path (if (null? area-obj) + "" + (caddr (cdr area-obj)))) + (sub-path (if (null? remargs) + "" + (car remargs)))) + + (if (null? area-obj) + (begin + (sauth:print-error (conc "Area " area " does not exist")) + (exit 1))) + (let* ((target-path (sauth-common:get-target-path '() (conc area "/" sub-path) top-areas base-path)) + (restrictions (if (equal? target-path #f) + "" + (sretrieve:shell-lookup base-path)))) +;(sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list) + + (if (not (equal? target-path #f)) + (begin + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "get " area " " sub-path) (number->string (car user-obj)) (number->string (caddr area-obj)) "get")))) + (sretrieve:shell-cat-cmd (list area) sub-path top-areas base-path '())))))) + ((ls) + (cond + ((< (length args) 1) + (begin + (print "ERROR: Missing arguments; ") + (exit 1))) + ((equal? (length args) 1) + (let* ((area (car args)) + (usr (current-user-name)) + (area-obj (get-obj-by-code area)) + (user-obj (get-user usr)) + (top-areas (sretrieve:get-accessable-projects area)) + (base-path (if (null? area-obj) + "" + (caddr (cdr area-obj))))) + (if (null? area-obj) + (begin + (print "Area " area " does not exist") + (exit 1))) + + ; (sretrieve:shell-cat-cmd base-pathlist ext-path top-areas base-path tail-cmd-list) + + (sauth-common:shell-ls-cmd '() area top-areas base-path '()) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" "ls" (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))))) + ((> (length args) 1) + (let* ((remargs (args:get-args args '("-m" ) '() args:arg-hash 0)) + (usr (current-user-name)) + (user-obj (get-user usr)) + (area (car args))) + (let* ((area-obj (get-obj-by-code area)) + (top-areas (sretrieve:get-accessable-projects area)) + (base-path (if (null? area-obj) + "" + (caddr (cdr area-obj)))) + + (sub-path (if (null? remargs) + area + (conc area "/" (car remargs))))) + ;(print "sub path " sub-path) + (if (null? area-obj) + (begin + (print "Area " area " does not exist") + (exit 1))) + (sauth-common:shell-ls-cmd `() sub-path top-areas base-path '()) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "ls " sub-path) (number->string (car user-obj)) (number->string (caddr area-obj)) "ls"))))))))) + + ((shell) + (if (< (length args) 1) + (begin + (print "ERROR: Missing arguments !!" ) + (exit 1)) + (sretrieve:shell (car args)))) + (else (print 0 "Unrecognised command " action)))) + +(define (main) + (let* ((args (argv)) + (prog (car args)) + (rema (cdr args)) + (exe-name (pathname-file (car (argv)))) + ;(exe-dir (or (pathname-directory prog) + ; (sretrieve:find exe-name (string-split (get-environment-variable "PATH") ":")))) + ;(configdat (sretrieve:load-config exe-dir exe-name)) +) + ;; preserve the exe data in the config file + ;(hash-table-set! configdat "exe-info" (list (list "exe-name" exe-name) + ; (list "exe-dir" exe-dir))) + (cond + ;; one-word commands + ((eq? (length rema) 1) + (case (string->symbol (car rema)) + ((help -h -help --h --help) + (print sretrieve:help)) + (else + (print "ERROR: Unrecognised command. Try \"sretrieve help\"")))) + ;; multi-word commands + ((null? rema)(print sretrieve:help)) + ((>= (length rema) 2) + + (apply sretrieve:process-action (car rema) (cdr rema))) + (else (debug:print 0 "ERROR: Unrecognised command. Try \"sretrieve 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) - - - DELETED sretrieve.scm Index: sretrieve.scm ================================================================== --- sretrieve.scm +++ /dev/null @@ -1,1112 +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") - -(define (toplevel-command . args) #f) -(use readline) - - - - -;; -;; 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 sretrieve:help (conc "Usage: " *exe-name* " [action [params ...]] - - ls : list contents of target area - get : retrieve path to the data within - -m \"message\" : why retrieved? - shell : start a shell-like interface - -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 (sretrieve:initialize-db db) -; (for-each -; (lambda (qry) -; (exec (sql db qry))) -; (list -; "CREATE TABLE IF NOT EXISTS actions -; (id INTEGER PRIMARY KEY, -; action TEXT NOT NULL, -; retriever TEXT NOT NULL, -; datetime TIMESTAMP DEFAULT (datetime('now','localtime')), -; srcpath TEXT NOT NULL, -; comment TEXT DEFAULT '' NOT NULL, -; state TEXT DEFAULT 'new');" -; "CREATE TABLE IF NOT EXISTS bundles -; (id INTEGER PRIMARY KEY, -; bundle TEXT NOT NULL, -; release TEXT NOT NULL, -; status TEXT NOT NULL, -; event_date TEXT NOT NULL);" -; ))) -; -;(define (sretrieve:register-action db action submitter source-path comment) -; ; (print "(sretrieve:register-action db " db " action " action " submitter " submitter " source-path " source-path " comment " comment) -; (exec (sql db "INSERT INTO actions (action,retriever,srcpath,comment) -; VALUES(?,?,?,?)") -; action -; submitter -; source-path -; (or comment ""))) - -;; (call-with-database -;; (lambda (db) -;; (set-busy-handler! db (busy-timeout 10000)) ; 10 second timeout -;; ...)) - -;; Create the sqlite db -;(define (sretrieve:db-do configdat proc) -; (let ((path (configf:lookup configdat "database" "location"))) -; (if (not path) -; (begin -; (debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!") -; (exit 1))) -; (if (and path -; (directory? path) -; (file-read-access? path)) -; (let* ((dbpath (conc path "/" *exe-name* ".db")) -; (writeable (file-write-access? dbpath)) -; (dbexists (file-exists? dbpath))) -; (handle-exceptions -; exn -; (begin -; (debug:print 2 "ERROR: problem accessing db " dbpath -; ((condition-property-accessor 'exn 'message) exn)) -; (exit 1)) -; ;;(debug:print 0 "calling proc " proc "db path " dbpath ) -; (call-with-database -; dbpath -; (lambda (db) -; ;;(debug:print 0 "calling proc " proc " on db " db) -; (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout -; (if (not dbexists)(sretrieve:initialize-db db)) -; (proc db))))) -; (debug:print 0 "ERROR: invalid path for storing database: " path)))) - -;; copy in directory to dest, validation is done BEFORE calling this -;; -;(define (sretrieve:get configdat retriever version comment) -; (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) -; (datadir (conc base-dir "/" version))) -; (if (or (not base-dir) -; (not (file-exists? base-dir))) -; (begin -; (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found") -; (exit 1))) -; (print datadir) -; (if (not (file-exists? datadir)) -; (begin -; (debug:print 0 "ERROR: Bad version (" version "), no data found at " datadir "." ) -; (exit 1))) -; -; (sretrieve:db-do -; configdat -; (lambda (db) -; (sretrieve:register-action db "get" retriever datadir comment))) -; (sretrieve:do-as-calling-user -; (lambda () -; (if (directory? datadir) -; (begin -; (change-directory datadir) -; (let ((files (filter (lambda (x) -; (not (member x '("." "..")))) -; (glob "*" ".*")))) -; (print "files: " files) -; (process-execute "/bin/tar" (append (append (list "chfv" "-") files) (list "--ignore-failed-read"))))) -; (begin -; (let* ((parent-dir (pathname-directory datadir) ) -; (filename (conc(pathname-file datadir) "." (pathname-extension datadir)))) -; (change-directory parent-dir) -; (process-execute "/bin/tar" (list "chfv" "-" filename)) -; ))) -;)))) -; -; -;;; copy in file to dest, validation is done BEFORE calling this -;;; -;(define (sretrieve:cp configdat retriever file comment) -; (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) -; (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths")) -; (datadir (conc base-dir "/" file)) -; (filename (conc(pathname-file datadir) "." (pathname-extension datadir)))) -; (if (or (not base-dir) -; (not (file-exists? base-dir))) -; (begin -; (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found") -; (exit 1))) -; (print datadir) -; (if (not (file-exists? datadir)) -; (begin -; (debug:print 0 "ERROR: File (" file "), not found at " base-dir "." ) -; (exit 1))) -; (if (directory? datadir) -; (begin -; (debug:print 0 "ERROR: (" file ") is a dirctory!! cp cmd works only on files ." ) -; (exit 1))) -; (if(not (string-match (regexp allowed-sub-paths) file)) -; (begin -; (debug:print 0 "ERROR: Access denied to file (" file ")!! " ) -; (exit 1))) -; -; (sretrieve:db-do -; configdat -; (lambda (db) -; (sretrieve:register-action db "cp" retriever datadir comment))) -; (sretrieve:do-as-calling-user -; ;; (debug:print 0 "ph: "(pathname-directory datadir) "!! " ) -; (change-directory (pathname-directory datadir)) -; ;;(debug:print 0 "ph: /bin/tar" (list "chfv" "-" filename) ) -; (process-execute "/bin/tar" (list "chfv" "-" filename))) -; )) -; -;;; ls in file to dest, validation is done BEFORE calling this -;;; -;(define (sretrieve:ls configdat retriever file comment) -; (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) -; (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths")) -; (datadir (conc base-dir "/" file)) -; (filename (conc(pathname-file datadir) "." (pathname-extension datadir)))) -; (if (or (not base-dir) -; (not (file-exists? base-dir))) -; (begin -; (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found") -; (exit 1))) -; (print datadir) -; (if (not (file-exists? datadir)) -; (begin -; (debug:print 0 "ERROR: File (" file "), not found at " base-dir "." ) -; (exit 1))) -; (if(not (string-match (regexp allowed-sub-paths) file)) -; (begin -; (debug:print 0 "ERROR: Access denied to file (" file ")!! " ) -; (exit 1))) -; -; (sretrieve:do-as-calling-user -; (lambda () -; (process-execute "/bin/ls" (list "-ls" "-lrt" datadir )) -; )))) - - - -(define (sretrieve:validate target-dir targ-mk) - (let* ((normal-path (normalize-pathname targ-mk)) - (targ-path (conc target-dir "/" normal-path))) - (if (string-contains normal-path "..") - (begin - (debug:print 0 "ERROR: Path " targ-mk " resolved outside target area " target-dir ) - (exit 1))) - - (if (not (string-contains targ-path target-dir)) - (begin - (debug:print 0 "ERROR: You cannot update data outside " target-dir ".") - (exit 1))) - (debug:print 0 "Path " targ-mk " is valid.") - )) - - -;(define (sretrieve: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)))) -; -; -;(define (sretrieve:lst->path pathlst) -; (conc "/" (string-intersperse (map conc pathlst) "/"))) -; -;(define (sretrieve:path->lst path) -; (string-split path "/")) -; -;(define (sretrieve:pathdat-apply-heuristics configdat path) -; (cond -; ((file-exists? path) "found") -; (else (conc path " not installed")))) - -;;====================================================================== -;; MISC -;;====================================================================== - -(define (sretrieve: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)) - ;; (debug:print 0 "running as " (current-effective-user-id)) - (proc) - (if (not (eq? eid cid)) - (set! (current-effective-user-id) eid)))) - -(define (sretrieve:find name paths) - (if (null? paths) - #f - (let loop ((hed (car paths)) - (tal (cdr paths))) - (if (file-exists? (conc hed "/" name)) - hed - (if (null? tal) - #f - (loop (car tal)(cdr tal))))))) - -(define (sretrieve:stderr-print . args) - (with-output-to-port (current-error-port) - (lambda () - (apply print args)))) - -;;====================================================================== -;; SHELL -;;====================================================================== - -;; Create the sqlite db for shell -;(define (sretrieve:shell-db-do path proc) -; (if (not path) -; (begin -; (debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!") -; (exit 1))) -; (if (and path -; (directory? path) -; (file-read-access? path)) -; (let* ((dbpath (conc path "/" *exe-name* ".db")) -; (writeable (file-write-access? dbpath)) -; (dbexists (file-exists? dbpath))) -; (handle-exceptions -; exn -; (begin -; (debug:print 2 "ERROR: problem accessing db " dbpath -; ((condition-property-accessor 'exn 'message) exn)) -; (exit 1)) -; ;;(debug:print 0 "calling proc " proc "db path " dbpath ) -; (call-with-database -; dbpath -; (lambda (db) -; ;;(debug:print 0 "calling proc " proc " on db " db) -; (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout -; (if (not dbexists)(sretrieve:initialize-db db)) -; (proc db))))) -; (debug:print 0 "ERROR: invalid path for storing database: " path))) - - - -;; function to find sheets to which use has access -(define (sretrieve:has-permission area) - (let ((username (current-user-name))) - (cond - ((is-admin username) - #t) - ((is-user "retrieve" username area) - #t) - ((is-user "publish" username area) - #t) - ((is-user "writer-admin" username area) - #t) - ((is-user "read-admin" username area) - #t) - ((is-user "area-admin" username area) - #t) - (else - #f)))) - - -(define (sretrieve:get-accessable-projects area) - (let* ((projects `())) - - (if (sretrieve:has-permission area) - (set! projects (cons area projects)) - (begin - (sauth:print-error (conc "User cannot access area " area "!!")) - (exit 1))) - ; (print projects) - projects)) - -(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 "Resolved path: " target-path) - (if (not (equal? target-path #f)) - (begin - (if (symbolic-link? target-path) - (set! target-path (conc 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 (sretrieve:shell-cat-cmd base-pathlist ext-path top-areas base-path tail-cmd-list) - (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas )) - (data "") ) - (if (not (equal? resolved-path #f)) - (if (null? resolved-path) - (print "Path could not be resolved!!") - (let* ((target-path (sauth-common:get-target-path base-pathlist ext-path top-areas base-path))) - (if (not (equal? target-path #f)) - (if (or (not (file-exists? target-path)) (directory? target-path)) - (print "Target path does not exist or is a directory!") - (begin - (cond - ((null? tail-cmd-list) - (run (pipe - (cat ,target-path)))) - ((not (equal? (car tail-cmd-list) "|")) - (print "cat cmd cannot accept "(string-join tail-cmd-list) " as an argument!!")) - (else - (run (pipe - (cat ,target-path) - (begin (system (string-join (cdr tail-cmd-list)))))))))) -))) - (print "Path could not be resolved!!")))) - -(define (get-options cmd-list split-str) - (if (null? cmd-list) - (list '() '()) - (let loop ((hed (car cmd-list)) - (tal (cdr cmd-list)) - (res '())) - (cond - ((equal? hed split-str) - (list res tal)) - ((null? tal) - (list (cons hed res) tal)) - (else - (loop (car tal)(cdr tal)(cons hed res))))))) - - -(define (sretrieve:shell-grep-cmd base-pathlist ext-path top-areas base-path tail-cmd-list) - (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas )) - (pattern (car tail-cmd-list)) - (pipe-cmd-list (get-options (cdr tail-cmd-list) "|")) - (options (string-join (car pipe-cmd-list))) - (pipe-cmd (cadr pipe-cmd-list)) - (redirect-split (string-split (string-join tail-cmd-list) ">")) ) - (if(and ( > (length redirect-split) 2 )) - (print "sgrep cmd cannot accept > " (string-join redirect-split) " as an argument!!" ) - (if (not (equal? resolved-path #f)) - (if (null? resolved-path) - (print "Path could not be resolved!!") - (let* ((target-path (sauth-common:get-target-path base-pathlist ext-path top-areas base-path)) - (restrictions (if (equal? target-path #f) - "" - (sretrieve:shell-lookup base-path))) - (rest-str (string-split (conc " --exclude-dir=" (string-join (string-split restrictions ",") " --exclude-dir=") )))) - (if (not (file-exists? target-path)) - (print "Target path does not exist!") - (begin - (cond - ((and (null? pipe-cmd) (string-null? options)) - (run (pipe - (grep ,pattern ,target-path )))) - ((and (null? pipe-cmd) (not (string-null? options))) - (run (pipe - (begin (process-execute "/usr/bin/grep" (append (list options pattern target-path) rest-str)))))) - ((and (not (null? pipe-cmd)) (string-null? options)) - (run (pipe - (grep ,exclude-dir ,pattern ,target-path) - (begin (system (string-join pipe-cmd)))))) - (else - (run (pipe - ;(grep ,options ,exclude-dir ,pattern ,target-path) - (begin (process-execute "/usr/bin/grep" (append (list options pattern target-path) rest-str))) - - (begin (system (string-join pipe-cmd))))))) -)))) - (print "Path could not be resolved!!"))))) - - -(define (sretrieve:shell-less-cmd base-pathlist ext-path top-areas base-path) - (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas ))) - (if (not (equal? resolved-path #f)) - (if (null? resolved-path) - (print "Path could not be resolved!!") - (let* ((target-path (sauth-common:get-target-path base-pathlist ext-path top-areas base-path))) - (if (not (equal? target-path #f)) - (if (or (not (file-exists? target-path)) (directory? target-path)) - (print "Target path does not exist or is a directory!") - (begin - ;(sretrieve:shell-db-do - ; db-location - ; (lambda (db) - ; (sretrieve:register-action db "less" (current-user-name) target-path (conc "Executing cmd: less " target-path)))) - - (setenv "LESSSECURE" "1") - (run (pipe - (less ,target-path)))))))) - (print "Path could not be resolved!!")))) - - - -(define (sretrieve:shell-lookup base-path) - (let* ((usr (current-user-name)) - (value (get-restrictions base-path usr))) - value)) - - -(define (sretrieve:load-shell-config fname) - (if (file-exists? fname) - (read-config fname #f #f) - )) - - -(define (is_directory target-path) - (let* ((retval #f)) - (sretrieve:do-as-calling-user - (lambda () - ;(print (current-effective-user-id) ) - (if (directory? target-path) - (set! retval #t)))) - ;(print (current-effective-user-id)) - retval)) - -(define (make-exclude-pattern restriction-list ) - (if (null? restriction-list) - "" - (let loop ((hed (car restriction-list)) - (tal (cdr restriction-list)) - (ret-str "")) - (cond - ((null? tal) - (conc ret-str ".+" hed ".*")) - (else - (loop (car tal)(cdr tal)(conc ret-str ".+" hed ".*|")))))) ) - -(define (sretrieve:get-shell-cmd target-path base-path restrictions iport) - (if (not (file-exists? target-path)) - (sauth:print-error "Target path does not exist!") - (begin - (if (not (equal? target-path #f)) - (begin - (if (is_directory target-path) - (begin - (let* ((tmpfile (conc "/tmp/" (current-user-name) "/my-pipe")) - (parent-dir target-path) - (last-dir-name (if (pathname-extension target-path) - (conc(pathname-file target-path) "." (pathname-extension target-path)) - (pathname-file target-path))) - (curr-dir (current-directory)) - (start-dir (conc (current-directory) "/" last-dir-name)) - (execlude (make-exclude-pattern (string-split restrictions ",")))) - ; (print tmpfile) - (if (file-exists? start-dir) - (begin - (print last-dir-name " already exist in your work dir. Do you want to over write it? [y|n]") - (let* ((inl (read-line iport))) - (if (equal? inl "y") - (begin - (change-directory parent-dir) - (create-fifo tmpfile) - (process-fork - (lambda() - (sleep 1) - (with-output-to-file tmpfile - (lambda () - (sretrieve:make_file parent-dir execlude parent-dir))))) - - (run (pipe - (tar "chfv" "-" "-T" ,tmpfile ) - (begin (system (conc "cd " start-dir ";tar xUf - " ))))) - (change-directory curr-dir) - (system (conc "rm " tmpfile)) ) - (begin - (print "Nothing has been retrieved!! "))))) - (begin - (sretrieve:do-as-calling-user - (lambda () - (create-directory start-dir #t))) - (change-directory parent-dir) - ; (print execlude) - (create-fifo tmpfile) - (process-fork - (lambda() - (sleep 1) - (with-output-to-file tmpfile - (lambda () - (sretrieve:make_file parent-dir execlude parent-dir))))) - - (run (pipe - (tar "chfv" "-" "-T" ,tmpfile) - (begin (system (conc "cd " start-dir ";tar xUf - " ))))) - (change-directory curr-dir) - (system (conc "rm " tmpfile)))))) - (begin - (let*((parent-dir (pathname-directory target-path)) - (start-dir (current-directory)) - (filename (if (pathname-extension target-path) - (conc(pathname-file target-path) "." (pathname-extension target-path)) - (pathname-file target-path))) - (work-dir-file (conc (current-directory) "/" filename))) - (if (file-exists? work-dir-file) - (begin - (print filename " already exist in your work dir. Do you want to over write it? [y|n]") - (let* ((inl (read-line iport))) - (if (equal? inl "y") - (begin - (change-directory parent-dir) - (run (pipe - (tar "chfv" "-" ,filename) - (begin (system (conc "cd " start-dir ";tar xUf - " ))))) - (change-directory start-dir)) - (begin - (print "Nothing has been retrieved!! "))))) - (begin - (change-directory parent-dir) - (run (pipe - (tar "chfv" "-" ,filename) - (begin (system (conc "cd " start-dir ";tar xUf -"))))) - (change-directory start-dir))))))))))) - -(define (sretrieve:get-shell-cmd-line target-path base-path restrictions iport) - (handle-exceptions - exn - (begin - (sauth:print-error (conc "Problem fetching the data. Sauth provieds sudo access to only one unix group. Please ensure you have washed all the remaining groups. System Error: " - ((condition-property-accessor 'exn 'message) exn))) - (exit 1)) - - (if (not (file-exists? target-path)) - (sauth:print-error "Error:Target path does not exist!") - (begin - (if (not (equal? target-path #f)) - (begin - (if (is_directory target-path) - (begin - (let* ((parent-dir target-path) - (last-dir-name (if (pathname-extension target-path) - (conc(pathname-file target-path) "." (pathname-extension target-path)) - (pathname-file target-path))) - (curr-dir (current-directory)) - (start-dir (conc (current-directory) "/" last-dir-name)) - (execlude (make-exclude-pattern (string-split restrictions ","))) - (tmpfile (conc "/tmp/my-pipe-" (current-process-id)))) - (if (file-exists? start-dir) - (begin - (sauth:print-error (conclast-dir-name " already exist in your work dir.")) - (sauth:print-error "Nothing has been retrieved!! ")) - (begin - ; (sretrieve:do-as-calling-user - ; (lambda () - ; (print tmpfile) - ;(if (not (file-exists? (conc "/tmp/" (current-user-name)))) - ; (create-directory (conc "/tmp/" (current-user-name)) #t)) - (change-directory parent-dir) - (create-fifo tmpfile) - (process-fork - (lambda() - (sleep 1) - (with-output-to-file tmpfile - (lambda () - (sretrieve:make_file parent-dir execlude parent-dir))))) - - (process-execute "/bin/tar" (append (list "chfv" "-" "-T" tmpfile) (list "--ignore-failed-read"))) - ;(run (pipe - ;(tar "chfv" "-" "." ) - ;(begin (system (conc "cd " start-dir ";tar xUf - " execlude ))))) - (system (conc "rm " tmpfile)) - (change-directory curr-dir))))) - (begin - (let*((parent-dir (pathname-directory target-path)) - (start-dir (current-directory)) - (filename (if (pathname-extension target-path) - (conc(pathname-file target-path) "." (pathname-extension target-path)) - (pathname-file target-path))) - (work-dir-file (conc (current-directory) "/" filename))) - (if (file-exists? work-dir-file) - (begin - (print filename " already exist in your work dir.") - (print "Nothing has been retrieved!! ")) - (begin - (change-directory parent-dir) - (process-execute "/bin/tar" (append (append (list "chfv" "-") (list filename)) (list "--ignore-failed-read"))) - ;(run (pipe - ; (tar "chfv" "-" ,filename) - ; (begin (system (conc "cd " start-dir ";tar xUf -"))))) - (change-directory start-dir)))))))))))) - -(define (sretrieve:make_file path exclude base_path) - (find-files - path - action: (lambda (p res) - (cond - ((symbolic-link? p) - (if (directory?(read-symbolic-link p)) - (sretrieve:make_file p exclude base_path) - (print (string-substitute (conc base_path "/") "" p "-")))) - ((directory? p) - ;;do nothing for dirs) - ) - (else - - (if (not (string-match (regexp exclude) p )) - (print (string-substitute (conc base_path "/") "" p "-")))))) - dotfiles: #t)) - -(define (sretrieve:shell-help) -(conc "Usage: " *exe-name* " [action [params ...]] - - ls [target path] : list contents of target area. The output of the cmd can be piped into other system cmd. eg ls | grep txt - cd : To change the current directory within the sretrive shell. - pwd : Prints the full pathname of the current directory within the sretrive shell. - get : download directory/files into the directory where sretrieve shell cmd was invoked - less : Read input file to allows backward movement in the file as well as forward movement - cat : show the contents of a file. The output of the cmd can be piped into other system cmd. - - sgrep [options] : Similar to unix grep cmd But with diffrent parameter ordering. The output of the cmd can be piped into other system cmd. -Part of the Megatest tool suite. -Learn more at http://www.kiatoa.com/fossils/megatest - -Version: " megatest-fossil-hash) -) -;(define (toplevel-command . args) #f) -(define (sretrieve:shell area) - ; (print area) - (use readline) - (let* ((path '()) - (prompt "sretrieve> ") - (args (argv)) - (usr (current-user-name) ) - (top-areas (sretrieve:get-accessable-projects area)) - (close-port #f) - (area-obj (get-obj-by-code area)) - (user-obj (get-user usr)) - (base-path (if (null? area-obj) - "" - (caddr (cdr area-obj)))) - (iport (make-readline-port prompt))) - (if (null? area-obj) - (begin - (print "Area " area " does not exist") - (exit 1))) - (let loop ((inl (read-line iport))) - ;(print 1) - (if (not (or (or (eof-object? inl) - (equal? inl "exit")) (port-closed? iport))) - (let* ((parts (string-split inl)) - (cmd (if (null? parts) #f (car parts)))) - ; (print "2") - (if (and (not cmd) (not (port-closed? iport))) - (loop (read-line)) - (case (string->symbol cmd) - ((cd) - (if (> (length parts) 1) ;; have a parameter - (begin - (let*((arg (cadr parts)) - (resolved-path (sauth-common:resolve-path arg path top-areas)) - (target-path (sauth-common:get-target-path path arg top-areas base-path))) - (if (not (equal? target-path #f)) - (if (or (equal? resolved-path #f) (not (file-exists? target-path))) - (print "Invalid argument " arg ".. ") - (begin - (set! path resolved-path) - (sauthorize:do-as-calling-user - (lambda () - (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cd")))) - ))))) - (set! path '()))) - ((pwd) - (if (null? path) - (print "/") - (print "/" (string-join path "/")))) - ((ls) - (let* ((thepath (if (> (length parts) 1) ;; have a parameter - (cdr parts) - `())) - (plen (length thepath))) - (cond - ((null? thepath) - (sauth-common:shell-ls-cmd path "" top-areas base-path '()) - (sauthorize:do-as-calling-user - (lambda () - (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))) ) - ((< plen 2) - - (sauth-common:shell-ls-cmd path (car thepath) top-areas base-path '()) - (sauthorize:do-as-calling-user - (lambda () - (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls"))))) - (else - (if (equal? (car thepath) "|") - (sauth-common:shell-ls-cmd path "" top-areas base-path thepath) - (sauth-common:shell-ls-cmd path (car thepath) top-areas base-path (cdr thepath))) - (sauthorize:do-as-calling-user - (lambda () - (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))))))) - ((cat) - (let* ((thepath (if (> (length parts) 1) ;; have a parameter - (cdr parts) - `())) - (plen (length thepath))) - (cond - ((null? thepath) - (print "Error: Missing argument to cat")) - ((< plen 2) - (sretrieve:shell-cat-cmd path (car thepath) top-areas base-path '()) - (sauthorize:do-as-calling-user - (lambda () - (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cat"))))) - - (else - (sretrieve:shell-cat-cmd path (car thepath) top-areas base-path (cdr thepath)) - (sauthorize:do-as-calling-user - (lambda () - (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cat")))) -)))) - ((sgrep) - (let* ((thepath (if (> (length parts) 1) ;; have a parameter - (cdr parts) - `())) - (plen (length thepath))) - (cond - ((null? thepath) - (print "Error: Missing arguments to grep!! Useage: grep [options] ")) - ((< plen 2) - (print "Error: Missing arguments to grep!! Useage: grep [options] ")) - (else - (sretrieve:shell-grep-cmd path (car thepath) top-areas base-path (cdr thepath)) - (sauthorize:do-as-calling-user - (lambda () - (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "grep")))))))) - - ((less) - (let* ((thepath (if (> (length parts) 1) ;; have a parameter - (cdr parts) - `())) - (plen (length thepath))) - (cond - ((null? thepath) - (print "Error: Missing argument to less")) - ((< plen 2) - (sretrieve:shell-less-cmd path (car thepath) top-areas base-path) - (sauthorize:do-as-calling-user - (lambda () - (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "less"))))) - (else - (print "less cmd takes only one () argument!!"))))) - ((get) - (let* ((thepath (if (> (length parts) 1) ;; have a parameter - (cdr parts) - `())) - (plen (length thepath))) - (cond - ((null? thepath) - (print "Error: Missing argument to get")) - ((< plen 2) - (let* ((target-path (sauth-common:get-target-path path (car thepath) top-areas base-path)) - (restrictions (if (equal? target-path #f) - "" - (sretrieve:shell-lookup base-path)))) - (if (not (equal? target-path #f)) - (begin - (sretrieve:get-shell-cmd target-path base-path restrictions iport) - (sauthorize:do-as-calling-user - (lambda () - (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "get")))))))) - (else - (print "Error: get cmd takes only one argument "))))) - ((exit) - (print "got exit")) - ((help) - (print (sretrieve:shell-help))) - (else - (print "Got command: " inl)))) - (loop (read-line iport))))))) -;;)) - - -;;====================================================================== -;; MAIN -;;====================================================================== -;;(define *default-log-port* (current-error-port)) - -;(define (sretrieve:load-config exe-dir exe-name) -; (let* ((fname (conc exe-dir "/." exe-name ".config"))) -; ;; (ini:property-separator-patt " * *") -; ;; (ini:property-separator #\space) -; (if (file-exists? fname) -; ;; (ini:read-ini fname) -; (read-config fname #f #f) -; (make-hash-table)))) - -;; package-type is "megatest", "builds", "kits" etc. -;; - -;(define (sretrieve:load-packages configdat exe-dir package-type) -; (push-directory exe-dir) -; (let* ((packages-metadir (configf:lookup configdat "settings" "packages-metadir")) -; (conversion-script (configf:lookup configdat "settings" "conversion-script")) -; (upstream-file (configf:lookup configdat "settings" "upstream-file")) -; (package-config (conc packages-metadir "/" package-type ".config"))) -; (if (file-exists? upstream-file) -; (if (or (not (file-exists? package-config)) ;; if not created call the updater, otherwise call only if upstream newer -; (> (file-modification-time upstream-file)(file-modification-time package-config))) -; (handle-exceptions -; exn -; (debug:print 0 "ERROR: failed to run script " conversion-script " with params " upstream-file " " package-config) -; (let ((pid (process-run conversion-script (list upstream-file package-config)))) -; (process-wait pid))) -; (debug:print 0 "Skipping update of " package-config " from " upstream-file)) -; (debug:print 0 "Skipping update of " package-config " as " upstream-file " not found")) -; (let ((res (if (file-exists? package-config) -; (begin -; (debug:print 0 "Reading package config " package-config) -; (read-config package-config #f #t)) -; (make-hash-table)))) -; (pop-directory) -; res))) - -(define (toplevel-command . args) #f) -(define (sretrieve:process-action action . args) - ; (print action) - ; (use readline) - (case (string->symbol action) - ((get) - (if (< (length args) 2) - (begin - (sauth:print-error "Missing arguments; " ) - (exit 1))) - (let* ((remargs (args:get-args args '("-m" ) '() args:arg-hash 0)) - (iport (make-readline-port ">")) - (area (car args)) - (usr (current-user-name)) - (area-obj (get-obj-by-code area)) - (user-obj (get-user usr)) - (top-areas (sretrieve:get-accessable-projects area)) - (base-path (if (null? area-obj) - "" - (caddr (cdr area-obj)))) - (sub-path (if (null? remargs) - "" - (car remargs)))) - - (if (null? area-obj) - (begin - (sauth:print-error (conc "Area " area " does not exist")) - (exit 1))) - (let* ((target-path (sauth-common:get-target-path '() (conc area "/" sub-path) top-areas base-path)) - (restrictions (if (equal? target-path #f) - "" - (sretrieve:shell-lookup base-path)))) - (if (not (equal? target-path #f)) - (begin - (sauthorize:do-as-calling-user - (lambda () - (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "get " area " " sub-path) (number->string (car user-obj)) (number->string (caddr area-obj)) "get")))) - (sretrieve:get-shell-cmd-line target-path base-path restrictions iport)))))) - ((cp) - (if (< (length args) 2) - (begin - (sauth:print-error "Missing arguments; " ) - (exit 1))) - (let* ((remargs (args:get-args args '("-m" ) '() args:arg-hash 0)) - (iport (make-readline-port ">")) - (area (car args)) - (usr (current-user-name)) - (area-obj (get-obj-by-code area)) - (user-obj (get-user usr)) - (top-areas (sretrieve:get-accessable-projects area)) - (base-path (if (null? area-obj) - "" - (caddr (cdr area-obj)))) - (sub-path (if (null? remargs) - "" - (car remargs)))) - ; (print args) - (if (null? area-obj) - (begin - (sauth:print-error (conc "Area " area " does not exist")) - (exit 1))) - (let* ((target-path (sauth-common:get-target-path '() (conc area "/" sub-path) top-areas base-path)) - (restrictions (if (equal? target-path #f) - "" - (sretrieve:shell-lookup base-path)))) - ;(print target-path) - (if (not (equal? target-path #f)) - (begin - (sauthorize:do-as-calling-user - (lambda () - (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "get " area " " sub-path) (number->string (car user-obj)) (number->string (caddr area-obj)) "get")))) - (sretrieve:get-shell-cmd-line target-path base-path restrictions iport)))))) - ((cat) - (if (< (length args) 2) - (begin - (sauth:print-error "Missing arguments; " ) - (exit 1))) - (let* ((remargs (args:get-args args '("-m" ) '() args:arg-hash 0)) - (area (car args)) - (usr (current-user-name)) - (area-obj (get-obj-by-code area)) - (user-obj (get-user usr)) - (top-areas (sretrieve:get-accessable-projects area)) - (base-path (if (null? area-obj) - "" - (caddr (cdr area-obj)))) - (sub-path (if (null? remargs) - "" - (car remargs)))) - - (if (null? area-obj) - (begin - (sauth:print-error (conc "Area " area " does not exist")) - (exit 1))) - (let* ((target-path (sauth-common:get-target-path '() (conc area "/" sub-path) top-areas base-path)) - (restrictions (if (equal? target-path #f) - "" - (sretrieve:shell-lookup base-path)))) -;(sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list) - - (if (not (equal? target-path #f)) - (begin - (sauthorize:do-as-calling-user - (lambda () - (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "get " area " " sub-path) (number->string (car user-obj)) (number->string (caddr area-obj)) "get")))) - (sretrieve:shell-cat-cmd (list area) sub-path top-areas base-path '())))))) - ((ls) - (cond - ((< (length args) 1) - (begin - (print "ERROR: Missing arguments; ") - (exit 1))) - ((equal? (length args) 1) - (let* ((area (car args)) - (usr (current-user-name)) - (area-obj (get-obj-by-code area)) - (user-obj (get-user usr)) - (top-areas (sretrieve:get-accessable-projects area)) - (base-path (if (null? area-obj) - "" - (caddr (cdr area-obj))))) - (if (null? area-obj) - (begin - (print "Area " area " does not exist") - (exit 1))) - - ; (sretrieve:shell-cat-cmd base-pathlist ext-path top-areas base-path tail-cmd-list) - - (sauth-common:shell-ls-cmd '() area top-areas base-path '()) - (sauthorize:do-as-calling-user - (lambda () - (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" "ls" (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))))) - ((> (length args) 1) - (let* ((remargs (args:get-args args '("-m" ) '() args:arg-hash 0)) - (usr (current-user-name)) - (user-obj (get-user usr)) - (area (car args))) - (let* ((area-obj (get-obj-by-code area)) - (top-areas (sretrieve:get-accessable-projects area)) - (base-path (if (null? area-obj) - "" - (caddr (cdr area-obj)))) - - (sub-path (if (null? remargs) - area - (conc area "/" (car remargs))))) - ;(print "sub path " sub-path) - (if (null? area-obj) - (begin - (print "Area " area " does not exist") - (exit 1))) - (sauth-common:shell-ls-cmd `() sub-path top-areas base-path '()) - (sauthorize:do-as-calling-user - (lambda () - (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "ls " sub-path) (number->string (car user-obj)) (number->string (caddr area-obj)) "ls"))))))))) - - ((shell) - (if (< (length args) 1) - (begin - (print "ERROR: Missing arguments !!" ) - (exit 1)) - (sretrieve:shell (car args)))) - (else (print 0 "Unrecognised command " action)))) - -(define (main) - (let* ((args (argv)) - (prog (car args)) - (rema (cdr args)) - (exe-name (pathname-file (car (argv)))) - ;(exe-dir (or (pathname-directory prog) - ; (sretrieve:find exe-name (string-split (get-environment-variable "PATH") ":")))) - ;(configdat (sretrieve:load-config exe-dir exe-name)) -) - ;; preserve the exe data in the config file - ;(hash-table-set! configdat "exe-info" (list (list "exe-name" exe-name) - ; (list "exe-dir" exe-dir))) - (cond - ;; one-word commands - ((eq? (length rema) 1) - (case (string->symbol (car rema)) - ((help -h -help --h --help) - (print sretrieve:help)) - (else - (print "ERROR: Unrecognised command. Try \"sretrieve help\"")))) - ;; multi-word commands - ((null? rema)(print sretrieve:help)) - ((>= (length rema) 2) - - (apply sretrieve:process-action (car rema) (cdr rema))) - (else (debug:print 0 "ERROR: Unrecognised command. Try \"sretrieve help\""))))) - -(main) - - - Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -27,11 +27,10 @@ (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (declare (unit tdb)) (declare (uses common)) -(declare (uses keys)) (declare (uses client)) (declare (uses mt)) (declare (uses db)) (declare (uses commonmod)) @@ -51,10 +50,51 @@ ;;====================================================================== ;; ;; T E S T D A T A B A S E S ;; ;;====================================================================== +;;====================================================================== +;; S T E P S +;;====================================================================== + +;; Run steps +;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time +(define (make-db:step)(make-vector 9)) +(define (tdb:step-get-id vec) (vector-ref vec 0)) +(define (tdb:step-get-test_id vec) (vector-ref vec 1)) +(define (tdb:step-get-stepname vec) (vector-ref vec 2)) +(define (tdb:step-get-state vec) (vector-ref vec 3)) +(define (tdb:step-get-status vec) (vector-ref vec 4)) +(define (tdb:step-get-event_time vec) (vector-ref vec 5)) +(define (tdb:step-get-logfile vec) (vector-ref vec 6)) +(define (tdb:step-get-comment vec) (vector-ref vec 7)) +(define (tdb:step-get-last_update vec) (vector-ref vec 8)) +(define (tdb:step-set-id! vec val)(vector-set! vec 0 val)) +(define (tdb:step-set-test_id! vec val)(vector-set! vec 1 val)) +(define (tdb:step-set-stepname! vec val)(vector-set! vec 2 val)) +(define (tdb:step-set-state! vec val)(vector-set! vec 3 val)) +(define (tdb:step-set-status! vec val)(vector-set! vec 4 val)) +(define (tdb:step-set-event_time! vec val)(vector-set! vec 5 val)) +(define (tdb:step-set-logfile! vec val)(vector-set! vec 6 val)) +(define (tdb:step-set-comment! vec val)(vector-set! vec 7 val)) + + +;; The steps table +(define (make-db:steps-table)(make-vector 5)) +(define (tdb:steps-table-get-stepname vec) (vector-ref vec 0)) +(define (tdb:steps-table-get-start vec) (vector-ref vec 1)) +(define (tdb:steps-table-get-end vec) (vector-ref vec 2)) +(define (tdb:steps-table-get-status vec) (vector-ref vec 3)) +(define (tdb:steps-table-get-runtime vec) (vector-ref vec 4)) +(define (tdb:steps-table-get-log-file vec) (vector-ref vec 5)) + +(define (tdb:step-stable-set-stepname! vec val)(vector-set! vec 0 val)) +(define (tdb:step-stable-set-start! vec val)(vector-set! vec 1 val)) +(define (tdb:step-stable-set-end! vec val)(vector-set! vec 2 val)) +(define (tdb:step-stable-set-status! vec val)(vector-set! vec 3 val)) +(define (tdb:step-stable-set-runtime! vec val)(vector-set! vec 4 val)) + ;;====================================================================== ;; T E S T S P E C I F I C D B ;;====================================================================== Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -25,16 +25,13 @@ (declare (unit tests)) (declare (uses lock-queue)) (declare (uses db)) (declare (uses tdb)) (declare (uses common)) -;; (declare (uses dcommon)) ;; needed for the steps processing (declare (uses items)) (declare (uses runconfig)) -;; (declare (uses sdb)) (declare (uses server)) -;;(declare (uses stml2)) (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils) (import (prefix sqlite3 sqlite3:)) (require-library stml) @@ -58,10 +55,108 @@ (include "js-path.scm") (define (init-java-script-lib) (set! *java-script-lib* (conc (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js")) ) + + +;;====================================================================== +;; Stuff from http-transport +;;====================================================================== + +;;=============================================== +;; Java script +;;=============================================== +(define (http-transport:show-jquery) + (let* ((data (tests:readlines *java-script-lib*))) +(string-join data "\n"))) + +;;====================================================================== +;; web pages +;;====================================================================== + +(define (http-transport:html-test-log $) + (let* ((run-id ($ 'runid)) + (test-item ($ 'testname)) + (parts (string-split test-item ":")) + (test-name (car parts)) + + (item-name (if (equal? (length parts) 1) + "" + (cadr parts)))) + ;(print $) +(tests:get-test-log run-id test-name item-name))) + + +(define (http-transport:html-dboard $) + (let* ((page ($ 'page)) + (oup (open-output-string)) + (bdy "--------------------------") + + (ret (tests:dynamic-dboard page))) + (s:output-new oup ret) + (close-output-port oup) + + (set! bdy (get-output-string oup)) + (conc "

Dashboard

" bdy "

" ))) + +(define (http-transport:main-page) + (let ((linkpath (root-path))) + (conc "

" (pathname-strip-directory *toppath*) "

" + "" + "Run area: " *toppath* + "

Server Stats

" + (http-transport:stats-table) + "
" + (http-transport:runs linkpath) + "
" + ;; (http-transport:run-stats) + "" + ))) + +(define (http-transport:stats-table) + (mutex-lock! *heartbeat-mutex*) + (let ((res + (conc "" + ;; "" + "" + "" + "" + ;; "" + "" + "
Max cached queries " *max-cache-size* "
Number of cached writes " *number-of-writes* "
Average cached write time " (if (eq? *number-of-writes* 0) + "n/a (no writes)" + (/ *writes-total-delay* + *number-of-writes*)) + " ms
Number non-cached queries " *number-non-write-queries* "
Average non-cached time " (if (eq? *number-non-write-queries* 0) + ;; "n/a (no queries)" + ;; (/ *total-non-write-delay* + ;; *number-non-write-queries*)) + " ms
Last access" (seconds->time-string *db-last-access*) "
"))) + (mutex-unlock! *heartbeat-mutex*) + res)) + +(define (http-transport:runs linkpath) + (conc "

Runs

" + (string-intersperse + (let ((files (map pathname-strip-directory (glob (conc linkpath "/*"))))) + (map (lambda (p) + (conc "" p "
")) + files)) + " "))) + +#;(define (http-transport:run-stats) + (let ((stats (open-run-close db:get-running-stats #f))) + (conc "" + (string-intersperse + (map (lambda (stat) + (conc "")) + stats) + " ") + "
" (car stat) "" (cadr stat) "
"))) + + ;; Call this one to do all the work and get a standardized list of tests ;; gets paths from configs and finds valid tests ;; returns hash of testname --> fullpath ;; Index: utils/gendeps.scm ================================================================== --- utils/gendeps.scm +++ utils/gendeps.scm @@ -23,10 +23,17 @@ (define (portprint p . args) (with-output-to-port p (lambda () (apply print args)))) + +(define (mofiles-adjust->dot-o inf) + (regex-case + inf + ("^.*mod$" _ (conc "mofiles/"inf".o")) + ("pgdb" _ (conc "cgisetup/models/"inf".o")) + (else (conc inf".o")))) (define (compunit targfname files) (let* ((unitdata (make-hash-table)) (moduledata (make-hash-table)) (filesdata (make-hash-table)) @@ -36,10 +43,15 @@ (importuse (regexp "^\\(import\\s+(.*)\\)")) ;; captures string of imports (one line) (dotport (open-output-file (conc targfname ".dot"))) (incport (open-output-file (conc targfname ".inc"))) ) (portprint dotport "digraph usedeps {") + (portprint incport "# To regenerate this file do: +# (cd utils/;ck52 csc gendeps.scm) && ./utils/gendeps allunits *scm +# cp allunits.inc build.inc +# +") (for-each (lambda (fname) (let* ((sname (string-substitute "\\.scm$" "" fname))) (print "Processing "fname" with core name of "sname) (hash-table-set! filesdata sname fname) ;; record the existance of the src file @@ -53,12 +65,18 @@ (unitdec (_ unitname) (if (equal? sname unitname) ;; good if same (if (not (hash-table-exists? unitdata unitname)) (hash-table-set! unitdata unitname (make-hash-table))))) (unituse (_ usingname) - (portprint dotport "\""sname"\" -> \""usingname"\"") - (portprint incport sname".scm : "usingname".scm")) + (portprint dotport "\""usingname"\" -> \""sname"\"") + (portprint incport + (if (or (string-search ".import$" sname) + (string-search ".import$" usingname)) + "# " + "") + (mofiles-adjust->dot-o sname)" : " + (mofiles-adjust->dot-o usingname))) ;; (moduledec (_ modname) (print "Module: " modname)) ;; (importuse (_ importname) (print "Imports: " importname)) (else #f)) (loop (read-line))))))))) files)