ADDED attic/index-tree.scm
Index: attic/index-tree.scm
==================================================================
--- /dev/null
+++ attic/index-tree.scm
@@ -0,0 +1,59 @@
+;;======================================================================
+;; 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 .
+;;
+;;======================================================================
+
+;;======================================================================
+;; Tests
+;;======================================================================
+
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
+(import (prefix sqlite3 sqlite3:))
+
+(declare (unit tests))
+(declare (uses lock-queue))
+(declare (uses db))
+(declare (uses common))
+(declare (uses items))
+(declare (uses runconfig))
+
+(include "common_records.scm")
+(include "key_records.scm")
+(include "db_records.scm")
+(include "run_records.scm")
+(include "test_records.scm")
+
+;; Populate the links tree with index.html files
+;;
+;; - start from most recent tests and work towards oldest -OR-
+;; start from deepest hierarchy and work way up
+;; - look up tests in megatest.db
+;; - cross-reference the tests to stats.db
+;; - if newer than event_time in stats.db or not registered in stats.db regenerate
+;; - run du and store in stats.db
+;; - when all tests at that level done generate next level up index.html
+;;
+;; include in rollup html index.html:
+;; sum of du
+;; counts of PASS, FAIL, RUNNING, REMOTEHOSTSTART, LAUNCHED, CHECK etc.
+;; overall status
+;;
+;; include in test specific index.html:
+;; host, uname, cpu graph, disk avail graph, steps, data
+;; meta data, state, status, du
+;;
ADDED attic/mlaunch.scm
Index: attic/mlaunch.scm
==================================================================
--- /dev/null
+++ attic/mlaunch.scm
@@ -0,0 +1,33 @@
+;; Copyright 2006-2014, 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 .
+
+;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
+
+;;======================================================================
+;; MLAUNCH
+;;
+;; take jobs from the given queue and keep launching them keeping
+;; the cpu load at the targeted level
+;;
+;;======================================================================
+
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 format)
+
+(declare (unit mlaunch))
+(declare (uses db))
+(declare (uses common))
+
ADDED attic/nexttag.rb
Index: attic/nexttag.rb
==================================================================
--- /dev/null
+++ attic/nexttag.rb
@@ -0,0 +1,62 @@
+#!/usr/bin/env ruby
+
+# 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 .
+
+def get_next_tag(branch)
+
+
+
+ abort "Not on a version branch like v1.64 (got: >#{branch}<)" unless branch.match(/^v\d\.\d\d$/)
+
+ #puts "this branch: #{branch}"
+
+ tag_pat = /#{branch}(\d\d)/
+ remote=`fsl remote`.chomp.sub(/^file:\/\//,'') # get tagset from origin
+ cmd="fossil tag -R '#{remote}' list"
+ tags = `#{cmd}`.split /\n/
+ abort "fossil command failed [#{cmd}]" if $? != 0
+ branch_tags = tags.find_all{|x| x.match(tag_pat) }.sort
+ if branch_tags.length == 0
+ return branch + "01"
+ else
+ latest_tag = branch_tags.last
+ m1 = latest_tag.match(tag_pat)
+ minor_digits = m1[1].to_i + 1
+ if (minor_digits % 10) == 0
+ minor_digits += 1
+ end
+ new_tag=sprintf("%s%02d", branch, minor_digits)
+ return new_tag
+ end
+end
+
+branch = `fossil branch`.sub(/\A.*\* /m,'').sub(/\n.*\z/m,'')
+tag= get_next_tag(branch)
+
+puts "TODO: Write to megatest-version.scm:"
+puts ";; Always use two or four digit decimal
+;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..
+
+(declare (unit megatest-version))
+
+(define megatest-version #{tag.sub(/^v/,'')})
+
+"
+
+puts "TODO: fossil tag add #{tag} #{branch}"
+puts ""
ADDED attic/runs-launch-loop-test.scm
Index: attic/runs-launch-loop-test.scm
==================================================================
--- /dev/null
+++ attic/runs-launch-loop-test.scm
@@ -0,0 +1,76 @@
+;; 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 .
+;;
+(use srfi-69)
+
+(define (runs:queue-next-hed tal reg n regful)
+ (if regful
+ (car reg)
+ (car tal)))
+
+(define (runs:queue-next-tal tal reg n regful)
+ (if regful
+ tal
+ (let ((newtal (cdr tal)))
+ (if (null? newtal)
+ reg
+ newtal
+ ))))
+
+(define (runs:queue-next-reg tal reg n regful)
+ (if regful
+ (cdr reg)
+ (if (eq? (length tal) 1)
+ '()
+ reg)))
+
+(use trace)
+(trace runs:queue-next-hed
+ runs:queue-next-tal
+ runs:queue-next-reg)
+
+
+(define tests '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20))
+
+(define test-registry (make-hash-table))
+
+(define n 3)
+
+(let loop ((hed (car tests))
+ (tal (cdr tests))
+ (reg '()))
+ (let* ((reglen (length reg))
+ (regful (> reglen n)))
+ (print "hed=" hed ", length reg=" (length reg) ", (> lenreg n)=" (> (length reg) n))
+ (let ((newtal (append tal (list hed)))) ;; used if we are not done with this test
+ (cond
+ ((not (hash-table-ref/default test-registry hed #f))
+ (hash-table-set! test-registry hed #t)
+ (print "Registering #" hed)
+ (if (not (null? tal))
+ (loop (runs:queue-next-hed tal reg n regful)
+ (runs:queue-next-tal tal reg n regful)
+ (let ((newl (append reg (list hed))))
+ (if regful
+ (cdr newl)
+ newl)))))
+ (else
+ (print "Running #" hed)
+ (if (not (null? tal))
+ (loop (runs:queue-next-hed tal reg n regful)
+ (runs:queue-next-tal tal reg n regful)
+ (runs:queue-next-reg tal reg n regful))))))))
ADDED attic/synchash.scm
Index: attic/synchash.scm
==================================================================
--- /dev/null
+++ attic/synchash.scm
@@ -0,0 +1,33 @@
+;;======================================================================
+;; 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 .
+;;
+;;======================================================================
+
+;;======================================================================
+;; A hash of hashes that can be kept in sync by sending minial deltas
+;;======================================================================
+
+(use format)
+(use srfi-1 srfi-69 sqlite3)
+(import (prefix sqlite3 sqlite3:))
+
+(declare (unit synchash))
+(declare (uses db))
+(declare (uses server))
+(include "db_records.scm")
+
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 index-tree.scm
Index: index-tree.scm
==================================================================
--- index-tree.scm
+++ /dev/null
@@ -1,59 +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 .
-;;
-;;======================================================================
-
-;;======================================================================
-;; Tests
-;;======================================================================
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (unit tests))
-(declare (uses lock-queue))
-(declare (uses db))
-(declare (uses common))
-(declare (uses items))
-(declare (uses runconfig))
-
-(include "common_records.scm")
-(include "key_records.scm")
-(include "db_records.scm")
-(include "run_records.scm")
-(include "test_records.scm")
-
-;; Populate the links tree with index.html files
-;;
-;; - start from most recent tests and work towards oldest -OR-
-;; start from deepest hierarchy and work way up
-;; - look up tests in megatest.db
-;; - cross-reference the tests to stats.db
-;; - if newer than event_time in stats.db or not registered in stats.db regenerate
-;; - run du and store in stats.db
-;; - when all tests at that level done generate next level up index.html
-;;
-;; include in rollup html index.html:
-;; sum of du
-;; counts of PASS, FAIL, RUNNING, REMOTEHOSTSTART, LAUNCHED, CHECK etc.
-;; overall status
-;;
-;; include in test specific index.html:
-;; host, uname, cpu graph, disk avail graph, steps, data
-;; meta data, state, status, du
-;;
DELETED mlaunch.scm
Index: mlaunch.scm
==================================================================
--- mlaunch.scm
+++ /dev/null
@@ -1,33 +0,0 @@
-;; Copyright 2006-2014, 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 .
-
-;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-
-;;======================================================================
-;; MLAUNCH
-;;
-;; take jobs from the given queue and keep launching them keeping
-;; the cpu load at the targeted level
-;;
-;;======================================================================
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 format)
-
-(declare (unit mlaunch))
-(declare (uses db))
-(declare (uses common))
-
DELETED nexttag.rb
Index: nexttag.rb
==================================================================
--- nexttag.rb
+++ /dev/null
@@ -1,62 +0,0 @@
-#!/usr/bin/env ruby
-
-# 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 .
-
-def get_next_tag(branch)
-
-
-
- abort "Not on a version branch like v1.64 (got: >#{branch}<)" unless branch.match(/^v\d\.\d\d$/)
-
- #puts "this branch: #{branch}"
-
- tag_pat = /#{branch}(\d\d)/
- remote=`fsl remote`.chomp.sub(/^file:\/\//,'') # get tagset from origin
- cmd="fossil tag -R '#{remote}' list"
- tags = `#{cmd}`.split /\n/
- abort "fossil command failed [#{cmd}]" if $? != 0
- branch_tags = tags.find_all{|x| x.match(tag_pat) }.sort
- if branch_tags.length == 0
- return branch + "01"
- else
- latest_tag = branch_tags.last
- m1 = latest_tag.match(tag_pat)
- minor_digits = m1[1].to_i + 1
- if (minor_digits % 10) == 0
- minor_digits += 1
- end
- new_tag=sprintf("%s%02d", branch, minor_digits)
- return new_tag
- end
-end
-
-branch = `fossil branch`.sub(/\A.*\* /m,'').sub(/\n.*\z/m,'')
-tag= get_next_tag(branch)
-
-puts "TODO: Write to megatest-version.scm:"
-puts ";; Always use two or four digit decimal
-;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..
-
-(declare (unit megatest-version))
-
-(define megatest-version #{tag.sub(/^v/,'')})
-
-"
-
-puts "TODO: fossil tag add #{tag} #{branch}"
-puts ""
DELETED runs-launch-loop-test.scm
Index: runs-launch-loop-test.scm
==================================================================
--- runs-launch-loop-test.scm
+++ /dev/null
@@ -1,76 +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 .
-;;
-(use srfi-69)
-
-(define (runs:queue-next-hed tal reg n regful)
- (if regful
- (car reg)
- (car tal)))
-
-(define (runs:queue-next-tal tal reg n regful)
- (if regful
- tal
- (let ((newtal (cdr tal)))
- (if (null? newtal)
- reg
- newtal
- ))))
-
-(define (runs:queue-next-reg tal reg n regful)
- (if regful
- (cdr reg)
- (if (eq? (length tal) 1)
- '()
- reg)))
-
-(use trace)
-(trace runs:queue-next-hed
- runs:queue-next-tal
- runs:queue-next-reg)
-
-
-(define tests '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20))
-
-(define test-registry (make-hash-table))
-
-(define n 3)
-
-(let loop ((hed (car tests))
- (tal (cdr tests))
- (reg '()))
- (let* ((reglen (length reg))
- (regful (> reglen n)))
- (print "hed=" hed ", length reg=" (length reg) ", (> lenreg n)=" (> (length reg) n))
- (let ((newtal (append tal (list hed)))) ;; used if we are not done with this test
- (cond
- ((not (hash-table-ref/default test-registry hed #f))
- (hash-table-set! test-registry hed #t)
- (print "Registering #" hed)
- (if (not (null? tal))
- (loop (runs:queue-next-hed tal reg n regful)
- (runs:queue-next-tal tal reg n regful)
- (let ((newl (append reg (list hed))))
- (if regful
- (cdr newl)
- newl)))))
- (else
- (print "Running #" hed)
- (if (not (null? tal))
- (loop (runs:queue-next-hed tal reg n regful)
- (runs:queue-next-tal tal reg n regful)
- (runs:queue-next-reg tal reg n regful))))))))
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,319 +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))
-
-
-
-
-;; 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 "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,319 @@
+;; 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))
+
+
+
+
+;; 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 "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))
+(declare (uses megatest-version))
+
+(include "megatest-fossil-hash.scm")
+;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm.
+(include "sauth-paths.scm")
+(include "sauth-common.scm")
+
+;;
+;; GLOBALS
+;;
+(define *verbosity* 1)
+(define *logging* #f)
+(define *exe-name* (pathname-file (car (argv))))
+(define *sretrieve:current-tab-number* 0)
+(define *args-hash* (make-hash-table))
+(define sauthorize:help (conc "Usage: " *exe-name* " [action [params ...]]
+
+ list : list areas $USER's can access
+ log : get listing of recent activity.
+ sauth list-area-user : list the users that can access the area.
+ sauth open --group : Open up an area. User needs to be the owner of the area to open it.
+ --code
+ --retrieve|--publish [--additional-grps ]
+ sauth update --retrieve|--publish : update the binaries with the lates changes
+ sauth grant --area : Grant permission to read or write to a area that is alrady opend up.
+ --expiration yyyy/mm/dd --retrieve|--publish
+ [--restrict ]
+ sauth read-shell : Open sretrieve shell for reading.
+ sauth write-shell : Open spublish shell for writing.
+
+Part of the Megatest tool suite.
+Learn more at http://www.kiatoa.com/fossils/megatest
+
+Version: " megatest-fossil-hash)) ;; "
+
+;;======================================================================
+;; RECORDS
+;;======================================================================
+
+;;======================================================================
+;; DB
+;;======================================================================
+
+;; replace (strftime('%s','now')), with datetime('now'))
+(define (sauthorize:initialize-db db)
+ (for-each
+ (lambda (qry)
+ (exec (sql db qry)))
+ (list
+ "CREATE TABLE IF NOT EXISTS actions
+ (id INTEGER PRIMARY KEY,
+ cmd TEXT NOT NULL,
+ user_id INTEGER NOT NULL,
+ datetime TIMESTAMP DEFAULT (datetime('now','localtime')),
+ area_id INTEGER NOT NULL,
+ comment TEXT DEFAULT '' NOT NULL,
+ action_type TEXT NOT NULL);"
+ "CREATE TABLE IF NOT EXISTS users
+ (id INTEGER PRIMARY KEY,
+ username TEXT NOT NULL,
+ is_admin TEXT NOT NULL,
+ datetime TIMESTAMP DEFAULT (datetime('now','localtime'))
+ );"
+ "CREATE TABLE IF NOT EXISTS areas
+ (id INTEGER PRIMARY KEY,
+ basepath TEXT NOT NULL,
+ code TEXT NOT NULL,
+ exe_name TEXT NOT NULL,
+ required_grps TEXT DEFAULT '' NOT NULL,
+ datetime TIMESTAMP DEFAULT (datetime('now','localtime'))
+ );"
+ "CREATE TABLE IF NOT EXISTS permissions
+ (id INTEGER PRIMARY KEY,
+ access_type TEXT NOT NULL,
+ user_id INTEGER NOT NULL,
+ datetime TIMESTAMP DEFAULT (datetime('now','localtime')),
+ area_id INTEGER NOT NULL,
+ restriction TEXT DEFAULT '' NOT NULL,
+ expiration TIMESTAMP DEFAULT NULL);"
+ )))
+
+
+
+
+(define (get-access-type args)
+ (let loop ((hed (car args))
+ (tal (cdr args)))
+ (cond
+ ((equal? hed "--retrieve")
+ "retrieve")
+ ((equal? hed "--publish")
+ "publish")
+ ((equal? hed "--area-admin")
+ "area-admin")
+ ((equal? hed "--writer-admin")
+ "writer-admin")
+ ((equal? hed "--read-admin")
+ "read-admin")
+
+ ((null? tal)
+ #f)
+ (else
+ (loop (car tal)(cdr tal))))))
+
+
+
+;; check if user can gran access to an area
+(define (can-grant-perm username access-type area)
+ (let* ((isadmin (is-admin username))
+ (is-area-admin (is-user "area-admin" username area ))
+ (is-read-admin (is-user "read-admin" username area) )
+ (is-writer-admin (is-user "writer-admin" username area) ) )
+ (cond
+ ((equal? isadmin #t)
+ #t)
+ ((equal? is-area-admin #t )
+ #t)
+ ((and (equal? is-writer-admin #t ) (equal? access-type "retrieve"))
+ #t)
+ ((and (equal? is-read-admin #t ) (equal? access-type "retrieve"))
+ #t)
+
+ (else
+ #f))))
+
+(define (sauthorize:list-areausers area )
+ (sauthorize:db-do (lambda (db)
+ (print "Users having access to " area ":")
+ (query (for-each-row
+ (lambda (row)
+ (let* ((exp-date (cadr row)))
+ (if (is-access-valid exp-date)
+ (apply print (intersperse row " | "))))))
+ (sql db (conc "SELECT users.username, permissions.expiration, permissions.access_type FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and areas.code = '" area "'"))))))
+
+
+
+
+; check if executable exists
+(define (exe-exist exe access-type)
+ (let* ((filepath (conc *exe-path* "/" access-type "/" exe)))
+ ; (print filepath)
+ (if (file-exists? filepath)
+ #t
+ #f)))
+
+(define (copy-exe access-type exe-name group)
+ (run-cmd "/bin/chmod" (list "g+w" (conc *exe-path* "/" access-type)))
+ (let* ((spath (conc *exe-src* "/s" access-type))
+ (dpath (conc *exe-path* "/" access-type "/" exe-name)))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd "/bin/cp" (list spath dpath ))
+ (if (equal? access-type "publish")
+ (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
+ (begin
+ (if (equal? group "none")
+ (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
+ (begin
+ (run-cmd "/bin/chgrp" (list group dpath))
+ (run-cmd "/bin/chmod" (list "g+s,o+rx" dpath))))))))
+ (run-cmd "chmod" (list "g-w" (conc *exe-path* "/" access-type)))))
+
+(define (get-exe-name path group)
+ (let ((name ""))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (if (equal? (current-effective-user-id) (file-owner path))
+ (set! name (conc (current-user-name) "_" group))
+ (begin
+ (print "You cannot open areas that you dont own!!")
+ (exit 1)))))
+name))
+
+(define (sauthorize:valid-unix-user username)
+ (let* ((ret-val #f))
+ (let-values (((inp oup pid)
+ (process "/usr/bin/id" (list username))))
+ (let loop ((inl (read-line inp)))
+ (if (string? inl)
+ (if (string-contains inl "No such user")
+ (set! ret-val #f)
+ (set! ret-val #t)))
+ (if (eof-object? inl)
+ (begin
+ (close-input-port inp)
+ (close-output-port oup))
+ (loop (read-line inp)))))
+ ret-val))
+
+
+;check if a paths/codes are vaid and if area is alrady open
+(define (open-area group path code access-type other-grps)
+ (let* ((exe-name (get-exe-name path group))
+ (path-obj (get-obj-by-path path))
+ (code-obj (get-obj-by-code-no-grp-validation code)))
+ ;(print path-obj)
+ (cond
+ ((not (null? path-obj))
+ (if (equal? code (car path-obj))
+ (begin
+ (if (equal? exe-name (cadr path-obj))
+ (begin
+ (if (not (exe-exist exe-name access-type))
+ (copy-exe access-type exe-name group)
+ (begin
+ (print "Area already open!!")
+ (exit 1))))
+ (begin
+ (if (not (exe-exist exe-name access-type))
+ (copy-exe access-type exe-name group))
+ ;; update exe-name in db
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "update areas set exe_name = '" exe-name "' where id = " (caddr path-obj)))))
+ )))
+ (begin
+ (print "Path " path " is registered with --code " (car path-obj) ". To open this area please execute following cmd: \n sauthorize open " path " --group " group " --code " (car path-obj) " --" access-type )
+ (exit 1))))
+
+ ((not (null? code-obj))
+ (print "Code " code " is used for diffrent path. Please try diffrent value of --code" )
+ (exit 1))
+ (else
+ ; (print (exe-exist exe-name access-type))
+ (if (not (exe-exist exe-name access-type))
+ (copy-exe access-type exe-name group))
+ (sauthorize:db-do (lambda (db)
+ (print conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') ")
+ (sauthorize:db-qry db (conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') "))))))))
+
+(define (user-has-open-perm user path access)
+ (let* ((has-access #f)
+ (eid (current-user-id)))
+ (cond
+ ((is-admin user)
+ (set! has-access #t ))
+ ((and (is-read-admin user) (equal? access "retrieve"))
+ (set! has-access #t ))
+ (else
+ (print "User " user " does not have permission to open areas")))
+ has-access))
+
+
+;;check if user has group access
+(define (is-group-washed req_grpid current-grp-list)
+ (let loop ((hed (car current-grp-list))
+ (tal (cdr current-grp-list)))
+ (cond
+ ((equal? hed req_grpid)
+ #t)
+ ((null? tal)
+ #f)
+ (else
+ (loop (car tal)(cdr tal))))))
+
+;create executables with appropriate suids
+(define (sauthorize:open user path group code access-type other-groups)
+ (let* ((gpid (group-information group))
+ (req_grpid (if (equal? group "none")
+ group
+ (if (equal? gpid #f)
+ #f
+ (caddr gpid))))
+ (current-grp-list (get-groups))
+ (valid-grp (if (equal? group "none")
+ group
+ (is-group-washed req_grpid current-grp-list))))
+ (if (and (not (equal? group "none")) (equal? valid-grp #f ))
+ (begin
+ (print "Group " group " is not washed in the current xterm!!")
+ (exit 1))))
+ (if (not (file-write-access? path))
+ (begin
+ (print "You can open areas owned by yourself. You do not have permissions to open path." path)
+ (exit 1)))
+ (if (user-has-open-perm user path access-type)
+ (begin
+ ;(print "here")
+ (open-area group path code access-type other-groups)
+ (sauthorize:grant user user code "2017/12/25" "read-admin" "")
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize open " path " --code " code " --group " group " --" access-type "'," (car (get-user user)) "," (car (get-area code)) ", 'open' )"))))
+ (print "Area has " path " been opened for " access-type ))))
+
+(define (sauthorize:update username exe area access-type)
+ (let* ((parts (string-split exe "_"))
+ (owner (car parts))
+ (group (cadr parts))
+ (gpid (group-information group))
+ (req_grpid (if (equal? group "none")
+ group
+ (if (equal? gpid #f)
+ #f
+ (caddr gpid))))
+
+ (current-grp-list (get-groups))
+ (valid-grp (if (equal? group "none")
+ group
+ (is-group-washed req_grpid current-grp-list))))
+ (if (not (equal? username owner))
+ (begin
+ (print "You cannot update " area ". Only " owner " can update this area!!")
+ (exit 1)))
+ (copy-exe access-type exe group)
+ (print "recording action..")
+ (sauthorize:db-do (lambda (db)
+
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize update " area " --" access-type "'," (car (get-user username)) "," (car (get-area area)) ", 'update' )"))))
+ (print "Area has " area " been update!!" )))
+
+(define (sauthorize:grant auser guser area exp-date access-type restrict)
+ ; check if user exist in db
+ (let* ((area-obj (get-area area))
+ (auser-obj (get-user auser))
+ (user-obj (get-user guser)))
+
+ (if (null? user-obj)
+ (begin
+ ;; is guser a valid unix user
+ (if (not (sauthorize:valid-unix-user guser))
+ (begin
+ (print "User " guser " is Invalid unix user!!")
+ (exit 1)))
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "insert into users (username, is_admin) values ('" guser "', 'no') "))))
+ (set! user-obj (get-user guser))))
+ (let* ((perm-obj (get-perm (car user-obj) (car area-obj))))
+ (if(null? perm-obj)
+ (begin
+ ;; insert permissions
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "insert into permissions (access_type, user_id, area_id, restriction, expiration ) values ('" access-type "', " (car user-obj) ", " (car area-obj) ", '" restrict "', '" exp-date "')")))))
+ (begin
+ ;update permissions
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "update permissions set access_type = '" access-type "' , restriction = '" restrict "', expiration = '" exp-date "' where user_id = " (car user-obj) " and area_id = " (car area-obj)))))))
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize grant " guser " --area " area " --expiration " exp-date " --" access-type " --restrict " restrict "'," (car auser-obj) "," (car area-obj) ", 'grant' )"))))
+ (print "Permission has been sucessfully granted to user " guser))))
+
+(define (sauthorize:process-action username action . args)
+ (case (string->symbol action)
+ ((grant)
+ (if (< (length args) 6)
+ (begin
+ (print "ERROR: Missing arguments; " (string-intersperse args ", "))
+ (exit 1)))
+ (let* ((remargs (args:get-args args '("--area" "--expiration" "--restrict") '() args:arg-hash 0))
+ (guser (car args))
+ (restrict (or (args:get-arg "--restrict") ""))
+ (area (or (args:get-arg "--area") ""))
+ (exp-date (or (args:get-arg "--expiration") ""))
+ (access-type (get-access-type remargs)))
+ ; (print "version " guser " restrict " restrict )
+ ; (print "area " area " exp-date " exp-date " access-type " access-type)
+ (cond
+ ((equal? guser "")
+ (print "Username not found!! Try \"sauthorize help\" for useage ")
+ (exit 1))
+ ((equal? area "")
+ (print "Area not found!! Try \"sauthorize help\" for useage ")
+ (exit 1))
+ ((equal? access-type #f)
+ (print "Access type not found!! Try \"sauthorize help\" for useage ")
+ (exit 1))
+ ((equal? exp-date "")
+ (print "Date of expiration not found!! Try \"sauthorize help\" for useage ")
+ (exit 1)))
+ (if (not (area-exists area))
+ (begin
+ (print "Area does not exisit!!")
+ (exit 1)))
+ (if (can-grant-perm username access-type area)
+ (begin
+ (print "calling sauthorize:grant ")
+ (sauthorize:grant username guser area exp-date access-type restrict))
+ (begin
+ (print "User " username " does not have permission to grant permissions to area " area "!!")
+ (exit 1)))))
+ ((list-area-user)
+ (if (not (equal? (length args) 1))
+ (begin
+ (print "Missing argument area code to list-area-user ")
+ (exit 1)))
+ (let* ((area (car args)))
+ (if (not (area-exists area))
+ (begin
+ (print "Area does not exisit!!")
+ (exit 1)))
+
+ (sauthorize:list-areausers area )
+ ))
+ ((read-shell)
+ (if (not (equal? (length args) 1))
+ (begin
+ (print "Missing argument area code to read-shell ")
+ (exit 1)))
+ (let* ((area (car args))
+ (code-obj (get-obj-by-code area)))
+ (if (or (null? code-obj)
+ (not (exe-exist (cadr code-obj) "retrieve")))
+ (begin
+ (print "Area " area " is not open for reading!!")
+ (exit 1)))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (list "shell" area ))))))
+ ((write-shell)
+ (if (not (equal? (length args) 1))
+ (begin
+ (print "Missing argument area code to read-shell ")
+ (exit 1)))
+ (let* ((area (car args))
+ (code-obj (get-obj-by-code area)))
+ (if (or (null? code-obj)
+ (not (exe-exist (cadr code-obj) "publish")))
+ (begin
+ (print "Area " area " is not open for Writing!!")
+ (exit 1)))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (list "shell" area))))))
+ ((publish)
+ (if (< (length args) 2)
+ (begin
+ (print "Missing argument to publish. \n publish [opts] ")
+ (exit 1)))
+
+ (let* ((action (car args))
+ (area (cadr args))
+ (cmd-args (cddr args))
+ (code-obj (get-obj-by-code area)))
+ ;(print "area " area)
+ ;(print "code: " code-obj)
+ ;(print (exe-exist (cadr code-obj) "publish"))
+ (if (or (null? code-obj)
+ (not (exe-exist (cadr code-obj) "publish")))
+ (begin
+ (print "Area " area " is not open for writing!!")
+ (exit 1)))
+ ;(print "hear")
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ ; (print *exe-path* "/publish/" (cadr code-obj) action area cmd-args )
+ (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (append (list action area ) cmd-args))))))
+
+ ((retrieve)
+ (if (< (length args) 2)
+ (begin
+ (print "Missing argument to publish. \n publish [opts] ")
+ (exit 1)))
+ (let* ((action (car args))
+ (area (cadr args))
+ (cmd-args (cddr args))
+ (code-obj (get-obj-by-code area)))
+ (if (or (null? code-obj)
+ (not (exe-exist (cadr code-obj) "retrieve")))
+ (begin
+ (print "Area " area " is not open for reading!!")
+ (exit 1)))
+ ;(print (conc *exe-path* "/retrieve/" (cadr code-obj) " " action " " area " " (string-join cmd-args)))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (append (list action area ) cmd-args))))))
+
+
+
+ ((open)
+ (if (< (length args) 6)
+ (begin
+ (print "sauthorize open cmd takes 6 arguments!! \n Useage: sauthorize open --group --code --retrieve|--publish")
+ (exit 1)))
+ (let* ((remargs (args:get-args args '("--group" "--code" "--additional-grps") '() args:arg-hash 0))
+ (path (car args))
+ (group (or (args:get-arg "--group") ""))
+ (area (or (args:get-arg "--code") ""))
+ (other-grps (or (args:get-arg "--additional-grps") ""))
+ (access-type (get-access-type remargs)))
+
+ (cond
+ ((equal? path "")
+ (print "path not found!! Try \"sauthorize help\" for useage ")
+ (exit 1))
+ ((equal? area "")
+ (print "--code not found!! Try \"sauthorize help\" for useage ")
+ (exit 1))
+ ((equal? access-type #f)
+ (print "Access type not found!! Try \"sauthorize help\" for useage ")
+ (exit 1))
+ ((and (not (equal? access-type "publish"))
+ (not (equal? access-type "retrieve")))
+ (print "Access type can be eiter --retrieve or --publish !! Try \"sauthorize help\" for useage ")
+ (exit 1)))
+ ; (print other-grps)
+ (sauthorize:open username path group area access-type other-grps)))
+ ((update)
+ (if (< (length args) 2)
+ (begin
+ (print "sauthorize update cmd takes 2 arguments!! \n Useage: sauthorize update --retrieve|--publish")
+ (exit 1)))
+ (let* ((area (car args))
+ (code-obj (get-obj-by-code area))
+ (access-type (get-access-type (cdr args))))
+ (if (and (not (equal? access-type "publish")) (not (equal? access-type "retrieve")))
+ (begin
+ (print "Access type can be --retrieve|--publish ")
+ (exit 1)))
+ (if (or (null? code-obj)
+ (not (exe-exist (cadr code-obj) access-type)))
+ (begin
+ (print "Area " area " is not open for reading!!")
+ (exit 1)))
+ (sauthorize:update username (cadr code-obj) area access-type )))
+ ((area-admin)
+ (let* ((usr (car args))
+ (usr-obj (get-user usr))
+ (user-id (car (get-user username))))
+
+ (if (is-admin username)
+ (begin
+ ; (print usr-obj)
+ (if (null? usr-obj)
+ (begin
+ (sauthorize:db-do (lambda (db)
+ ;(print (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )"))
+ (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )")))))
+ (begin
+ ; (print (conc "update users set is_admin = 'no' where id = " (car usr-obj) ))
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "update users set is_admin = 'read-admin' where id = " (car usr-obj)))))))
+ (print "User " usr " is updated with area-admin access!"))
+ (print "Admin only function"))
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('area-admin " usr " ', " user-id ",0, 'area-admin ')" ))))))
+ ((mk-admin)
+ (let* ((usr (car args))
+ (usr-obj (get-user usr))
+ (user-id (car (get-user username))))
+ (if (not (sauthorize:valid-unix-user usr))
+ (begin
+ (print "User " usr " is Invalid unix user!!")
+ (exit 1)))
+
+ (if (member username *super-users*)
+ (begin
+ (if (null? usr-obj)
+ (begin
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'yes' )")))))
+ (begin
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "update users set is_admin = 'yes' where id = " (car usr-obj)))))))
+ (print "User " usr " is updated with admin access!"))
+ (print "Super-Admin only function"))
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('mk-admin " usr " ', " user-id ",0, 'mk-admin ')" ))))))
+
+ ((register-log)
+ (if (< (length args) 4)
+ (print "Invalid arguments"))
+ ;(print args)
+ (let* ((cmd-line (car args))
+ (user-id (cadr args))
+ (area-id (caddr args))
+ (user-obj (get-user username))
+ (cmd (cadddr args)))
+
+ (if (and (not (null? user-obj)) (equal? user-id (number->string(car user-obj))))
+ (begin
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('" cmd-line"', " user-id "," area-id ", '" cmd "')" )))))
+ (print "You ar not authorised to run this cmd")
+
+)))
+
+
+ (else (print 0 "Unrecognised command " action))))
+
+(define (main)
+ (let* ((args (argv))
+ (prog (car args))
+ (rema (cdr args))
+ (username (current-user-name)))
+ ;; preserve the exe data in the config file
+ (cond
+ ;; one-word commands
+ ((eq? (length rema) 1)
+ (case (string->symbol (car rema))
+ ((help -h -help --h --help)
+ (print sauthorize:help))
+ ((list)
+
+ (sauthorize:db-do (lambda (db)
+ (print "My Area accesses: ")
+ (query (for-each-row
+ (lambda (row)
+ (let* ((exp-date (car row)))
+ (if (is-access-valid exp-date)
+ (apply print (intersperse (cdr row) " | "))))))
+ (sql db (conc "SELECT permissions.expiration, areas.basepath, areas.code, permissions.access_type FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "'"))))))
+
+ ((log)
+ (sauthorize:db-do (lambda (db)
+ (print "Logs : ")
+ (query (for-each-row
+ (lambda (row)
+
+ (apply print (intersperse row " | "))))
+ (sql db "SELECT actions.cmd, users.username, actions.action_type, actions.datetime, areas.code FROM actions, users, areas where actions.user_id = users.id and actions.area_id = areas.id ")))))
+ (else
+ (print "ERROR: Unrecognised command. Try \"sauthorize help\""))))
+ ;; multi-word commands
+ ((null? rema)(print sauthorize:help))
+ ((>= (length rema) 2)
+ (apply sauthorize:process-action username (car rema)(cdr rema)))
+ (else (debug:print 0 "ERROR: Unrecognised command. Try \"sauthorize help\"")))))
+
+(main)
+
+
+
DELETED sauthorize.scm
Index: sauthorize.scm
==================================================================
--- sauthorize.scm
+++ /dev/null
@@ -1,651 +0,0 @@
-
-;; Copyright 2006-2013, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see .
-;;
-
-(use defstruct)
-(use scsh-process)
-
-(use srfi-18)
-(use srfi-19)
-(use refdb)
-
-(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
-;(declare (uses common))
-;(declare (uses configf))
-(declare (uses margs))
-(declare (uses megatest-version))
-
-(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 synchash.scm
Index: synchash.scm
==================================================================
--- synchash.scm
+++ /dev/null
@@ -1,33 +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 .
-;;
-;;======================================================================
-
-;;======================================================================
-;; A hash of hashes that can be kept in sync by sending minial deltas
-;;======================================================================
-
-(use format)
-(use srfi-1 srfi-69 sqlite3)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (unit synchash))
-(declare (uses db))
-(declare (uses server))
-(include "db_records.scm")
-
DELETED telemetry-daemon
Index: telemetry-daemon
==================================================================
--- telemetry-daemon
+++ /dev/null
@@ -1,265 +0,0 @@
-#!/usr/bin/env python
-# -*- Mode: Python; -*-
-## Tiny Syslog Server in Python.
-##
-## This is a tiny syslog server that is able to receive UDP based syslog
-## entries on a specified port and save them to a file.
-## That's it... it does nothing else...
-
-
-import os
-import sys, os, time, atexit
-from signal import SIGTERM
-import logging
-import logging.handlers
-import SocketServer
-import datetime
-from subprocess import call
-import argparse
-import os
-import socket
-
-## code to determine this host's IP on non-loopback interface
-if os.name != "nt":
- import fcntl
- import struct
-
- def get_interface_ip(ifname):
- s = socket.socket(socket.AF_INET, socket.SOCK_DGRAM)
- return socket.inet_ntoa(fcntl.ioctl(s.fileno(), 0x8915, struct.pack('256s',
- ifname[:15]))[20:24])
-
-def get_lan_ip():
- ip = socket.gethostbyname(socket.gethostname())
- if ip.startswith("127.") and os.name != "nt":
- interfaces = [
- "eth0",
- "eth1",
- "eth2",
- "wlan0",
- "wlan1",
- "wifi0",
- "ath0",
- "ath1",
- "ppp0",
- ]
- for ifname in interfaces:
- try:
- ip = get_interface_ip(ifname)
- break
- except IOError:
- pass
- return ip
-
-class Daemon(object):
- """
- A generic daemon class.
-
- Usage: subclass the Daemon class and override the run() method
- """
- def __init__(self, pidfile, stdin='/dev/null', stdout='/dev/null', stderr='/dev/null'):
- self.stdin = stdin
- self.stdout = stdout
- self.stderr = stderr
- self.pidfile = pidfile
-
- def daemonize(self):
- """
- do the UNIX double-fork magic, see Stevens' "Advanced
- Programming in the UNIX Environment" for details (ISBN 0201563177)
- http://www.erlenstar.demon.co.uk/unix/faq_2.html#SEC16
- """
- try:
- pid = os.fork()
- if pid > 0:
- # exit first parent
- sys.exit(0)
- except OSError, e:
- sys.stderr.write("fork #1 failed: %d (%s)\n" % (e.errno, e.strerror))
- sys.exit(1)
-
- # decouple from parent environment
- os.chdir("/")
- os.setsid()
- os.umask(0)
-
- # do second fork
- try:
- pid = os.fork()
- if pid > 0:
- # exit from second parent
- sys.exit(0)
- except OSError, e:
- sys.stderr.write("fork #2 failed: %d (%s)\n" % (e.errno, e.strerror))
- sys.exit(1)
-
- # redirect standard file descriptors
- sys.stdout.flush()
- sys.stderr.flush()
- si = file(self.stdin, 'r')
- so = file(self.stdout, 'a+')
- se = file(self.stderr, 'a+', 0)
- os.dup2(si.fileno(), sys.stdin.fileno())
- os.dup2(so.fileno(), sys.stdout.fileno())
- os.dup2(se.fileno(), sys.stderr.fileno())
-
- # write pidfile
- atexit.register(self.delpid)
- pid = str(os.getpid())
- file(self.pidfile,'w+').write("%s\n" % pid)
-
- def delpid(self):
- os.remove(self.pidfile)
-
- def start(self):
- """
- Start the daemon
- """
- # Check for a pidfile to see if the daemon already runs
- try:
- pf = file(self.pidfile,'r')
- pid = int(pf.read().strip())
- pf.close()
- except IOError:
- pid = None
-
- if pid:
- message = "pidfile %s already exist. Daemon already running?\n"
- sys.stderr.write(message % self.pidfile)
- sys.exit(1)
-
- # Start the daemon
- self.daemonize()
- self.run()
-
- def stop(self):
- """
- Stop the daemon
- """
- # Get the pid from the pidfile
- try:
- pf = file(self.pidfile,'r')
- pid = int(pf.read().strip())
- pf.close()
- except IOError:
- pid = None
-
- if not pid:
- message = "pidfile %s does not exist. Daemon not running?\n"
- sys.stderr.write(message % self.pidfile)
- return # not an error in a restart
-
- # Try killing the daemon process
- try:
- while 1:
- os.kill(pid, SIGTERM)
- time.sleep(0.1)
- except OSError, err:
- err = str(err)
- if err.find("No such process") > 0:
- if os.path.exists(self.pidfile):
- os.remove(self.pidfile)
- else:
- print str(err)
- sys.exit(1)
-
- def restart(self):
- """
- Restart the daemon
- """
- self.stop()
- self.start()
-
- def run(self):
- """
- You should override this method when you subclass Daemon. It will be called after the process has been
- daemonized by start() or restart().
- """
-
-# setup logging module so that the log can be moved aside and will reopen for append
-def log_setup(logfile):
- log_handler = logging.handlers.WatchedFileHandler(logfile)
- formatter = logging.Formatter(
- '%(message)s','')
- log_handler.setFormatter(formatter)
- logger = logging.getLogger()
- logger.addHandler(log_handler)
- logger.setLevel(logging.INFO)
-
-
-class SyslogUDPHandler(SocketServer.BaseRequestHandler):
- def handle(self):
- data = bytes.decode(self.request[0].strip())
- socket = self.request[1]
- print( "%s : " % self.client_address[0], str(data))
- timestamp = datetime.datetime.now().isoformat()
- logline = timestamp + ":"+self.client_address[0] + ":" + str(data)
- logging.info(str(logline))
-
-
-
-class TelemetryLogDaemon(Daemon):
- def __init__(self, pidfile, logfile, server_ip, server_port):
- self.logfile = logfile
- self.server_ip = server_ip
- self.server_port = server_port
- super(TelemetryLogDaemon, self).__init__(pidfile)
-
- def run(self):
- log_setup(self.logfile)
- server = SocketServer.UDPServer((self.server_ip,int(self.server_port)), SyslogUDPHandler)
- server.serve_forever(poll_interval=0.5)
-
-
-def main():
- default_log_file = os.environ['PWD'] + "/telemetry.log"
-
- parser = argparse.ArgumentParser(description = 'telemetry-daemon')
- actions="start,restart,stop,nodaemon".split(",")
-
- parser.add_argument("-a", "--action", required=True, choices=actions, help="manage daemon: start stop or restart")
- parser.add_argument("-p", "--server-port", default="5929", help="specify alternate udp port number, default is 5929")
- parser.add_argument("-i", "--server-ip", default=get_lan_ip(), help="specify IP if heuristics to get local host lan ip fails")
- parser.add_argument("-l", "--log-file", default=default_log_file, help="specify log file to write")
- parser.add_argument("-z", "--pid-file", default=default_log_file + ".pidfile", help="specify pidfile")
- opts = parser.parse_args()
-
- tld = TelemetryLogDaemon(opts.pid_file, opts.log_file, opts.server_ip, opts.server_port)
-
- if opts.action == "start":
- print "Info: Starting server"
- print """Example addition to megatest.config to enable telemetry:
-
-[telemetry]
-host %s
-port %s
-want-events ALL
-
- """ % (opts.server_ip, opts.server_port)
- tld.start()
-
- elif opts.action == "stop":
- tld.stop()
- elif opts.action == "restart":
-
- print "Info: Restarting server"
- print """Example addition to megatest.config to enable telemetry:
-
-[telemetry]
-host %s
-port %s
-want-events ALL
-
- """ % (opts.server_ip, opts.server_port)
- tld.restart()
- elif opts.action == "nodaemon":
- log_setup(opts.log_file)
- server = SocketServer.UDPServer((opts.server_ip,int(opts.server_port)), SyslogUDPHandler)
- server.serve_forever(poll_interval=0.5)
-
-if __name__ == '__main__':
- main()
-
-
-
-
DELETED trackback.scm
Index: trackback.scm
==================================================================
--- trackback.scm
+++ /dev/null
@@ -1,53 +0,0 @@
-;; Copyright 2006-2017, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see .
-
-(include "codescanlib.scm")
-
-;; show call paths for named procedure
-(define (traceback-proc in-procname)
- (letrec* ((all-scm-files (glob "*.scm"))
- (xref (get-xref all-scm-files))
- (have (alist-ref (string->symbol in-procname) xref eq? #f))
- (lookup (lambda (path procname depth)
- (let* ((upcone-temp (filter (lambda (x)
- (eq? procname (car x)))
- xref))
- (upcone-temp2 (cond
- ((null? upcone-temp) '())
- (else (cdar upcone-temp))))
- (upcone (filter
- (lambda (x) (not (eq? x procname)))
- upcone-temp2))
- (uppath (cons procname path))
- (updepth (add1 depth)))
- (if (null? upcone)
- (print uppath)
- (for-each (lambda (x)
- (if (not (member procname path))
- (lookup uppath x updepth) ))
- upcone))))))
- (if have
- (lookup '() (string->symbol in-procname) 0)
- (print "no such func - "in-procname))))
-
-
-(if (eq? 1 (length (command-line-arguments)))
- (traceback-proc (car (command-line-arguments)))
- (print "Usage: trackback "))
-
-(exit 0)
-
ADDED utils/telemetry-daemon
Index: utils/telemetry-daemon
==================================================================
--- /dev/null
+++ utils/telemetry-daemon
@@ -0,0 +1,265 @@
+#!/usr/bin/env python
+# -*- Mode: Python; -*-
+## Tiny Syslog Server in Python.
+##
+## This is a tiny syslog server that is able to receive UDP based syslog
+## entries on a specified port and save them to a file.
+## That's it... it does nothing else...
+
+
+import os
+import sys, os, time, atexit
+from signal import SIGTERM
+import logging
+import logging.handlers
+import SocketServer
+import datetime
+from subprocess import call
+import argparse
+import os
+import socket
+
+## code to determine this host's IP on non-loopback interface
+if os.name != "nt":
+ import fcntl
+ import struct
+
+ def get_interface_ip(ifname):
+ s = socket.socket(socket.AF_INET, socket.SOCK_DGRAM)
+ return socket.inet_ntoa(fcntl.ioctl(s.fileno(), 0x8915, struct.pack('256s',
+ ifname[:15]))[20:24])
+
+def get_lan_ip():
+ ip = socket.gethostbyname(socket.gethostname())
+ if ip.startswith("127.") and os.name != "nt":
+ interfaces = [
+ "eth0",
+ "eth1",
+ "eth2",
+ "wlan0",
+ "wlan1",
+ "wifi0",
+ "ath0",
+ "ath1",
+ "ppp0",
+ ]
+ for ifname in interfaces:
+ try:
+ ip = get_interface_ip(ifname)
+ break
+ except IOError:
+ pass
+ return ip
+
+class Daemon(object):
+ """
+ A generic daemon class.
+
+ Usage: subclass the Daemon class and override the run() method
+ """
+ def __init__(self, pidfile, stdin='/dev/null', stdout='/dev/null', stderr='/dev/null'):
+ self.stdin = stdin
+ self.stdout = stdout
+ self.stderr = stderr
+ self.pidfile = pidfile
+
+ def daemonize(self):
+ """
+ do the UNIX double-fork magic, see Stevens' "Advanced
+ Programming in the UNIX Environment" for details (ISBN 0201563177)
+ http://www.erlenstar.demon.co.uk/unix/faq_2.html#SEC16
+ """
+ try:
+ pid = os.fork()
+ if pid > 0:
+ # exit first parent
+ sys.exit(0)
+ except OSError, e:
+ sys.stderr.write("fork #1 failed: %d (%s)\n" % (e.errno, e.strerror))
+ sys.exit(1)
+
+ # decouple from parent environment
+ os.chdir("/")
+ os.setsid()
+ os.umask(0)
+
+ # do second fork
+ try:
+ pid = os.fork()
+ if pid > 0:
+ # exit from second parent
+ sys.exit(0)
+ except OSError, e:
+ sys.stderr.write("fork #2 failed: %d (%s)\n" % (e.errno, e.strerror))
+ sys.exit(1)
+
+ # redirect standard file descriptors
+ sys.stdout.flush()
+ sys.stderr.flush()
+ si = file(self.stdin, 'r')
+ so = file(self.stdout, 'a+')
+ se = file(self.stderr, 'a+', 0)
+ os.dup2(si.fileno(), sys.stdin.fileno())
+ os.dup2(so.fileno(), sys.stdout.fileno())
+ os.dup2(se.fileno(), sys.stderr.fileno())
+
+ # write pidfile
+ atexit.register(self.delpid)
+ pid = str(os.getpid())
+ file(self.pidfile,'w+').write("%s\n" % pid)
+
+ def delpid(self):
+ os.remove(self.pidfile)
+
+ def start(self):
+ """
+ Start the daemon
+ """
+ # Check for a pidfile to see if the daemon already runs
+ try:
+ pf = file(self.pidfile,'r')
+ pid = int(pf.read().strip())
+ pf.close()
+ except IOError:
+ pid = None
+
+ if pid:
+ message = "pidfile %s already exist. Daemon already running?\n"
+ sys.stderr.write(message % self.pidfile)
+ sys.exit(1)
+
+ # Start the daemon
+ self.daemonize()
+ self.run()
+
+ def stop(self):
+ """
+ Stop the daemon
+ """
+ # Get the pid from the pidfile
+ try:
+ pf = file(self.pidfile,'r')
+ pid = int(pf.read().strip())
+ pf.close()
+ except IOError:
+ pid = None
+
+ if not pid:
+ message = "pidfile %s does not exist. Daemon not running?\n"
+ sys.stderr.write(message % self.pidfile)
+ return # not an error in a restart
+
+ # Try killing the daemon process
+ try:
+ while 1:
+ os.kill(pid, SIGTERM)
+ time.sleep(0.1)
+ except OSError, err:
+ err = str(err)
+ if err.find("No such process") > 0:
+ if os.path.exists(self.pidfile):
+ os.remove(self.pidfile)
+ else:
+ print str(err)
+ sys.exit(1)
+
+ def restart(self):
+ """
+ Restart the daemon
+ """
+ self.stop()
+ self.start()
+
+ def run(self):
+ """
+ You should override this method when you subclass Daemon. It will be called after the process has been
+ daemonized by start() or restart().
+ """
+
+# setup logging module so that the log can be moved aside and will reopen for append
+def log_setup(logfile):
+ log_handler = logging.handlers.WatchedFileHandler(logfile)
+ formatter = logging.Formatter(
+ '%(message)s','')
+ log_handler.setFormatter(formatter)
+ logger = logging.getLogger()
+ logger.addHandler(log_handler)
+ logger.setLevel(logging.INFO)
+
+
+class SyslogUDPHandler(SocketServer.BaseRequestHandler):
+ def handle(self):
+ data = bytes.decode(self.request[0].strip())
+ socket = self.request[1]
+ print( "%s : " % self.client_address[0], str(data))
+ timestamp = datetime.datetime.now().isoformat()
+ logline = timestamp + ":"+self.client_address[0] + ":" + str(data)
+ logging.info(str(logline))
+
+
+
+class TelemetryLogDaemon(Daemon):
+ def __init__(self, pidfile, logfile, server_ip, server_port):
+ self.logfile = logfile
+ self.server_ip = server_ip
+ self.server_port = server_port
+ super(TelemetryLogDaemon, self).__init__(pidfile)
+
+ def run(self):
+ log_setup(self.logfile)
+ server = SocketServer.UDPServer((self.server_ip,int(self.server_port)), SyslogUDPHandler)
+ server.serve_forever(poll_interval=0.5)
+
+
+def main():
+ default_log_file = os.environ['PWD'] + "/telemetry.log"
+
+ parser = argparse.ArgumentParser(description = 'telemetry-daemon')
+ actions="start,restart,stop,nodaemon".split(",")
+
+ parser.add_argument("-a", "--action", required=True, choices=actions, help="manage daemon: start stop or restart")
+ parser.add_argument("-p", "--server-port", default="5929", help="specify alternate udp port number, default is 5929")
+ parser.add_argument("-i", "--server-ip", default=get_lan_ip(), help="specify IP if heuristics to get local host lan ip fails")
+ parser.add_argument("-l", "--log-file", default=default_log_file, help="specify log file to write")
+ parser.add_argument("-z", "--pid-file", default=default_log_file + ".pidfile", help="specify pidfile")
+ opts = parser.parse_args()
+
+ tld = TelemetryLogDaemon(opts.pid_file, opts.log_file, opts.server_ip, opts.server_port)
+
+ if opts.action == "start":
+ print "Info: Starting server"
+ print """Example addition to megatest.config to enable telemetry:
+
+[telemetry]
+host %s
+port %s
+want-events ALL
+
+ """ % (opts.server_ip, opts.server_port)
+ tld.start()
+
+ elif opts.action == "stop":
+ tld.stop()
+ elif opts.action == "restart":
+
+ print "Info: Restarting server"
+ print """Example addition to megatest.config to enable telemetry:
+
+[telemetry]
+host %s
+port %s
+want-events ALL
+
+ """ % (opts.server_ip, opts.server_port)
+ tld.restart()
+ elif opts.action == "nodaemon":
+ log_setup(opts.log_file)
+ server = SocketServer.UDPServer((opts.server_ip,int(opts.server_port)), SyslogUDPHandler)
+ server.serve_forever(poll_interval=0.5)
+
+if __name__ == '__main__':
+ main()
+
+
+
+
ADDED utils/trackback.scm
Index: utils/trackback.scm
==================================================================
--- /dev/null
+++ utils/trackback.scm
@@ -0,0 +1,53 @@
+;; Copyright 2006-2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+(include "codescanlib.scm")
+
+;; show call paths for named procedure
+(define (traceback-proc in-procname)
+ (letrec* ((all-scm-files (glob "*.scm"))
+ (xref (get-xref all-scm-files))
+ (have (alist-ref (string->symbol in-procname) xref eq? #f))
+ (lookup (lambda (path procname depth)
+ (let* ((upcone-temp (filter (lambda (x)
+ (eq? procname (car x)))
+ xref))
+ (upcone-temp2 (cond
+ ((null? upcone-temp) '())
+ (else (cdar upcone-temp))))
+ (upcone (filter
+ (lambda (x) (not (eq? x procname)))
+ upcone-temp2))
+ (uppath (cons procname path))
+ (updepth (add1 depth)))
+ (if (null? upcone)
+ (print uppath)
+ (for-each (lambda (x)
+ (if (not (member procname path))
+ (lookup uppath x updepth) ))
+ upcone))))))
+ (if have
+ (lookup '() (string->symbol in-procname) 0)
+ (print "no such func - "in-procname))))
+
+
+(if (eq? 1 (length (command-line-arguments)))
+ (traceback-proc (car (command-line-arguments)))
+ (print "Usage: trackback "))
+
+(exit 0)
+