Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -151,57 +151,62 @@
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 \
+# 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
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
@@ -217,11 +222,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
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,307 @@
+# To regenerate this file do:
+# (cd utils/;ck52 csc gendeps.scm) && ./utils/gendeps allunits *scm
+# cp allunits.inc build.inc
+#
+
+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
+mofiles/apimod.o : mofiles/commonmod.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
+configf.o : process.o
+configf.o : env.o
+configf.o : keys.o
+configf.o : mofiles/commonmod.o
+configf.o : mofiles/configfmod.o
+mofiles/configfmod.o : mofiles/commonmod.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 : keys.o
+dashboard-guimonitor.o : db.o
+dashboard-guimonitor.o : tasks.o
+dashboard-guimonitor.o : mofiles/commonmod.o
+dashboard-guimonitor.o : mofiles/dbmod.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
+dashboard.o : common.o
+dashboard.o : margs.o
+dashboard.o : keys.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
+db.o : common.o
+db.o : keys.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/dbmod.o : mofiles/commonmod.o
+mofiles/dbmod.o : ods.o
+mofiles/dbmod.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
+mofiles/dcommonmod.o : mofiles/commonmod.o
+mofiles/dcommonmod.o : mofiles/configfmod.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
+fs-transport.o : common.o
+fs-transport.o : db.o
+fs-transport.o : tests.o
+fs-transport.o : mofiles/commonmod.o
+fs-transport.o : mofiles/dbmod.o
+genexample.o : mofiles/commonmod.o
+http-transport.o : common.o
+http-transport.o : db.o
+http-transport.o : tests.o
+http-transport.o : server.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
+keys.o : common.o
+keys.o : mofiles/commonmod.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
+mt.o : db.o
+mt.o : common.o
+mt.o : items.o
+mt.o : runconfig.o
+mt.o : tests.o
+mt.o : server.o
+mt.o : runs.o
+mt.o : rmt.o
+mt.o : mofiles/commonmod.o
+mt.o : mofiles/configfmod.o
+mt.o : mofiles/dbmod.o
+mtexec.o : margs.o
+mtexec.o : configf.o
+mtexec.o : mofiles/configfmod.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
+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
+mofiles/rmtmod.o : mofiles/commonmod.o
+mofiles/rmtmod.o : mofiles/apimod.o
+mofiles/rmtmod.o : mofiles/dbmod.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
+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
+mofiles/servermod.o : mofiles/commonmod.o
+mofiles/servermod.o : mofiles/configfmod.o
+mofiles/servermod.o : mofiles/dbmod.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 : keys.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
+test.o : mtcommon.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
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)
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))
-
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: 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)