Megatest

	(export BASEPATH=/tmp/$(USER)/basepath ; export PATH="$(PWD)/datashare-testing:$(PATH)" ; xterm &)

datashare-testing/spublish : spublish.scm $(OFILES)
	csc $(CSCOPTS) spublish.scm $(OFILES) -o datashare-testing/spublish

datashare-testing/sretrieve : sretrieve.scm megatest-version.o margs.o configf.o process.o 
	csc $(CSCOPTS) sretrieve.scm megatest-version.o margs.o configf.o process.o -o datashare-testing/sretrieve

datashare-testing/sauthorize : sretrieve.scm megatest-version.o margs.o configf.o process.o common.o
	 csc sauthorize.scm megatest-version.o margs.o configf.o process.o common.o -o datashare-testing/sauthorize


sretrieve/sretrieve : datashare-testing/sretrieve
	csc $(CSCOPTS) -deploy -deployed sretrieve.scm megatest-version.o margs.o configf.o process.o
	chicken-install -keep-installed $(PROXY) -deploy -prefix sretrieve defstruct srfi-18 format sql-de-lite \
             srfi-1 posix regex regex-case srfi-69 

# base64 dot-locking \
#             csv-xml z3

#  "(define (toplevel-command . a) #f)"
# if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \

    ok))

(define (client:connect iface port)
  (case (server:get-transport)
    ((rpc)  (rpc:client-connect  iface port))
    ((http) (http:client-connect iface port))
    ((zmq)  (zmq:client-connect  iface port))
    (else
     (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " not supported (5)")
     (exit))))

(define (client:setup  run-id #!key (remaining-tries 10) (failed-connects 0))
  (case (server:get-transport)
    ((rpc) (let ((res (client:setup-rpc run-id remaining-tries: remaining-tries)))
             (remote-conndat-set! *runremote* res)
             res))
    ((http)(client:setup-http run-id remaining-tries: remaining-tries failed-connects: failed-connects))
    (else
     (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " not supported (6)")
     (exit)))) ;; (client:setup-rpc run-id))))

;; (define (client:login-no-auto-setup server-info run-id)
;;   (case (server:get-transport)
;;     ((rpc)  (rpc:login-no-auto-client-setup server-info run-id))
;;     ((http) (rmt:login-no-auto-client-setup server-info run-id))
;;     (else   (rpc:login-no-auto-client-setup server-info run-id))))
;; 

;;   2. We are a run tests, list runs or other interactive process and we must figure out
;;      *transport-type* and *runremote* from the monitor.db
;;
;; client:setup
;;
;; lookup_server, need to remove *runremote* stuff
;;

(define (client:setup-rpc run-id #!key (remaining-tries 10) (failed-connects 0))
  (debug:print-info 2 *default-log-port* "client:setup-rpc remaining-tries=" remaining-tries)
  (let* ((server-dat (tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id))
         (num-available (tasks:num-in-available-state (db:delay-if-busy (tasks:open-db)) run-id)))
    (cond
     ((<= remaining-tries 0)
      (debug:print-error 0 *default-log-port* "failed to start or connect to server for run-id " run-id)
      (exit 1))
     (server-dat
      (debug:print-info 4 *default-log-port* "client:setup-rpc server-dat=" server-dat ", remaining-tries=" remaining-tries)

      (rpc-transport:client-setup run-id server-dat remaining-tries: remaining-tries))
     (else
      (if (< num-available 2)
          (server:try-running run-id))
      (thread-sleep! (+ 2 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms.
      (client:setup run-id remaining-tries: (- remaining-tries 1))))))


(define (client:setup-http run-id #!key (remaining-tries 10) (failed-connects 0))
  (debug:print-info 2 *default-log-port* "client:setup remaining-tries=" remaining-tries)
  (let* ((tdbdat (tasks:open-db)))
    (if (<= remaining-tries 0)
	(begin
	  (debug:print-error 0 *default-log-port* "failed to start or connect to server for run-id " run-id)
	  (exit 1))
	(let* ((server-dat (tasks:get-server (db:delay-if-busy tdbdat) run-id)))
	  (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
	  (if server-dat
	      (let* ((iface     (tasks:hostinfo-get-interface server-dat))
		     (hostname  (tasks:hostinfo-get-hostname  server-dat))
		     (port      (tasks:hostinfo-get-port      server-dat))

		     (start-res (http-transport:client-connect iface port))



		     (ping-res  (rmt:login-no-auto-client-setup start-res)))






		(if (and start-res
			 ping-res)
		    (begin
		      (remote-conndat-set! *runremote* start-res) ;; (hash-table-set! *runremote* run-id start-res)
		      (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res))
		      start-res)
		    (begin    ;; login failed but have a server record, clean out the record and try again
		      (debug:print-info 0 *default-log-port* "client:setup, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat)
		      (case *transport-type* 
			((http)(http-transport:close-connections run-id)))
		      (remote-conndat-set! *runremote* #f)  ;; (hash-table-delete! *runremote* run-id)
		      (tasks:kill-server-run-id run-id)
		      (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat)
							   run-id 
							   (tasks:hostinfo-get-interface server-dat)
							   (tasks:hostinfo-get-port      server-dat)
							   " client:setup (server-dat = #t)")
		      (if (> remaining-tries 8)
			  (thread-sleep! (+ 1 (random 5))) ;; spread out the starts a little
			  (thread-sleep! (+ 15 (random 20)))) ;; it isn't going well. give it plenty of time
		      (server:try-running run-id)
		      (thread-sleep! 5)   ;; give server a little time to start up
		      (client:setup run-id remaining-tries: (- remaining-tries 1))
		      )))
	      (begin    ;; no server registered
		(let ((num-available (tasks:num-in-available-state (db:dbdat-get-db tdbdat) run-id)))
		  (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available)
		  (if (< num-available 2)
		      (server:try-running run-id))
		  (thread-sleep! (+ 5 (random (- 20 remaining-tries))))  ;; give server a little time to start up, randomize a little to avoid start storms.
		  (client:setup run-id remaining-tries: (- remaining-tries 1)))))))))

;; keep this as a function to ease future ;; this is unused, not porting for rpc -BB
(define (client:start run-id server-info)
  (http-transport:client-connect (tasks:hostinfo-get-interface server-info)
				 (tasks:hostinfo-get-port server-info)))

;; ;; client:signal-handler
;; (define (client:signal-handler signum)
;;   (signal-mask! signum)

(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))

(declare (unit common))

(include "common_records.scm")
(include "thunk-utils.scm")


;; (require-library margs)
;; (include "margs.scm")

;; (define old-exit exit)
;; 
;; (define (exit . code)

  (mutex-lock! *context-mutex*)
  (let ((cxt (hash-table-ref/default *contexts* toppath #f)))
    (if (not cxt)
        (set! cxt (let ((x (make-cxt)))(hash-table-set! *contexts* toppath x) x)))
    (let ((cxt-mutex (cxt-mutex cxt)))
      (mutex-unlock! *context-mutex*)
      (mutex-lock! cxt-mutex)
      ;; here we guard proc with exception handler so
      ;; no matter how proc succeeds or fails,
      ;; the cxt-mutex will be unlocked afterward.
      (let* ((EXCEPTION-SYMBOL (gensym)) ;; use a generated symbol
             (guarded-proc               ;; to avoid collision
              (lambda args
                (let* ((res (condition-case
                             (apply proc args)
                             [x () (cons EXCEPTION-SYMBOL x)])))
                 (mutex-unlock! cxt-mutex)
                 (if (and (pair? res) (eq? (car res) EXCEPTION))
                     (abort (cdr res))
                     res)))))
        (guarded-proc cxt)))))
        
(define *db-keys* #f)

(define *configinfo*   #f)   ;; raw results from setup, includes toppath and table from megatest.config
(define *runconfigdat* #f)   ;; run configs data
(define *configdat*    #f)   ;; megatest.config data
(define *configstatus* #f)   ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done

(define *task-db*             #f) ;; (vector db path-to-db)
(define *db-access-allowed*   #t) ;; flag to allow access
(define *db-access-mutex*     (make-mutex))
(define *db-cache-path*       #f)

;; SERVER
(define *my-client-signature* #f)
(define *transport-type*  #f)             ;; override with [server] transport http|rpc|nmsg

(define *DEFAULT-TRANSPORT* "http")
(define (common:set-transport-type)
  (set! *transport-type*
        (string->symbol
         (or
          (args:get-arg "-transport")
          (configf:lookup *configdat* "server" "transport")
          *DEFAULT-TRANSPORT*)))
  *transport-type*)
  
(define *runremote*         #f)                ;; if set up for server communication this will hold <host port>
(define *max-cache-size*    0)
(define *logged-in-clients* (make-hash-table))
(define *server-id*         #f)
(define *server-info*       #f)
(define *time-to-exit*      #f)
(define *server-run*        #t)

        (this-wd-num     (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x)))
        )
    (debug:print-info 0 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id)" this-wd-num="this-wd-num)
    (if (and legacy-sync (not *time-to-exit*))
	(let ((dbstruct (db:setup)))
	  (debug:print-info 0 *default-log-port* "Server running, periodic sync started.")
	  (let loop ()
            (BB> "watchdog loop.  pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
	    ;; sync for filesystem local db writes
	    ;;
	    (mutex-lock! *db-multi-sync-mutex*)
	    (let* ((need-sync        (>= *db-last-access* *db-last-sync*)) ;; no sync since last write
		   (sync-in-progress *db-sync-in-progress*)
		   (should-sync      (and (not *time-to-exit*)
                                          (> (- (current-seconds) *db-last-sync*) 5))) ;; sync every five seconds minimum

		    (set! last-time start-time)
		    (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
	    
	    ;; keep going unless time to exit
	    ;;
	    (if (not *time-to-exit*)
		(let delay-loop ((count 0))
                  (BB> "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
                                                            
		  (if (and (not *time-to-exit*)
			   (< count 4)) ;; was 11, changing to 4. 
		      (begin
			(thread-sleep! 1)
			(delay-loop (+ count 1))))
		  (if (not *time-to-exit*) (loop))))
	    (if (common:low-noise-print 30)
		(debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" this-wd-num="this-wd-num)))))))

(define (std-exit-procedure)
  (on-exit (lambda () 0))

  (let ((no-hurry  (if *time-to-exit* ;; hurry up
		       #f
		       (begin
			 (set! *time-to-exit* #t)
			 #t))))
    (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
    (if (and no-hurry (debug:debug-mode 18))

                                  (begin
                                    (thread-sleep! 5)) ;; give the clean up few seconds to do it's stuff
                                  (begin
      				  (thread-sleep! 2)))
      			      (debug:print 4 *default-log-port* " ... done")
      			      )
			    "clean exit")))

      ;; let's try to clean up open sockets
      (if *runremote*
          (case (remote-transport *runremote*)
            ((http) #t)
            ((rpc)  (rpc:close-all-connections!))
            (else
             (debug:print-info 0 *default-log-port* "Transport "(remote-transport *runremote*)" not supported"))))

      (thread-start! th1)
      (thread-start! th2)
      (thread-join! th1)
      )
    )

  0)

(define (std-signal-handler signum)
  ;; (signal-mask! signum)
  (set! *time-to-exit* #t)

  (debug:print-error 0 *default-log-port* "Received signal " signum " exiting promptly")
  ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway
  (exit))

(set-signal-handler! signal/int  std-signal-handler)  ;; ^C
(set-signal-handler! signal/term std-signal-handler)
;; (set-signal-handler! signal/stop std-signal-handler)  ;; ^Z NO, do NOT handle ^Z!

	(lambda ()
	  (if *logging*
	      (db:log-event (apply conc params))
	      (apply print params)
	      )))))

;; Brandon's debug printer shortcut (indulge me :)

(define (BB> . in-args)
  (let* ((stack (get-call-chain))
         (location #f))
    (for-each
     (lambda (frame)
       (let* ((this-loc (vector-ref frame 0))
              (this-func (cadr (string-split this-loc " "))))
         (if (equal? this-func "BB>")
             (set! location this-loc))))
     stack)
    (let ((dp-args (append (list 0 *default-log-port* location"   "  ) in-args)))
      (apply debug:print dp-args))))

(define *BBpp_custom_expanders_list* (make-hash-table))



;; register hash tables with BBpp.

                                   (setup-env-defaults runconfigf run-id (make-hash-table) keydat environ-patt: keystring))
	 			 (make-hash-table))))
	       (testconfig    (begin
				;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path)
				(runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process
				(handle-exceptions
				 exn
				 (tests:get-testconfig (db:test-get-testname testdat) test-registry #f)
				 (tests:get-testconfig (db:test-get-testname testdat) test-registry #t))))
	       (viewlog    (lambda (x)
			     (if (file-exists? logfile)
					;(system (conc "firefox " logfile "&"))
				 (dashboard-tests:run-html-viewer logfile)
				 (message-window (conc "File " logfile " not found")))))
	       (view-a-log (lambda (lfile) 

[settings]
base-dir      /tmp/delme_data
allowed-users matt 
allowed-chars [0-9a-zA-Z\-\.]+
allowed-sub-paths [0-9a-zA-Z\-\.]+
[database]
location #{scheme (create-directory "/tmp/#{getenv USER}" #t)}

				      (res #f))
				 (cond
				  ((equal? (uri-path (request-uri (current-request)))
					   '(/ "api"))
				   (send-response body:    (api:process-request *dbstruct-db* $) ;; the $ is the request vars proc
						  headers: '((content-type text/plain)))
				   (mutex-lock! *heartbeat-mutex*)
				   (set! *db-lastaccess* (current-seconds))
				   (mutex-unlock! *heartbeat-mutex*))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ ""))
				   (send-response body: (http-transport:main-page)))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ "json_api"))
				   (send-response body: (http-transport:main-page)))

;;
;; connect
;;
(define (http-transport:client-connect iface port)
  (let* ((api-url      (conc "http://" iface ":" port "/api"))
	 (api-uri      (uri-reference (conc "http://" iface ":" port "/api")))
	 (api-req      (make-request method: 'POST uri: api-uri))
	 (server-dat   (vector iface port api-uri api-url api-req (current-seconds) 'http)))
    server-dat))

;; run http-transport:keep-running in a parallel thread to monitor that the db is being 
;; used and to shutdown after sometime if it is not.
;;
(define (http-transport:keep-running server-id run-id)
  ;; if none running or if > 20 seconds since 

         (last-access 0)
	 (server-timeout (server:get-timeout))
	 (server-going  #f))
    (let loop ((count         0)
	       (server-state 'available)
	       (bad-sync-count 0)
	       (start-time     (current-milliseconds)))

      ;; Use this opportunity to sync the tmp db to megatest.db
      (if (not server-going) ;; *dbstruct-db* 
	    ;; Removed code is pasted below (keeping it around until we are clear it is not needed).
	    ;; no *dbstruct-db* yet, set running after our first pass through and start the db
	    (if (eq? server-state 'available)
		(let ((new-server-id (tasks:server-am-i-the-server? (db:delay-if-busy tdbdat) run-id))) ;; try to ensure no double registering of servers
		  (if (equal? new-server-id server-id)
		      (begin
			(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep")

			(thread-sleep! 0.5) ;; give some margin for queries to complete before switching from file based access to server based access
			(set! *dbstruct-db*  (db:setup)) ;;  run-id))
			(set! server-going #t)
			(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running")

			(server:write-dotserver *toppath* (conc iface ":" port))

                        (server:dotserver-starting-remove))
                      (begin ;; gotta exit nicely

			(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "collision")
			(http-transport:server-shutdown server-id port))))))

      ;; when things go wrong we don't want to be doing the various queries too often
      ;; so we strive to run this stuff only every four seconds or so.
      (let* ((sync-time (- (current-milliseconds) start-time))
	    (rem-time  (quotient (- 4000 sync-time) 1000)))
	(if (and (<= rem-time 4)
		 (>  rem-time 0))
	    (thread-sleep! rem-time)))

;; (if (and (<= rem-time 4)
;; 	     (> rem-time 0))
;; 	(thread-sleep! rem-time)
;; 	(thread-sleep! 4))) ;; fallback for if the math is changed ...

(define (http-transport:server-shutdown server-id port)
  (let ((tdbdat (tasks:open-db)))

    (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id))
    ;;
    ;; start_shutdown
    ;;
    (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down")
    (set! *time-to-exit* #t) ;; tell on-exit to be fast as we've already cleaned up
    (portlogger:open-run-close portlogger:set-port port "released")

			  (/ *total-non-write-delay* 
			     *number-non-write-queries*))
		      " ms")
    (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
    (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running complete")
    ;; if the .server file contained :myport then we can remove it
    (server:remove-dotserver-file *toppath* port)

    (exit)))

;; all routes though here end in exit ...
;;
;; start_server? 
;;
(define (http-transport:launch run-id)
  (server:dotserver-starting)
  (let* ((tdbdat (tasks:open-db)))
    (set! *run-id*   run-id)
    (if (args:get-arg "-daemonize")
	(begin
	  (daemon:ize)
	  (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it
	      (begin
		(current-error-port *alt-log-file*)
		(current-output-port *alt-log-file*)))))
    (if (and (server:read-dotserver *toppath*)
             (server:check-if-running run-id))
	(begin
	  (debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running")
	  (exit 0))
	(begin ;; ok, no server detected, clean out any lingering records
	   (tasks:server-force-clean-running-records-for-run-id  (db:delay-if-busy tdbdat) run-id "notresponding")))
    (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id 'http))
	       (remtries  4))
      (if (not server-id)
	  (if (> remtries 0)
	      (begin
		(thread-sleep! 2)
		(loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id 'http)
		      (- remtries 1)))
	      (begin
		;; since we didn't get the server lock we are going to clean up and bail out
		(debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
		(tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch")
                
                (server:dotserver-starting-remove)
		))
	  (let* ((th2 (make-thread (lambda ()
				     (debug:print-info 0 *default-log-port* "Server run thread started")
				     (http-transport:run 
				      (if (args:get-arg "-server")
					  (args:get-arg "-server")
					  "-")

	       " ms</td></tr>"
	       "<tr><td>Number non-cached queries</td> <td>"  *number-non-write-queries* "</td></tr>"
	       "<tr><td>Average non-cached time</td>   <td>" (if (eq? *number-non-write-queries* 0)
								 "n/a (no queries)"
								 (/ *total-non-write-delay* 
								    *number-non-write-queries*))
	       " ms</td></tr>"
	       "<tr><td>Last access</td><td>"              (seconds->time-string *last-db-access*) "</td></tr>"
	       "</table>")))
    (mutex-unlock! *heartbeat-mutex*)
    res))

(define (http-transport:runs linkpath)
  (conc "<h3>Runs</h3>"
	(string-intersperse

	       )))))
  ;; then, if runscript ran ok (or did not get called)
  ;; do all the ezsteps (if any)
  (if ezsteps
      (let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here?
	      ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic
	      ;;       ezstep names need a full re-eval here.
	      (tests:get-testconfig test-name tconfigreg #t force-create: #t)) ;; 'return-procs)))
	     (ezstepslst (if (hash-table? testconfig)
			     (hash-table-ref/default testconfig "ezsteps" '())
			     #f)))
	(if testconfig
	    (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ...
	    (begin
	      (launch:setup)

	      (set! *runconfigdat* rdat)
	      (set! *toppath*      toppath)
	      (set! *configstatus* 'partial))
	    (begin
	      (debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.")
	      (exit 2))))))
    ;; additional house keeping
    (common:set-transport-type)
    (let* ((linktree (or (getenv "MT_LINKTREE")
			 (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f))))
      (if linktree
	  (begin
	    (if (not (file-exists? linktree))
		(begin
		  (handle-exceptions

       (list "MT_TEST_NAME" test-name)
       (list "MT_RUNNAME"   runname)
       (list "MT_ITEMPATH"  item-path)
       )
      itemdat))
    (let* ((tregistry       (tests:get-all)) ;; third param (below) is system-allowed
           ;; for tconfig, why do we allow fallback to test-conf?
	   (tconfig         (or (tests:get-testconfig test-name tregistry #t force-create: #t)
				(begin
                                  (debug:print 0 *default-log-port* "WARNING: falling back to pre-calculated testconfig. This is likely not desired.")
                                  test-conf))) ;; force re-read now that all vars are set
	   (useshell        (let ((ush (config-lookup *configdat* "jobtools"     "useshell")))
			      (if ush 
				  (if (equal? ush "no") ;; must use "no" to NOT use shell
				      #f

;; 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 1.6302)

			"-q" ;; quiet 0, errors/warnings only
		       )
		 args:arg-hash
		 0))

;; Add args that use remargs here
;;

(if (and (not (null? remargs))
	 (not (or
	       (args:get-arg "-runstep")
	       (args:get-arg "-envcap")
	       (args:get-arg "-envdelta")
	       )
	      ))
    (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv))  " ")))

;; immediately set MT_TARGET if -reqtarg or -target are available
;;
(let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
  (if targ (setenv "MT_TARGET" targ)))

;; The watchdog is to keep an eye on things like db sync etc.
;;
(define *watchdog* (make-thread common:watchdog "Watchdog thread"))


(thread-start! *watchdog*)
(BB> "thread-start! watchdog")

(if (args:get-arg "-log")
    (let ((oup (open-output-file (args:get-arg "-log"))))
      (debug:print-info 0 *default-log-port* "Sending log output to " (args:get-arg "-log"))
      (set! *default-log-port* oup)))

(if (or (args:get-arg "-h")
	(args:get-arg "-help")

(if (args:get-arg "-server")

    ;; Server? Start up here.
    ;;
    (let ((tl        (launch:setup))
	;; (run-id    (and (args:get-arg "-run-id")
	;; 		  (string->number (args:get-arg "-run-id"))))
          (transport-type *transport-type*  ))


      (server:launch 0 transport-type)
      (set! *didsomething* #t)))
;;     ;; (debug:print-error 0 *default-log-port* "server requires run-id be specified with -run-id")))
;; 
;;     ;; Not a server? This section will decide how to communicate
;;     ;;
;;     ;;  Setup client for all expect listed here

;;======================================================================
;; Exit and clean up
;;======================================================================

(if (not *didsomething*)
    (debug:print 0 *default-log-port* help))
(BB> "thread-join! watchdog")






(thread-join! *watchdog*)

(set! *time-to-exit* #t)

(if (not (eq? *globalexitstatus* 0))
    (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall"))
        (begin
           (debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*)
           (exit 0))
        (case *globalexitstatus*
         ((0)(exit 0))
         ((1)(exit 1))
         ((2)(exit 2))
         (else (exit 3)))))

;;======================================================================
;; Copyright 2006-2013, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;======================================================================
;;
(use format typed-records) ;; RADT => purpose of json format??

(declare (unit rmt))
(declare (uses api))
(declare (uses tdb))
(declare (uses http-transport))
(declare (uses rpc-transport))
;;(declare (uses nmsg-transport))
(include "common_records.scm")

;;
;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
;;

     ;; if not on homehost ensure we have a connection to a live server
     ;; NOTE: we *have* a homehost record by now
     ((and (not (cdr (remote-hh-dat *runremote*)))        ;; are we on a homehost?
           (not (remote-conndat *runremote*)))            ;; and no connection
      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  6  hh-dat: " (remote-hh-dat *runremote*) " conndat: " (remote-conndat *runremote*))
      (mutex-unlock! *rmt-mutex*)
      (tasks:start-and-wait-for-server (tasks:open-db) 0 15)
      (let* ((cinfo (rmt:get-connection-info 0))
             (transport (if cinfo
                            (vector-ref cinfo 6)
                            (server:get-transport)))) ;; TODO: replace with tasks:server-dat-accessor-?? for transport
        (remote-conndat-set! *runremote* cinfo) ;; calls client:setup which calls client:setup-http
        (remote-transport-set! *runremote* transport))
      (rmt:send-receive cmd rid params attemptnum: attemptnum))
     ;; all set up if get this far, dispatch the query
     ((cdr (remote-hh-dat *runremote*)) ;; we are on homehost
      (mutex-unlock! *rmt-mutex*)
      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  7")
      (rmt:open-qry-close-locally cmd (if rid rid 0) params))
     ;; not on homehost, do server query
     (else
      (mutex-unlock! *rmt-mutex*)
      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  9")
      (let* ((conninfo (remote-conndat *runremote*))
	     (dat      (case (remote-transport *runremote*)
			 ((http) (condition-case ;; handling here has caused a lot of problems. However it is needed to deal with attemtped communication to servers that have gone away
                                  (http-transport:client-api-send-receive 0 conninfo cmd params)
                                  ((commfail)(vector #f "communications fail"))
                                  ((exn)(vector #f "other fail" (print-call-chain)))))
                         ((rpc) (condition-case ;; handling here has caused a lot of problems. However it is needed to deal with attemtped communication to servers that have gone away
                                  (rpc-transport:client-api-send-receive 0 conninfo cmd params)
                                  ((commfail)(vector #f "communications fail"))
                                  ((exn)(vector #f "other fail" (print-call-chain)))))
			 (else
			  (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " not supported (1)")
			  (exit))))
	     (success  (if (vector? dat) (vector-ref dat 0) #f))
	     (res      (if (vector? dat) (vector-ref dat 1) #f)))
	(if (vector? conninfo)(http-transport:server-dat-update-last-access conninfo)) ;; refresh access time
        (debug:print-info 12 *default-log-port* "rmt:send-receive, case  9. conninfo=" conninfo " dat=" dat)
	(if success
	    (case (remote-transport *runremote*)
	      ((http rpc) res)
	      (else
	       (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " is unknown")
	       (exit 1)))
	    (begin
	      (debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum)
	      (remote-conndat-set!    *runremote* #f)
	      (remote-server-url-set! *runremote* #f)

		(mutex-lock! *db-multi-sync-mutex*)
		(set! *db-last-access* start-time)  ;; THIS IS PROBABLY USELESS? (we are on a client)
                (mutex-unlock! *db-multi-sync-mutex*)))))
    res))

(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params)
  (let* ((run-id   (if run-id run-id 0))
         (transport (or (remote-transport *runremote*) (server:get-transport)))
	 (res  	   (handle-exceptions
		    exn
		    #f
                    (case transport
                      ((http) (http-transport:client-api-send-receive run-id connection-info cmd params))
                      ((rpc) (rpc-transport:client-api-send-receive run-id connection-info cmd params))
                      (else
			  (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " not supported (2)")
			  (exit))

                    ))))
    (if (and res (vector-ref res 0))
	(vector-ref res 1) ;;; YES!! THIS IS CORRECT!! CHANGE IT HERE, THEN CHANGE rmt:send-receive ALSO!!!
	#f)))

;; ;; Wrap json library for strings (why the ports crap in the first place?)
;; (define (rmt:dat->json-str dat)
;;   (with-output-to-string 

  (rmt:send-receive 'login run-id (list *toppath* megatest-version *my-client-signature*)))

;; This login does no retries under the hood - it acts a bit like a ping.
;; Deprecated for nmsg-transport.
;;
(define (rmt:login-no-auto-client-setup connection-info)
  (case *transport-type* ;; run-id of 0 is just a placeholder
    ((http rpc)(rmt:send-receive-no-auto-client-setup connection-info 'login 0 (list *toppath* megatest-version *my-client-signature*)))
    (else
     (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " not supported (3)")
     (exit))

    
    ;;((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list *toppath* megatest-version run-id *my-client-signature*)))
    ))

;; hand off a call to one of the db:queries statements
;; added run-id to make looking up the correct db possible 
;;
(define (rmt:general-call stmtname run-id . params)

;; Copyright 2006-2016, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

(declare (uses common))
(declare (uses db))
(declare (uses tests))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.

(include "common_records.scm")
(include "db_records.scm")

(define *heartbeat-mutex* (make-mutex))
(define *server-loop-heart-beat* (current-seconds))


;; procstr is the name of the procedure to be called as a string
(define (rpc-transport:autoremote procstr params)  ;; may be unused, I think api-exec deprecates this one.
  (let* ((procsym (if (symbol? procstr)
                     procstr
                     (string->symbol (->string procstr))))
        (res
         (begin
           (apply (eval procsym) params))))
    res))


;; rpc receiver
(define (rpc-transport:api-exec cmd params)
  (let* ( (resdat  (api:execute-requests *dbstruct-db* (vector cmd params))) ;; #( flag result )
          (flag    (vector-ref resdat 0))
          (res     (vector-ref resdat 1)))

    (mutex-lock! *heartbeat-mutex*)

    (set! *last-db-access* (current-seconds)) ;; bump *last-db-access*; this will renew keep-running thread's lease on life for another (server:get-timeout) seconds
    ;;(BB> "in api-exec; last-db-access updated to "*last-db-access*)
    (mutex-unlock! *heartbeat-mutex*)

    res))


;; retry an operation (depends on srfi-18)
;; ==================
;; idea here is to avoid spending time on coding retrying something.  Trying to be generic here.
;;
;; Exception handling:
;; -------------------
;; if evaluating the thunk results in exception, it will be retried.
;; on last try, if final-failure-returns-actual is true, the exception will be re-thrown to caller.
;;
;; look at options below #!key to see how to configure behavior
;;
;;
(define (retry-thunk
         the-thunk
         #!key ;;;; options below
         (accept-result?   (lambda (x) x)) ;; retry if predicate applied to thunk's result is false 
         (retries                       4) ;; how many tries
         (failure-value                #f) ;; return this on final failure, unless following option is enabled:
         (final-failure-returns-actual #f) ;; on failure, on the last try, just return the result, not failure-value

         (retry-delay                 0.1) ;; delay between tries
         (back-off-factor               1) ;; multiply retry-delay by this factor on retry
         (random-delay                0.1) ;; add a random portion of this value to wait

         (chatty                       #f) ;; print status as we go, for debugging.
         )
  
  (when chatty (print) (print "Entered retry-thunk") (print "-=-=-=-=-=-"))
  (let* ((guarded-thunk ;; we are guarding the thunk against exceptions.  We will record whether result of evaluation is an exception or a regular result.
          (lambda ()
           (let* ((EXCEPTION (gensym)) ;; using gensym to avoid potential collision
                  (res
                   (condition-case
                    (the-thunk) ;; this is what we are guarding the execution of
                    [x () (cons EXCEPTION x)]
                    )))
             (cond
              ((and (pair? res) (eq? (car res) EXCEPTION))
               (if chatty
                   (print " - the-thunk threw exception >"(cdr res)"<"))
               (cons 'exception (cdr res)))
               (else
                (if chatty
                    (print " - the-thunk returned result >"res"<"))
                (cons 'regular-result res)))))))
    
    (let loop ((guarded-res (guarded-thunk))
               (retries-left retries)
               (fail-wait retry-delay))
      (if chatty (print "   =========="))
      (let* ((wait-time (+ fail-wait (+ (* fail-wait back-off-factor)
                                        (* random-delay
                                           (/ (random 1024) 1024) ))))
             (res-type (car guarded-res))
             (res-value (cdr guarded-res)))
        (cond
         ((and (eq? res-type 'regular-result) (accept-result? res-value))
                   (if chatty (print " + return result that satisfied accept-result? >"res-value"<"))
                   res-value)

         ((> retries-left 0)
          (if chatty (print " - sleep "wait-time))
          (thread-sleep! wait-time)
          (if chatty (print " + retry ["retries-left" tries left]"))
          (loop (guarded-thunk)
                (sub1 retries-left)
                wait-time))
         
         ((eq? res-type 'regular-result)
          (if final-failure-returns-actual
              (begin
                (if chatty (print " + last try failed- return the result >"res-value"<"))
                res-value)
              (begin
                (if chatty (print " + last try failed- return canned failure value >"failure-value"<"))
              failure-value)))
         
         (else ;; no retries left; result was not accepted and res-type can only be 'exception
          (if final-failure-returns-actual 
              (begin
                (if chatty (print " + last try failed with exception- re-throw it >"res-value"<"))
                (abort res-value)); re-raise the exception. TODO: find a way for call-history to show as though from entry to this function
              (begin
                (if chatty (print " + last try failed with exception- return canned failure value >"failure-value"<"))
                failure-value))))))))


(define (rpc-transport:server-shutdown server-id rpc:listener ) ;;#!key (from-on-exit #f))
  ;;(on-exit (lambda () #t)) ;; turn off on-exit stuff
  ;;(tcp-close rpc:listener) ;; gotta exit nicely
  ;;(tasks:server-set-state! (db:delay-if-busy (tasks:open-db)) server-id "stopped")


  ;; TODO: (low) the following is extraordinaritly slow.  Maybe we don't even need portlogger for rpc anyway??  the exception-based failover when ports are taken is fast!
  ;;(portlogger:open-run-close portlogger:set-port (rpc:default-server-port) "released")
  
  (set! *time-to-exit* #t)
  ;;(if *dbstruct-db* (db:sync-touched *dbstruct-db* *run-id* force-sync: #t))
  
  (server:remove-dotserver-file *toppath* "anyhost:anyport" force: #t)
  (tasks:server-delete-record (db:delay-if-busy (tasks:open-db)) server-id " rpc-transport:keep-running complete")
  
  (rpc:close-all-connections!)
  ;;(BB> "Before (exit) (from-on-exit="from-on-exit")")
  ;;(unless from-on-exit (exit))  ;; sometimes we hang (around) here with 100% cpu.
  ;;(BB> "After")
  ;; strace reveals endless:
  ;; getrusage(RUSAGE_SELF, {ru_utime={413, 917868}, ru_stime={0, 60003}, ...}) = 0
  ;; getrusage(RUSAGE_SELF, {ru_utime={414, 9874}, ru_stime={0, 60003}, ...}) = 0
  ;; getrusage(RUSAGE_SELF, {ru_utime={414, 13874}, ru_stime={0, 60003}, ...}) = 0
  ;; getrusage(RUSAGE_SELF, {ru_utime={414, 105880}, ru_stime={0, 60003}, ...}) = 0
  ;; getrusage(RUSAGE_SELF, {ru_utime={414, 109880}, ru_stime={0, 60003}, ...}) = 0
  ;; getrusage(RUSAGE_SELF, {ru_utime={414, 201886}, ru_stime={0, 60003}, ...}) = 0
  ;; getrusage(RUSAGE_SELF, {ru_utime={414, 205886}, ru_stime={0, 60003}, ...}) = 0
  ;; getrusage(RUSAGE_SELF, {ru_utime={414, 297892}, ru_stime={0, 60003}, ...}) = 0
  ;; getrusage(RUSAGE_SELF, {ru_utime={414, 301892}, ru_stime={0, 60003}, ...}) = 0
  ;; getrusage(RUSAGE_SELF, {ru_utime={414, 393898}, ru_stime={0, 60003}, ...}) = 0
  ;; getrusage(RUSAGE_SELF, {ru_utime={414, 397898}, ru_stime={0, 60003}, ...}) = 0
  ;; make a post to chicken-users w/ http://paste.call-cc.org/paste?id=60a4b66a29ccf7d11359ea866db642c970735978


  ;; (if from-on-exit
  ;;     ;; avoid above condition!  End current process externally  since 1 in 20 (exit)'s result in hung, 100% cpu zombies. (see above)
  
  (system (conc  "kill -9  "(current-process-id)))
  )


;; all routes though here end in exit ...
;;
;; start_server? 
;;
(define (rpc-transport:launch run-id)


  (set! *run-id*   run-id)

  ;; ;; send to background if requested
  ;; (when (args:get-arg "-daemonize")
  ;;     (daemon:ize)
  ;;     (when *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it
  ;;       (current-error-port *alt-log-file*)
  ;;       (current-output-port *alt-log-file*)))

  ;; double check we dont alrady have a running server for this run-id
  (when (and (server:read-dotserver *toppath*)
             (server:check-if-running run-id))

    (debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running")
    (exit 0))

  ;; did not find server running, let's clean up the table of dead servers
  (tasks:server-force-clean-running-records-for-run-id  (db:delay-if-busy (tasks:open-db)) run-id "notresponding")  

  (server:dotserver-starting)

  


  
  ;; let's get a server-id for this server
  ;;   if at first we do not suceed, try 3 more times.
  (let ((server-id (retry-thunk
                    (lambda () (tasks:server-lock-slot (db:delay-if-busy (tasks:open-db)) run-id 'rpc))
                    chatty: #f
                    final-failure-returns-actual: #t
                    retries: 4)))
    (when (not server-id) ;; dang we couldn't get a server-id.
      ;; since we didn't get the server lock we are going to clean up and bail out


      (debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
      (tasks:server-delete-records-for-this-pid (db:delay-if-busy (tasks:open-db)) " rpc-transport:launch")
      (server:dotserver-starting-remove)
      (exit 1))

    ;; we got a server-id (and a corresponding entry in servers table in globally shared mdb)
    ;; all systems go.  Proceed to setup rpc server.  
    (rpc-transport:run
     (if (args:get-arg "-server")
         (args:get-arg "-server")
         "-")
     run-id
     server-id)
    (exit)))

(define *rpc-listener-port* #f)
(define *rpc-listener-port-bind-timestamp* #f)

(define *on-exit-flag #f)

(define (rpc-transport:server-dat-get-iface         vec)    (vector-ref  vec 0))
(define (rpc-transport:server-dat-get-port          vec)    (vector-ref  vec 1))
(define (rpc-transport:server-dat-get-last-access   vec)    (vector-ref  vec 5))
(define (rpc-transport:server-dat-get-transport     vec)    (vector-ref  vec 6))
(define (rpc-transport:server-dat-update-last-access vec)
  (if (vector? vec)
      (vector-set! vec 5 (current-seconds))
      (begin
	(print-call-chain (current-error-port))
	(debug:print-error 0 *default-log-port* "call to rpc-transport:server-dat-update-last-access with non-vector!!"))))


(define *api-exec-ht* (make-hash-table))
(define *api-exec-mutex* (make-mutex))
;; let's see if caching the rpc stub curbs thread-profusion on server side
(define (rpc-transport:get-api-exec iface port)
  (mutex-lock! *api-exec-mutex*)
  (let* ((lu (hash-table-ref/default *api-exec-ht* (cons iface  port) #f)))
    (if lu
        (begin
          (mutex-unlock! *api-exec-mutex*)
          lu)
        (let ((res (rpc:procedure 'api-exec iface port)))
          (hash-table-set! *api-exec-ht* (cons iface port) res)
          (mutex-unlock! *api-exec-mutex*)
          res))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; this client-side procedure makes rpc call to server and returns result
;;
(define (rpc-transport:client-api-send-receive run-id serverdat cmd params #!key (numretries 3))
  ;;(BB> "entered rpc-transport:client-api-send-receive with run-id="run-id " serverdat="serverdat" cmd="cmd" params="params" numretries="numretries)
  (if (not (vector? serverdat))
      (begin
        (BB> "WHAT?? for run-id="run-id", serverdat="serverdat)
        (print-call-chain)
        (rpc:close-all-connections!)
        (exit 1)))
  (let* ((iface (rpc-transport:server-dat-get-iface serverdat))
         (port  (rpc-transport:server-dat-get-port serverdat))
         (res #f)
         (api-exec (rpc-transport:get-api-exec iface port))  ;; chached by host/port. may need to clear...
         (send-receive (lambda ()
                         (tcp-buffer-size 0)
                         (set! res (retry-thunk
                                    (lambda ()
                                      (condition-case
                                       ;;(vector #t (run-remote cmd params))
                                       (vector 'success (api-exec cmd params))
                                       [x (exn i/o net) (vector 'comms-fail (conc "communications fail ["(->string x)"]") x)]
                                       [x () (vector 'other-fail "other fail ["(->string x)"]" x)]))
                                    chatty: #f
                                    accept-result?: (lambda(x)
                                                      (and (vector? x) (vector-ref x 0)))
                                    retries: 8
                                    back-off-factor: 1.5
                                    random-wait: 0.2
                                    retry-delay: 0.1
                                    final-failure-returns-actual: #t))
                         ;;(BB> "HEY res="res)
                         res
                         ))
         (th1 (make-thread send-receive "send-receive"))
         (time-out-reached #f)
         (time-out     (lambda ()
			      (thread-sleep! 45)
                              (set! time-out-reached #t)
                              (thread-terminate! th1)
                              
			      #f))

         (th2 (make-thread time-out     "time out")))
	 (thread-start! th1)
	 (thread-start! th2)
	 (thread-join! th1)
	 (thread-terminate! th2)
         ;;(BB> "alt got res="res)
	 (debug:print-info 11 *default-log-port* "got res=" res)
	 (if (vector? res)
             (case (vector-ref res 0)
               ((success) (vector #t (vector-ref res 1)))
               (
                (comms-fail other-fail)
                ;;(comms-fail) 
                (debug:print 0 *default-log-port* "WARNING: comms failure for rpc request >>"res"<<")
                ;;(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
                (vector #f (vector-ref res 1)))

               (else
                (debug:print-error 0 *default-log-port* "error occured at server, info=" (vector-ref res 1))
                (debug:print 0 *default-log-port* " client call chain:")
                (print-call-chain (current-error-port))
                (debug:print 0 *default-log-port* " server call chain:")
                (pp (vector-ref res 1) (current-error-port))
                (signal (vector-ref res 2))))
             (signal (make-composite-condition
                      (make-property-condition 
             	       'timeout
             	       'message "nmsg-transport:client-api-send-receive-raw timed out talking to server"))))))
        


(define (rpc-transport:run hostn run-id server-id)
  (debug:print 2 *default-log-port* "Attempting to start the rpc server ...")
   ;; (trace rpc:publish-procedure!)

  ;;======================================================================
  ;;	  start of publish-procedure section
  ;;======================================================================
  (rpc:publish-procedure! 'server:login server:login) ;; this allows client to validate it is the same megatest instance as the server.  No security here, just making sure we're in the right room.
  (rpc:publish-procedure!
   'testing
   (lambda ()
     "Just testing"))

  ;; procedure to receive arbitrary API request from client's rpc:send-receive/rpc-transport:client-api-send-receive 
  (rpc:publish-procedure! 'rpc-transport:autoremote rpc-transport:autoremote)
  ;; can use this to run most anything at the remote
  (rpc:publish-procedure! 'api-exec rpc-transport:api-exec)
  
  
  ;;======================================================================
  ;;	  end of publish-procedure section
  ;;======================================================================


  (let* ((db              #f)
	 (hostname        (let ((res (get-host-name)))  res))
         (server-start-time (current-seconds))
         (server-timeout (server:get-timeout))
	 (ipaddrstr       (let* ((ipstr (if (string=? "-" hostn)
					   ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
					   (server:get-best-guess-address hostname)
					   #f))
                                 (res (if ipstr ipstr hostn)))
                            res)) ;; hostname))) 
	 (start-port      (let ((res (portlogger:open-run-close portlogger:find-port)))      ;; BB> TODO: remove portlogger!
                            res))
	 (link-tree-path  (configf:lookup *configdat* "setup" "linktree"))

         ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
         ;; rpc:listener is the tcp-listen result from inside the find-free-port-and-open complex.
         ;;   It is our handle on the listening tcp port
         ;;   We will attach this to our rpc server with rpc:make-server in thread th1 .
	 (rpc:listener    (rpc-transport:find-free-port-and-open start-port)) 
	 (th1             (make-thread
			   (lambda ()
                             ;;(BB> "BEFORE rpc:make-server")
			     ((rpc:make-server rpc:listener) #t)
                             ;;(BB> "BEFORE rpc:make-server")
                             )
			   "rpc:server"))


         (hostname        (if (string=? "-" hostn)
			      (get-host-name) 
			      hostn))
	 (ipaddrstr       (if (string=? "-" hostn)
			      (server:get-best-guess-address hostname) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
                              (string-intersperse 
                               (map number->string
                                    (u8vector->list
                                      (hostname->ip hostn))) ".")
                              ))
	 (portnum         (let ((res (rpc:default-server-port)))  res))
	 (host:port       (conc (if ipaddrstr ipaddrstr hostname) ":" portnum)))

    (when (not (equal? ipaddrstr (server:get-best-guess-address (get-host-name))))
        
      (debug:print 0 *default-log-port* "Error: This host "(ip->string (hostname->ip (get-host-name)))" ("(get-host-name)") is not the homehost "ipaddrstr" ("(ip->hostname (string->ip ipaddrstr))"; Cannot proceed.")
      (server:dotserver-starting-remove)
      (tcp-close rpc:listener) ;; gotta exit nicely and free up that tcp port
      (exit))
    
    (tasks:server-set-interface-port (db:delay-if-busy (tasks:open-db)) server-id ipaddrstr portnum)

    ;;============================================================
    ;;  activate thread th1 to attach opened tcp port to rpc server
    ;;=============================================================
    (thread-start! th1)
    (set! db *dbstruct-db*)


    (debug:print 0 *default-log-port* "Server started on " host:port)
    ;;(BB> "before SELF-TEST")
    (if (retry-thunk (lambda ()
                       (rpc-transport:self-test run-id ipaddrstr portnum))
                     final-failure-returns-actual: #t ;; TODO: remove this line
                     )
        (debug:print 0 *default-log-port* "INFO: rpc self test passed!")
        (begin
          (debug:print 0 *default-log-port* "Error: rpc listener did not pass self test.  Shutting down.  On: " host:port)
          (tasks:server-set-state! (db:delay-if-busy (tasks:open-db)) server-id "dead")
          (tcp-close rpc:listener) ;; gotta exit nicely and free up that tcp port
          (rpc-transport:server-shutdown server-id rpc:listener)
          (server:dotserver-starting-remove)
          (exit)))




    ;;(on-exit (lambda ()
    ;;           (rpc-transport:server-shutdown server-id rpc:listener from-on-exit: #t)))
    
    ;; check again for running servers for this run-id in case one has snuck in since we checked last in rpc-transport:launch
    (if (not (equal? server-id (tasks:server-am-i-the-server? (db:delay-if-busy (tasks:open-db)) run-id)));; try to ensure no double registering of servers
        (begin ;; i am not the server, another server snuck in and beat this one to the punch
          (tcp-close rpc:listener) ;; gotta exit nicely and free up that tcp port
          (tasks:server-set-state! (db:delay-if-busy (tasks:open-db)) server-id "collision")
          (server:dotserver-starting-remove))

        (begin ;; i am the server
          ;; setup the in-memory db
          (set! *dbstruct-db*  (db:setup run-id))
          (db:get-db *dbstruct-db* run-id)

          ;; at this point, satisfied server has started
          ;; let's make it official
          (server:write-dotserver *toppath* (conc ipaddrstr ":" portnum))
          (mutex-lock! *heartbeat-mutex*)
          (set! *last-db-access* (current-seconds))
          (mutex-unlock! *heartbeat-mutex*)
          (set! *rpc:listener* rpc:listener) 
          (tasks:server-set-state! (db:delay-if-busy (tasks:open-db)) server-id "running") ;; update our mdb servers entry

          
          
          ;; this let loop will hold open this thread until we want the server to shut down.
          ;;   if no requests received within the last 20 seconds :
          ;;   database hasnt changed in ??

          ;;


          
          ;; keep-running loop: polls last-db-access to see if we have timed out.  keep running if not. 
          (let loop ((count          0)
                     (bad-sync-count 0))
            (BB> "keep running: count = "count)
            ;; Use this opportunity to sync the inmemdb to db

            (let ((start-time (current-milliseconds))
                  (sync-time  #f)
                  (rem-time   #f))

              ;; following is now done in common:watchdog, commenting out.  sync-time will now be 0; can live with that.
              ;; ;; inmemddb is a dbstruct
              ;; (condition-case
              ;;  (db:sync-touched *dbstruct-db* *run-id* force-sync: #t)
              ;;  ((sync-failed)(cond
              ;;                 ((> bad-sync-count 10) ;; time to give up
              ;;                  (rpc-transport:server-shutdown server-id rpc:listener))
              ;;                 (else ;; (> bad-sync-count 0)  ;; we've had a fail or two, delay and loop
              ;;                  (thread-sleep! 5)
              ;;                  (loop count (+ bad-sync-count 1)))))
              ;;  ((exn)
              ;;   (debug:print-error 0 *default-log-port* "error from sync code other than 'sync-failed. Attempting to gracefully shutdown the server ")
              ;;   (rpc-transport:server-shutdown server-id rpc:listener)))
              
              (set! sync-time  (- (current-milliseconds) start-time))
              (set! rem-time (quotient (- 4000 sync-time) 1000))
              (debug:print 4 *default-log-port* "SYNC: time= " sync-time ", rem-time=" rem-time)
              
              (if (and (<= rem-time 4)
                       (> rem-time 0))
                  (thread-sleep! rem-time)
                  (thread-sleep! 4))) ;; fallback for if the math is changed ...
            
            (if (< count 1) ;; 3x3 = 9 secs aprox
                (loop (+ count 1) bad-sync-count))

            ;; BB: don't see how this is possible with RPC
            ;; ;; Check that iface and port have not changed (can happen if server port collides)
            ;; (mutex-lock! *heartbeat-mutex*)
            ;; (set! sdat *server-info*)
            ;; (mutex-unlock! *heartbeat-mutex*)
            
            ;; (if (or (not (equal? sdat (list iface port)))
            ;;         (not server-id))
            ;;     (begin 
            ;;       (debug:print-info 0 *default-log-port* "interface changed, refreshing iface and port info")
            ;;       (set! iface (car sdat))
            ;;       (set! port  (cadr sdat))))
            
            ;; Transfer *last-db-access* to last-access to use in checking that we are still alive
            (mutex-lock! *heartbeat-mutex*)
            (set! last-access *last-db-access*)
            (mutex-unlock! *heartbeat-mutex*)
            
            ;; (debug:print 11 *default-log-port* "last-access=" last-access ", server-timeout=" server-timeout)
            ;;
            ;; no_traffic, no running tests, if server 0, no running servers
            ;;
            ;; (let ((wait-on-running (configf:lookup *configdat* "server" b"wait-on-running"))) ;; wait on running tasks (if not true then exit on time out)
            ;;
            (let* ((hrs-since-start  (/ (- (current-seconds) server-start-time) 3600))
                   (adjusted-timeout (if (> hrs-since-start 1)
                                         (- server-timeout (inexact->exact (round (* hrs-since-start 60))))  ;; subtract 60 seconds per hour
                                         server-timeout)))
              (if (common:low-noise-print 120 "server timeout")
                  (debug:print-info 0 *default-log-port* "Adjusted server timeout: " adjusted-timeout))
              (if (and *server-run*
                       (> (+ last-access server-timeout)
                          (current-seconds)))
                  (begin
                    (if (common:low-noise-print 120 "server continuing")
                        (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access)))
                    ;;
                    ;; Consider implementing some smarts here to re-insert the record or kill self is
                    ;; the db indicates so
                    ;;
                    (if (tasks:server-am-i-the-server? (db:delay-if-busy (tasks:open-db)) run-id)
                        (tasks:server-set-state! (db:delay-if-busy (tasks:open-db)) server-id "running"))
                    ;;
                    (loop 0 bad-sync-count))
                  (begin
                    ;;(BB> "SERVER SHUTDOWN CALLED!  last-access="last-access" current-seconds="(current-seconds)" server-timeout="server-timeout)
                    
                    (rpc-transport:server-shutdown server-id rpc:listener)))))
          ;; end new loop
          ))))


(define (rpc-transport:find-free-port-and-open port #!key )
  (handle-exceptions
   exn
   (begin
     (print "Failed to bind to port " (rpc:default-server-port) ", trying next port")
     (rpc-transport:find-free-port-and-open (add1 port)))
   (rpc:default-server-port port)
   (set! *rpc-listener-port* port) ;; a bit paranoid about rpc:default-server-port parameter not changing across threads (as params are wont to do).  keeping this global in my back pocket in case this causes problems
   (set! *rpc-listener-port-bind-timestamp* (current-milliseconds)) ;; may want to test how long it has been since the last bind attempt happened...
   (tcp-read-timeout 240000)
   (tcp-buffer-size 0) ;; gotta do this because http-transport undoes it.
   (tcp-listen (rpc:default-server-port) 10000)
   ))
  
(define (rpc-transport:ping run-id host port)
  (handle-exceptions
   exn
   (begin
     (print "SERVER_NOT_FOUND exn="exn)
     (exit 1))
   (let ((login-res ((rpc:procedure 'server:login host port) *toppath*)))

     (if login-res
	 (begin
	   (print "LOGIN_OK")
	   (exit 0))
	 (begin
	   (print "LOGIN_FAILED")
	   (exit 1))))))

(define (rpc-transport:self-test run-id host port)
  (if (not host)
      (abort "host not set."))



  (if (not port)

      (abort "port not set."))
  (tcp-buffer-size 0) ;; gotta do this because http-transport undoes it.
  (let* ((testing-res ((rpc:procedure 'testing host port)))
         (login-res ((rpc:procedure 'server:login host port) *toppath*))
         (res (and login-res (equal? testing-res "Just testing"))))
    


    (if login-res











        (begin
          ;;(BB> "Self test PASS.  login-res="login-res" testing-res="testing-res" *toppath*="*toppath*)

          #t)
        (begin
          (BB> "Self test fail.  login-res="login-res" testing-res="testing-res" *toppath*="*toppath*)
           
          #f))
    res))

(define (rpc-transport:client-setup run-id server-dat #!key (remaining-tries 10))
  ;;(BB> "entered rpc-transport:client-setup with run-id="run-id" and server-dat="server-dat" and retries="remaining-tries)

  (tcp-buffer-size 0)
  (debug:print-info 0 *default-log-port* "rpc-transport:client-setup run-id="run-id" server-dat=" server-dat ", remaining-tries=" remaining-tries)







  (let* ((iface     (tasks:hostinfo-get-interface server-dat))
         (hostname  (tasks:hostinfo-get-hostname  server-dat))
         (port      (tasks:hostinfo-get-port      server-dat))
         (runremote-server-dat (vector iface port #f #f #f (current-seconds) 'rpc)) ;; http version := (vector iface port api-uri api-url api-req (current-seconds) 'http  )



         (ping-res (retry-thunk (lambda ()  ;; make 3 attempts to ping.




                                  ((rpc:procedure 'server:login iface port) *toppath*))
                                chatty: #f
                                retries: 3)))
    ;; we got here from rmt:get-connection-info on the condition that *runremote* has no entry for run-id...
    (if ping-res
        (begin
          (debug:print-info 0 *default-log-port* "rpc-transport:client-setup CONNECTION ESTABLISHED run-id="run-id" server-dat=" server-dat)
          runremote-server-dat)
        (begin ;; login failed but have a server record, clean out the record and try again
          (debug:print-info 0 *default-log-port* "rpc-transport:client-setup UNABLE TO CONNECT run-id="run-id" server-dat=" server-dat)
          (tasks:kill-server-run-id run-id)
          (tasks:server-force-clean-run-record  (db:delay-if-busy (tasks:open-db)) run-id iface port
                                                   " rpc-transport:client-setup (server-dat = #t)")
          (if (> remaining-tries 2)
              (thread-sleep! (+ 1 (random 5))) ;; spread out the starts a little
              (thread-sleep! (+ 15 (random 20)))) ;; it isn't going well. give it plenty of time
          (server:try-running run-id)
          (thread-sleep! 5)   ;; give server a little time to start up
          (client:setup run-id remaining-tries: (sub1 remaining-tries))))))

;; Call this to start the actual server
;;

;; all routes though here end in exit ...
;;
;; start_server
;;
(define (server:launch run-id transport-type-raw)
  (let ((transport-type
         (cond
          ((string? transport-type-raw) (string->symbol transport-type-raw))


          (else transport-type-raw))))
         

    ;;(BB> "server:launch fired for run-id="run-id" transport-type="transport-type)




    (case transport-type
      ((http)(http-transport:launch run-id))
      ;;((nmsg)(nmsg-transport:launch run-id))
      ((rpc)  (rpc-transport:launch run-id))
      (else (debug:print-error 0 *default-log-port* "unknown server type " transport-type)))))


  
;;======================================================================
;; S E R V E R   U T I L I T I E S 
;;======================================================================

;; Get the transport
(define (server:get-transport)
  (if *transport-type*
      *transport-type*
      (let ((ttype (string->symbol
		    (or (args:get-arg "-transport")
			(configf:lookup *configdat* "server" "transport")
			*DEFAULT-TRANSPORT*))))
	(set! *transport-type* ttype)
	ttype)))
	    
;; Generate a unique signature for this server
(define (server:mk-signature)
  (message-digest-string (md5-primitive) 
			 (with-output-to-string

     result)))

;; Given a run id start a server process    ### NOTE ### > file 2>&1 
;; if the run-id is zero and the target-host is set 
;; try running on that host
;;   incidental: rotate logs in logs/ dir.
;;
(define  (server:run areapath) ;; areapath is ignored for now.
  (let* ((curr-host   (get-host-name))


	 (curr-ip     (server:get-best-guess-address curr-host))
	 (curr-pid    (current-process-id))
	 (homehost    (common:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" ))
	 (target-host (car homehost))
	 (testsuite   (common:get-testsuite-name))
	 (logfile     (conc *toppath* "/logs/server.log"))
	 (cmdln (conc (common:get-megatest-exe)
		      " -server " (or target-host "-") " -run-id " 0
                      (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
                          (conc " -daemonize -log " logfile)
                          "")
                      " -transport " (server:get-transport)
		      " -m testsuite:" testsuite)) ;; (conc " >> " logfile " 2>&1 &")))))
	 (log-rotate  (make-thread common:rotate-logs  "server run, rotate logs thread")))
    ;; we want the remote server to start in *toppath* so push there
    (push-directory *toppath*)






    (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...")
    (thread-start! log-rotate)

    ;; host.domain.tld match host?
    (if (and target-host 
	     ;; look at target host, is it host.domain.tld or ip address and does it 
	     ;; match current ip or hostname
	     (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host))
	     (not (equal? curr-ip target-host)))
	(begin
	  (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile)
	  (setenv "TARGETHOST" target-host)))
    
    (setenv "TARGETHOST_LOGF" logfile)
    (common:wait-for-normalized-load 4 " delaying server start due to load" remote-host: (get-environment-variable "TARGETHOST")) ;; do not try starting servers on an already overloaded machine, just wait forever
    (system (conc "nbfake " cmdln))
    (unsetenv "TARGETHOST_LOGF")
    (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
    (thread-join! log-rotate)
    (pop-directory)))

(define (server:get-client-signature) ;; BB> why is this proc named "get-"?  it returns nothing -- set! has not return value.
  (if *my-client-signature* *my-client-signature*
      (let ((sig (server:mk-signature)))
	(set! *my-client-signature* sig)
	*my-client-signature*)))

;; kind start up of servers, wait 40 seconds before allowing another server for a given
;; run-id to be launched
(define (server:kind-run areapath)
  (let ((last-run-time (hash-table-ref/default *server-kind-run* areapath #f)))
    (if (or (not last-run-time)
	    (> (- (current-seconds) last-run-time) 30))
	(begin
	  (server:run areapath)
	  (hash-table-set! *server-kind-run* areapath (current-seconds))))))

;; The generic run a server command. Dispatches the call to server 0 if run-id != 0
;; 
;;  (define (server:try-running run-id)




;;    (if (eq? run-id 0)
;;        (server:run run-id)
;;        (rmt:start-server run-id)))
(define server:try-running server:run) ;; there is no more per-run servers ;; REMOVE ME. BUG.

(define (server:start-attempted? areapath)
  (let ((flagfile (conc areapath "/.starting-server")))
    (handle-exceptions
     exn
     #f  ;; if things go wrong pretend we can't see the file

     (and (file-exists? flagfile)
	  (< (- (current-seconds)
		(file-modification-time flagfile))
	     15))))) ;; exists and less than 15 seconds old





    
(define (server:read-dotserver areapath)
  (let ((dotfile (conc areapath "/.server")))
    (handle-exceptions
     exn
     #f  ;; if things go wrong pretend we can't see the file
     (if (and (file-exists? dotfile)
	      (file-read-access? dotfile))
	 (with-input-from-file
	     dotfile
	   (lambda ()
	     (read-line)))
	 #f))))


(define (server:dotserver-starting)
  (with-output-to-file
      (conc *toppath* "/.starting-server")
    (lambda ()
      (print (current-process-id) " on " (get-host-name)))))

(define (server:dotserver-starting-remove)
  (delete-file* (conc *toppath* "/.starting-server")))
  

  
;; write a .server file in *toppath* with hostport
;; return #t on success, #f otherwise
;;
(define (server:write-dotserver areapath hostport)
  (let ((lock-file   (conc areapath "/.server.lock"))
	(server-file (conc areapath "/.server")))
    (if (common:simple-file-lock lock-file)
	(let ((res (handle-exceptions
		    exn
		    #f ;; failed for some reason, for the moment simply return #f
		    (with-output-to-file server-file
		      (lambda ()
			(print hostport)))
		    #t)))
	  (debug:print-info 0 *default-log-port* "server file " server-file " for " hostport " created")
	  (common:simple-file-release-lock lock-file)
	  res)
	#f)))

(define (server:remove-dotserver-file areapath hostport #!key (force #f))
  (let ((dotserver   (server:read-dotserver areapath))
	(server-file (conc areapath "/.server"))
	(lock-file   (conc areapath "/.server.lock")))
    (if (or force (and dotserver (string-match (conc ".*:" hostport "$") dotserver))) ;; port matches, good enough info to decide to remove the file
	(if (common:simple-file-lock lock-file)
	    (begin
	      (handle-exceptions
	       exn
	       #f
	       (delete-file* server-file))
	      (debug:print-info 0 *default-log-port* "server file " server-file " for " hostport " removed")
	      (common:simple-file-release-lock lock-file))))))

;; no longer care if multiple servers are started by accident. older servers will drop off in time.
;;
(define (server:check-if-running areapath)
  (let* ((dotserver (server:read-dotserver areapath))) ;; tdbdat (tasks:open-db)))
    (if dotserver
	(let* ((res (case *transport-type*
		      ((http rpc)(server:ping-server dotserver))
		      ;; ((nmsg)(nmsg-transport:ping (tasks:hostinfo-get-interface server)
		      )))
	  (if res
	      dotserver


	      #f))
	#f)))

;; called in megatest.scm, host-port is string hostname:port
;;
;; NOTE: This is NOT called directly from clients as not all transports support a client running
;;       in the same process as the server.
;;

	  (begin
	    (if host-port-in
		(debug:print 0 *default-log-port*  "ERROR: bad host:port"))
	    (if do-exit (exit 1))
	    #f)
	  (let* ((iface      (car host-port))
		 (port       (cadr host-port))
		 (server-dat
                  (case (remote-transport *runremote*)
                    ((http) (http-transport:client-connect iface port))
                    ((rpc) (rpc-transport:client-connect iface port))
                    (else
                     (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " not supported (4)")
                     (exit))))
		 (login-res  (rmt:login-no-auto-client-setup server-dat)))
	    (if (and (list? login-res)
		     (car login-res))
		(begin
		  (print "LOGIN_OK")
		  (if do-exit (exit 0)))
		(begin

;; Copyright 2006-2013, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

(use defstruct)
(use scsh-process)

(use refdb)


;; (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 srfi-19)

(use format)

;; (require-library ini-file)
;; (import (prefix ini-file ini:))

(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
;; (import (prefix sqlite3 sqlite3:))

;; (declare (uses db))
;; (declare (uses synchash))
;; (declare (uses server))
(declare (uses megatest-version))
;; (declare (uses tbd))

(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 *spublish:current-tab-number* 0)
(define *args-hash* (make-hash-table))
(define spublish:help (conc "Usage: spublish  [action [params ...]]

  ls       <area>              : list contents of target area
  cp|publish <area> <src file> <destination>      : copy file to target area
  mkdir <area> <dir name>       : maks directory in target area  
  rm <area> <file>              : remove file <file> from target area
  ln <area> <target> <link name> : creates a symlink

 
  options:

    -m \"message\"        : describe what was done
Note: All the target locations relative to base path 
Part of the Megatest tool suite.
Learn more at http://www.kiatoa.com/fossils/megatest

Version: " megatest-fossil-hash)) ;; "

;;======================================================================
;; RECORDS
;;======================================================================

;;======================================================================
;; DB
;;======================================================================

(define *default-log-port* (current-error-port))
(define *verbosity*         1)

(define (spublish:initialize-db db)
  (for-each
   (lambda (qry)
     (exec (sql db qry)))
   (list 
    "CREATE TABLE IF NOT EXISTS actions
         (id           INTEGER PRIMARY KEY,

     configdat
     (lambda (db)
       (spublish:register-action db "cp" submitter source-path comment)))
    (let* (;; (target-path (configf:lookup "settings" "target-path"))
	   (th1         (make-thread
			 (lambda ()
			   (file-copy source-path targ-path #t))
                            (print " ... file " targ-path " copied to " targ-path)
			 ;; (let ((pid (process-run "cp" (list source-path target-dir))))
			 ;;   (process-wait pid)))
			 "copy thread"))
	   (th2         (make-thread
			 (lambda ()
			   (let loop ()
			     (thread-sleep! 15)

      (let loop ((hed (car paths))
		 (tal (cdr paths)))
	(if (file-exists? (conc hed "/" name))
	    hed
	    (if (null? tal)
		#f
		(loop (car tal)(cdr tal)))))))
;;========================================================================
;;Shell 
;;========================================================================
(define (spublish:get-accessable-projects  area)
   (let* ((projects `()))
     ;  (print "in spublish:get-accessable-projects") 
        ;(print (spublish:has-permission area))
        (if (spublish:has-permission area)
               (set! projects (cons area projects))
               (begin
                 (print "User cannot access area " area "!!")  
                (exit 1))) 
       ;  (print "exiting spublish:get-accessable-projects")
    projects))

;; function to find sheets to which use has access 
(define (spublish:has-permission  area)
  ;(print "in spublish:has-permission")
  (let* ((username     (current-user-name))
        (ret-val #f))
  (cond
   ((equal? (is-admin username) #t)
     (set! ret-val #t))
    ((equal? (is-user "publish" username area) #t)
     (set! ret-val #t))
   ((equal? (is-user "writer-admin" username area) #t) 
     (set! ret-val #t))

   ((equal? (is-user "area-admin" username area) #t) 
     (set! ret-val #t))
   (else  
    (set! ret-val #f)))
  ;  (print ret-val)
     ret-val))

(define (is_directory target-path) 
  (let* ((retval #f))
  (sauthorize:do-as-calling-user
    	(lambda ()
          ;(print (current-effective-user-id) ) 
          (if (directory? target-path)
               (set! retval  #t))))
             ;(print (current-effective-user-id))
     retval)) 


(define (spublish:shell-cp src-path target-path)  
  (cond
   ((not (file-exists? target-path))
	(print "ERROR: target Directory " target-path " does not exist!!"))
   ((not (file-exists? src-path))
    (print "Error: Source path " src-path " does not exist!!" ))
   (else
     (if (is_directory src-path) 
        (begin
            (let* ((parent-dir src-path)
                   (start-dir target-path))
                 ;(print "parent-dir " parent-dir " start-dir " start-dir)   
                 (run (pipe
                   (begin (system (conc "cd " parent-dir " ;tar chf - ." )))
                   (begin (change-directory start-dir)
                          ;(print "123")
                          (run-cmd "tar" (list "xf" "-")))))
                          (print "Copied data to " start-dir))) 
        (begin
           (let*((parent-dir (pathname-directory src-path))
                  (start-dir target-path)
                (filename (if  (pathname-extension src-path)  
                                      (conc(pathname-file src-path) "." (pathname-extension src-path))
                                      (pathname-file src-path))))
                ;(print "parent-dir " parent-dir " start-dir " start-dir)   
                 (run (pipe
                   (begin (system (conc "cd " parent-dir ";tar chf - " filename )))
                   (begin (change-directory start-dir)
                          (run-cmd "tar" (list "xf" "-")))))
                          (print "Copied data to " start-dir)))))))


(define (spublish:shell-mkdir targ-path)
    (if (file-exists? targ-path)
	(begin
	  (print "ERROR: target Directory " targ-path " already exist!!"))
        (let* ((th1         (make-thread
			 (lambda ()
			   (create-directory targ-path #t)
			   (print " ... dir " targ-path " created"))
			 "mkdir thread"))
	   (th2         (make-thread
			 (lambda ()
			   (let loop ()
			     (thread-sleep! 15)
			     (display ".")
			     (flush-output)
			     (loop)))
			 "action is happening thread")))
      (thread-start! th1)
      (thread-start! th2)
      (thread-join! th1)
    (cons #t "Successfully saved data"))))
 

(define (spublish:shell-rm targ-path)
    (if (not (file-exists? targ-path))
	(begin
	  (print "ERROR: target path " targ-path " does not exist!!"))
        (let* ((th1         (make-thread
			 (lambda ()
			   (delete-file  targ-path )
			   (print " ... path " targ-path " deleted"))
			 "rm thread"))
	   (th2         (make-thread
			 (lambda ()
			   (let loop ()
			     (thread-sleep! 15)
			     (display ".")
			     (flush-output)
			     (loop)))
			 "action is happening thread")))
      (thread-start! th1)
      (thread-start! th2)
      (thread-join! th1)
    (cons #t "Successfully saved data"))))

(define (spublish:shell-ln src-path target-path sub-path)
   (if (not (file-exists? sub-path))
	 (print "ERROR: Path " sub-path " does not exist!! cannot proceed with link creation!!")
        (begin  
          (if (not (file-exists? src-path))
  	    (print "ERROR: Path " src-path " does not exist!! cannot proceed with link creation!!")
            (begin
                (if (file-exists? target-path)
                   (print "ERROR: Path " target-path "already exist!! cannot proceed with link creation!!")
                   (begin 
                      (create-symbolic-link src-path target-path  )
			   (print " ... link " target-path " created"))))))))
 
(define (spublish:shell-help)
(conc "Usage: [action [params ...]]

  ls    [target path]               	  : list contents of target area.
  cd    <target path> 	     	          : To change the current directory within the sretrive shell. 
  pwd				     	  : Prints the full pathname of the current directory within the sretrive shell.
  mkdir <path>                            : creates directory. Note it does not create's a path recursive manner.
  rm <target path>                        : removes files and emoty directories   
  cp <src> <target path>                  : copy a file/dir to target path. if src is a dir it automatically makes a recursive copy.
  ln TARGET LINK_NAME                     : creates a symlink      
Part of the Megatest tool suite.
Learn more at http://www.kiatoa.com/fossils/megatest

Version: " megatest-fossil-hash)
)	

(define (toplevel-command . args) #f)

(define (spublish:shell area)
 ; (print area)
  (use readline)
  (let* ((path      '())
	 (prompt    "spublish> ")
	 (args      (argv))
         (usr (current-user-name) )   
         (top-areas (spublish:get-accessable-projects area))
         (close-port     #f)
         (area-obj  (get-obj-by-code area))
         (user-obj (get-user usr)) 
         (base-path (if (null? area-obj) 
                         "" 
                        (caddr (cdr area-obj))))      
	 (iport     (make-readline-port prompt)))
        ;(print base-path) 
        (if (null? area-obj)
          (begin 
             (print "Area " area " does not exist")
          (exit 1)))
        ; (print "here")    
	(let loop ((inl (read-line iport)))
	  (if (not (or (or (eof-object? inl)
		       (equal? inl "exit")) (port-closed? iport)))
	      (let* ((parts (string-split inl))
		     (cmd   (if (null? parts) #f (car parts))))
		(if (and (not cmd) (not (port-closed? iport)))
		    (loop (read-line))
		    (case (string->symbol cmd)
		      ((cd)
		       (if (> (length parts) 1) ;; have a parameter
                           (begin
                             (let*((arg (cadr parts))
                                   (resolved-path (sauth-common:resolve-path  arg path top-areas))
                                   (target-path (sauth-common:get-target-path path  arg top-areas base-path)))
                                 (if (not (equal? target-path #f))
                                 (if (or (equal? resolved-path #f) (not (file-exists? target-path)))    
                                 (print "Invalid argument " arg ".. ")
                                  (begin      
			            (set! path resolved-path)
                                     (sauthorize:do-as-calling-user
                              (lambda ()
			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "cd"))))
                                  )))))  
   			   (set! path '())))
                      ((pwd)
                         (if (null? path)
                           (print "/")  
                           (print "/" (string-join path "/")))) 
		      ((ls)
		       (let* ((thepath (if (> (length parts) 1) ;; have a parameter
					   (cdr parts)
					   `()))
			      (plen    (length thepath)))
                         (cond
			  ((null? thepath)
                           (sauth-common:shell-ls-cmd path "" top-areas base-path  '())
                            (sauthorize:do-as-calling-user
                              (lambda ()
			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "ls"))))   )
			  ((< plen 2)
                            (sauth-common:shell-ls-cmd path  (car thepath) top-areas base-path '())
                              (sauthorize:do-as-calling-user
                              (lambda ()
			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "ls")))))
                          (else 
                            (if (equal? (car thepath) "|")
                              (sauth-common:shell-ls-cmd path "" top-areas base-path thepath)
                              (sauth-common:shell-ls-cmd path  (car thepath) top-areas base-path (cdr thepath)))
                           (sauthorize:do-as-calling-user
                              (lambda ()
			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "ls"))))))))
                       ((mkdir)
                         (let* ((thepath (if (> (length parts) 1) ;; have a parameter
				   (cdr parts)
				   `()))
			      (plen    (length thepath)))
                         (cond
                          ((null? thepath)
                            (print "mkdir takes one argument"))
                          ((< plen 2) 
                            (let*((mk-path (cadr parts))
                                  (resolved-path (sauth-common:resolve-path  mk-path path top-areas))
                                  (target-path (sauth-common:get-target-path path  mk-path top-areas base-path)))
                              (if (not (equal? target-path #f))
                                 (if (equal? resolved-path #f)     
                                 (print "Invalid argument " mk-path ".. ")
                                  (begin 
                                      (spublish:shell-mkdir target-path)   
                                      (sauthorize:do-as-calling-user
                              (lambda ()
			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "mkdir")))))))
		       )))))
                       ((rm)
                          (let* ((thepath (if (> (length parts) 1) ;; have a parameter
				   (cdr parts)
				   `()))
			      (plen    (length thepath)))
                         (cond
                          ((null? thepath)
                            (print "rm takes one argument"))
                          ((< plen 2) 
                            (let*((rm-path (cadr parts))
                                  (resolved-path (sauth-common:resolve-path  rm-path path top-areas))
                                  (target-path (sauth-common:get-target-path path  rm-path top-areas base-path)))
                              (if (not (equal? target-path #f))
                                 (if (equal? resolved-path #f)     
                                 (print "Invalid argument " rm-path ".. ")
                                  (begin 
                                      (spublish:shell-rm target-path)   
                                      (sauthorize:do-as-calling-user
                              (lambda ()
			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "rm")))))))
		       )))))

                      ((cp publish)
                          (let* ((thepath (if (> (length parts) 1) ;; have a parameter
				   (cdr parts)
				   `()))
			      (plen    (length thepath)))
                         (cond
                          ((or (null? thepath) (< plen 2)) 
                            (print "cp takes two argument"))
                          ((< plen 3) 
                            (let*((src-path (car thepath))
                                  (dest-path (cadr thepath))   
                                  (resolved-path (sauth-common:resolve-path  dest-path path top-areas))
                                  (target-path (sauth-common:get-target-path path  dest-path top-areas base-path)))
                              (if (not (equal? target-path #f))
                                 (if (equal? resolved-path #f)     
                                 (print "Invalid argument " dest-path ".. ")
                                  (begin 
                                      (spublish:shell-cp src-path target-path)   
                                      (sauthorize:do-as-calling-user
                              (lambda ()
			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "cp")))))))
		       )))))
                      ((ln)
                           (let* ((thepath (if (> (length parts) 1) ;; have a parameter
				   (cdr parts)
				   `()))
			      (plen    (length thepath)))
                         (cond
                          ((or (null? thepath) (< plen 2)) 
                            (print "ln takes two argument"))
                          ((< plen 3) 
                            (let*((src-path (car thepath))
                                  (dest-path (cadr thepath))   
                                  (resolved-path (sauth-common:resolve-path  dest-path path top-areas))
                                  (target-path (sauth-common:get-target-path path  dest-path top-areas base-path))
                                  (sub-path (conc "/" (string-reverse (string-join (cdr (string-split (string-reverse  target-path) "/")) "/")))))
                              (if (not (equal? target-path #f))
                                 (if (equal? resolved-path #f)     
                                 (print "Invalid argument " dest-path ".. ")
                                  (begin 
                                      (spublish:shell-ln src-path target-path sub-path)   
                                      (sauthorize:do-as-calling-user
                              (lambda ()
			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "ln")))))))
		       )))))  
                      ((exit)
                          (print "got exit"))  
                      ((help)
                          (print (spublish:shell-help)))
		      (else 
		       (print "Got command: " inl))))
                 (loop (read-line iport)))))))


;;======================================================================
;; MAIN
;;======================================================================

(define (spublish:load-config exe-dir exe-name)
  (let* ((fname   (conc exe-dir "/." exe-name ".config")))
    ;; (ini:property-separator-patt " *  *")
    ;; (ini:property-separator #\space)
    (if (file-exists? fname)
	;; (ini:read-ini fname)
	(read-config fname #f #t)
	(make-hash-table))))

(define (spublish:process-action action . args)
  ;(print args)
  (let* ((usr          (current-user-name))
         (user-obj (get-user usr)) 
         (area   (car args))
         (area-obj  (get-obj-by-code area))
         (top-areas (spublish:get-accessable-projects area))  
         (base-path (if (null? area-obj) 
                         "" 
                        (caddr (cdr area-obj))))   



         (remargs (cdr args)))
     (if (null? area-obj)
          (begin 




             (print "Area " area " does not exist")
          (exit 1)))
    (case (string->symbol action)
      ((cp publish)
       (if (< (length remargs) 2)
	   (begin 
	     (print "ERROR: Missing arguments; spublish <area> <src file> <destination>" )
	     (exit 1)))
       (let* ((filter-args     (args:get-args args '("-m") '() args:arg-hash 0))

              (src-path-in (car filter-args))
              (dest-path (cadr filter-args))
	      (src-path    (with-input-from-pipe
			    (conc "readlink -f " src-path-in)
			    (lambda ()
			      (read-line))))
	      (msg         (or (args:get-arg "-m") ""))
              (resolved-path (sauth-common:resolve-path  (conc area "/" dest-path) `() top-areas))
              (target-path (sauth-common:get-target-path `()  (conc area "/" dest-path) top-areas base-path)))
 	     (if (not (equal? target-path #f))

                 (if (equal? resolved-path #f)     

                    (print "Invalid argument " dest-path ".. ")
                    (begin 



                      (spublish:shell-cp src-path target-path)   
                      (sauthorize:do-as-calling-user

                      (lambda ()








		        (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" cp " src-path-in " " dest-path  "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "cp")))))))))   
      ((mkdir)
        (if (< (length remargs) 1)
          (begin 
	     (print "ERROR: Missing arguments; <area> <path>")
	     (exit 1)))
        (let* ((filter-args     (args:get-args args '("-m") '() args:arg-hash 0))
               (mk-path (car filter-args))
               (msg         (or (args:get-arg "-m") ""))
               (resolved-path (sauth-common:resolve-path  mk-path (list area) top-areas))
               (target-path (sauth-common:get-target-path (list area)  mk-path top-areas base-path))) 
               (print "attempting to create directory " mk-path  )
               (if (not (equal? target-path #f))
                 (if (equal? resolved-path #f)     
                   (print "Invalid argument " mk-path ".. ")
                   (begin 
                     (spublish:shell-mkdir target-path)   
                     (sauthorize:do-as-calling-user
                       (lambda ()
		        (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" mkdir " mk-path  "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "mkdir")))))))))  
      ((ln) 
        (if (< (length remargs) 2)
          (begin 
	     (print "ERROR: Missing arguments;  <area> <target> <link name>" )
	     (exit 1)))













        (let* ((filter-args     (args:get-args args '("-m") '() args:arg-hash 0))

              (src-path (car filter-args))
              (dest-path (cadr filter-args))   
              (resolved-path (sauth-common:resolve-path  dest-path (list area) top-areas))
              (target-path (sauth-common:get-target-path  (list area)  dest-path top-areas base-path))
              (sub-path (conc "/" (string-reverse (string-join (cdr (string-split (string-reverse  target-path) "/")) "/")))))
               (if (not (equal? target-path #f))
                  (if (equal? resolved-path #f)     
                    (print "Invalid argument " dest-path ".. ")
                    (begin 





                   (spublish:shell-ln src-path target-path sub-path)   
                  (sauthorize:do-as-calling-user
                 (lambda ()
		   (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" ln " src-path " " dest-path  "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "ln")))))))))
      ((rm)
       (if (< (length remargs) 1)
	   (begin 
	     (print "ERROR: Missing arguments; <area> <path> ")









	     (exit 1)))

       (let* ((filter-args  (args:get-args args '("-m") '() args:arg-hash 0))
              (rm-path (car filter-args))
              (resolved-path (sauth-common:resolve-path  rm-path (list area) top-areas))
              (target-path (sauth-common:get-target-path (list area)  rm-path top-areas base-path)))

	       (if (not (equal? target-path #f))
                                 (if (equal? resolved-path #f)     
                                 (print "Invalid argument " rm-path ".. ")
                                  (begin 
                                      (spublish:shell-rm target-path)   

                                      (sauthorize:do-as-calling-user





                              (lambda ()
			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" rm " rm-path "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "rm")))))))))
      ((shell)
          (if (< (length args) 1)
             (begin 
	     (print  "ERROR: Missing arguments area!!" )


	     (exit 1))




             (spublish:shell area))) 
      (else (print "Unrecognised command " action)))))
  
;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION!
;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.spublishrc")))
;;   (if (file-exists? debugcontrolf)
;;       (load debugcontrolf)))

(define (main)
  (let* ((args      (argv))
	 (prog      (car args))
	 (rema      (cdr args))
	 (exe-name  (pathname-file (car (argv)))))



    (cond
     ;; one-word commands
     ((eq? (length rema) 1)
      (case (string->symbol (car rema))
	((help -h -help --h --help)
	 (print spublish:help))













	(else
	 (print "ERROR: Unrecognised command. Try \"spublish help\""))))
     ;; multi-word commands
     ((null? rema)(print spublish:help))
     ((>= (length rema) 2)
      (apply spublish:process-action (car rema)(cdr rema)))
     (else (print "ERROR: Unrecognised command2. Try \"spublish help\"")))))

(main)

;; Copyright 2006-2013, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

(use defstruct)
(use scsh-process)

(use srfi-18)



(use srfi-19)



;;(use utils)


;;(use format)
(use refdb)
;; (require-library ini-file)
;; (import (prefix ini-file ini:))

(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
;; (import (prefix sqlite3 sqlite3:))
;; 
(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")

(define (toplevel-command . args) #f)
(use readline)


;;
;; GLOBALS
;;
(define *verbosity* 1)
(define *logging* #f)
(define *exe-name* (pathname-file (car (argv))))
(define *sretrieve:current-tab-number* 0)
(define *args-hash* (make-hash-table))
(define sretrieve:help (conc "Usage: " *exe-name* " [action [params ...]]

  ls   <area>                        : list contents of target area
  get  <area>  <reletive path>       : retrieve path to the data within <area>
     -m \"message\"       : why retrieved?


  shell  <area>                   : start a shell-like interface

Part of the Megatest tool suite.
Learn more at http://www.kiatoa.com/fossils/megatest

Version: " megatest-fossil-hash)) ;; "

;;======================================================================

          bundle       TEXT NOT NULL,
          release      TEXT NOT NULL,
          status       TEXT NOT NULL,
          event_date   TEXT NOT NULL);"
    )))

(define (sretrieve:register-action db action submitter source-path comment)
 ; (print "(sretrieve:register-action db " db " action " action " submitter " submitter " source-path " source-path " comment " comment)
  (exec (sql db "INSERT INTO actions (action,retriever,srcpath,comment)
                 VALUES(?,?,?,?)")
	action
	submitter
	source-path
	(or comment "")))

;; (call-with-database
;;  (lambda (db)
;;   (set-busy-handler! db (busy-timeout 10000)) ; 10 second timeout
;;   ...))

;; Create the sqlite db
(define (sretrieve:db-do configdat proc) 

  (let ((path (configf:lookup configdat "database" "location")))
    (if (not path)
	(begin
	  (debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!")
	  (exit 1)))
    (if (and path
	     (directory? path)
	     (file-read-access? path))
	(let* ((dbpath    (conc path "/" *exe-name* ".db"))
	       (writeable (file-write-access? dbpath))
	       (dbexists  (file-exists? dbpath)))
	  (handle-exceptions
	   exn
	   (begin
	     (debug:print 2 "ERROR: problem accessing db " dbpath
			  ((condition-property-accessor 'exn 'message) exn))
	     (exit 1))
            ;;(debug:print 0 "calling proc " proc "db path " dbpath )
	   (call-with-database
            dbpath
	    (lambda (db)
	       ;;(debug:print 0 "calling proc " proc " on db " db)
	      (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
	      (if (not dbexists)(sretrieve:initialize-db db))
	      (proc db)))))
	(debug:print 0 "ERROR: invalid path for storing database: " path))))

;; copy in directory to dest, validation is done BEFORE calling this
;;
(define (sretrieve:get configdat retriever version comment)
  (let* ((base-dir  (configf:lookup configdat "settings" "base-dir"))
	 (datadir   (conc base-dir "/" version)))
    (if (or (not base-dir)
	    (not (file-exists? base-dir)))
	(begin
	  (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found")
	  (exit 1)))
    (print datadir)
    (if (not (file-exists? datadir))
	(begin
	  (debug:print 0 "ERROR: Bad version (" version "), no data found at " datadir "." )
	  (exit 1)))
    
    (sretrieve:db-do
     configdat
     (lambda (db)
       (sretrieve:register-action db "get" retriever datadir comment)))
      (sretrieve:do-as-calling-user

	     (process-execute "/bin/tar" (append (append (list  "chfv" "-") files) (list "--ignore-failed-read")))))
             (begin
               (let* ((parent-dir (pathname-directory datadir) )
                      (filename  (conc(pathname-file datadir) "." (pathname-extension datadir))))
                  (change-directory parent-dir)  
                  (process-execute "/bin/tar" (list "chfv" "-" filename))
             )))
))))



;; copy in file to dest, validation is done BEFORE calling this
;;
(define (sretrieve:cp configdat retriever file comment)
  (let* ((base-dir  (configf:lookup configdat "settings" "base-dir"))
         (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths"))    
	 (datadir   (conc base-dir "/" file))
         (filename  (conc(pathname-file datadir) "." (pathname-extension datadir))))
    (if (or (not base-dir)
	    (not (file-exists? base-dir)))
	(begin
	  (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found")
	  (exit 1)))
    (print datadir)
    (if (not (file-exists? datadir))
	(begin
	  (debug:print 0 "ERROR: File  (" file "), not found at " base-dir "." )
	  (exit 1)))
    (if (directory? datadir)
	(begin
	  (debug:print 0 "ERROR: (" file ") is a dirctory!! cp cmd works only on files ." )
	  (exit 1)))
    (if(not (string-match (regexp  allowed-sub-paths) file))
        (begin
	  (debug:print 0 "ERROR: Access denied to file (" file ")!! " )
	  (exit 1)))
     
     (sretrieve:db-do
     configdat
     (lambda (db)
       (sretrieve:register-action db "cp" retriever datadir comment)))
      (sretrieve:do-as-calling-user
      ;;  (debug:print 0 "ph:  "(pathname-directory datadir)  "!! " )
       (change-directory (pathname-directory datadir))  
       ;;(debug:print 0 "ph: /bin/tar" (list "chfv" "-" filename) )
      (process-execute "/bin/tar" (list "chfv" "-" filename)))
      ))

;; ls in file to dest, validation is done BEFORE calling this
;;
(define (sretrieve:ls configdat retriever file comment)
  (let* ((base-dir  (configf:lookup configdat "settings" "base-dir"))
         (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths"))    
	 (datadir   (conc base-dir "/" file))
         (filename  (conc(pathname-file datadir) "." (pathname-extension datadir))))
    (if (or (not base-dir)
	    (not (file-exists? base-dir)))
	(begin
	  (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found")
	  (exit 1)))
    (print datadir)
    (if (not (file-exists? datadir))
	(begin
	  (debug:print 0 "ERROR: File  (" file "), not found at " base-dir "." )
	  (exit 1)))
      (if(not (string-match (regexp  allowed-sub-paths) file))
        (begin
	  (debug:print 0 "ERROR: Access denied to file (" file ")!! " )
	  (exit 1)))
   
        (sretrieve:do-as-calling-user
        (lambda ()




	  (process-execute "/bin/ls" (list "-ls"  "-lrt" datadir ))
 ))))







(define (sretrieve:validate target-dir targ-mk)
  (let* ((normal-path (normalize-pathname targ-mk))
        (targ-path (conc target-dir "/" normal-path)))
    (if (string-contains   normal-path "..")
    (begin
      (debug:print 0 "ERROR: Path  " targ-mk " resolved outside target area "  target-dir )
      (exit 1)))

    (if (not (string-contains targ-path target-dir))
    (begin
      (debug:print 0 "ERROR: You cannot update data outside " target-dir ".")
      (exit 1)))
    (debug:print 0 "Path " targ-mk " is valid.")   
 ))


































































































(define (sretrieve:backup-move path)
  (let* ((trashdir  (conc (pathname-directory path) "/.trash"))
	 (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path))))
    (create-directory trashdir #t)
    (if (directory? path)
	(system (conc "mv " path " " trashfile))

;;======================================================================

(define (sretrieve:do-as-calling-user proc)
  (let ((eid (current-effective-user-id))
        (cid (current-user-id)))
    (if (not (eq? eid cid)) ;; running suid
            (set! (current-effective-user-id) cid))
    ;; (debug:print 0 "running as " (current-effective-user-id))
    (proc)
    (if (not (eq? eid cid))
        (set! (current-effective-user-id) eid))))

(define (sretrieve:find name paths)
  (if (null? paths)
      #f

    (lambda ()
      (apply print args))))

;;======================================================================
;; SHELL
;;======================================================================


(define *refdb*     "/p/foundry/env/pkgs/chicken/4.10.0_ext/bin/refdb") 
(define *refdbloc*     "/nfs/site/disks/ch_ciaf_disk023/fdk_gwa_disk003/pjhatwal/fossil/megatest1.60/megatest/datashare-testing/sretrieve_configs") 

;; Create the sqlite db for shell
(define (sretrieve:shell-db-do path proc) 
    (if (not path)
	(begin
	  (debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!")
	  (exit 1)))
    (if (and path
	     (directory? path)
	     (file-read-access? path))
	(let* ((dbpath    (conc path "/" *exe-name* ".db"))
	       (writeable (file-write-access? dbpath))
	       (dbexists  (file-exists? dbpath)))
	  (handle-exceptions
	   exn
	   (begin
	     (debug:print 2 "ERROR: problem accessing db " dbpath
			  ((condition-property-accessor 'exn 'message) exn))
	     (exit 1))
            ;;(debug:print 0 "calling proc " proc "db path " dbpath )
	   (call-with-database
            dbpath
	    (lambda (db)
	       ;;(debug:print 0 "calling proc " proc " on db " db)
	      (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
	      (if (not dbexists)(sretrieve:initialize-db db))
	      (proc db)))))
	(debug:print 0 "ERROR: invalid path for storing database: " path)))



;; function to find sheets to which use has access 
(define (sretrieve:has-permission  area)
  (let ((username     (current-user-name)))
  (cond
   ((is-admin username)
     #t)
   ((is-user "retrieve" username area) 
     #t)
    ((is-user "publish" username area) 
     #t)
   ((is-user "writer-admin" username area) 
     #t)
   ((is-user "read-admin" username area) 
     #t)
   ((is-user "area-admin" username area) 
     #t)
   (else  
    #f))))
 
    



(define (sretrieve:get-accessable-projects  area)
   (let* ((projects `()))
         
        (if (sretrieve:has-permission area)
               (set! projects (cons area projects))
               (begin
                 (print "User cannot access area " area "!!")  
                (exit 1))) 
   ; (print projects)
    projects))
		 
(define (sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list)
    (if (and (null? base-path-list) (equal? ext-path "") )
      (print (string-intersperse top-areas " "))
  (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas )))
           ;(print resolved-path)
           (if (not (equal? resolved-path #f))
           (if (null? resolved-path) 
             (print (string-intersperse top-areas " "))
           (let* ((target-path (sauth-common:get-target-path  base-path-list  ext-path top-areas base-path)))
                ;(print "Resolved path: " target-path)
                (if (symbolic-link? target-path)
                   (set! target-path (conc target-path "/"))) 
                (if (not (equal? target-path #f))
                (begin 
                (cond
		  ((null? tail-cmd-list)
		     (run (pipe
      	      	      (ls "-lrt" ,target-path))))
		  ((not (equal? (car tail-cmd-list) "|"))
                         (print "ls cmd cannot accept "(string-join tail-cmd-list) " as an argument!!"))
                  (else  
                    (run (pipe
      	      	      (ls "-lrt" ,target-path)
                      (begin (system (string-join (cdr tail-cmd-list))))))
      ))))))))))

(define (sretrieve:shell-cat-cmd base-pathlist ext-path top-areas base-path tail-cmd-list)
  (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas ))
          (data "") )
         (if (not (equal? resolved-path #f))
           (if (null? resolved-path) 
             (print "Path could not be resolved!!")
           (let* ((target-path (sauth-common:get-target-path  base-pathlist  ext-path top-areas base-path)))
             (if (not (equal? target-path #f))
               (if (or (not (file-exists? target-path)) (directory? target-path))
               (print "Target path does not exist or is a directory!") 
               (begin 
                 (cond
		  ((null? tail-cmd-list)
		     (run (pipe
      	      	      (cat  ,target-path))))
		  ((not (equal? (car tail-cmd-list) "|"))
                         (print "cat cmd cannot accept "(string-join tail-cmd-list) " as an argument!!"))
                  (else  
                    (run (pipe
      	      	      (cat ,target-path)
                      (begin (system (string-join (cdr tail-cmd-list))))))))))
)))
             (print "Path could not be resolved!!"))))

(define (get-options cmd-list split-str)
    (if (null? cmd-list)
              (list '() '())
    (let loop ((hed (car cmd-list))
		 (tal (cdr cmd-list))
                  (res '()))
                   (cond
                   ((equal? hed split-str)
                      (list res tal))
                   ((null? tal)
                      (list (cons hed res) tal)) 
                   (else 
		  	(loop (car tal)(cdr tal)(cons hed res)))))))

  
(define (sretrieve:shell-grep-cmd base-pathlist ext-path top-areas base-path tail-cmd-list)
  (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas ))
          (pattern (car tail-cmd-list))
          (pipe-cmd-list (get-options (cdr tail-cmd-list) "|"))
          (options (string-join (car pipe-cmd-list)))
          (pipe-cmd (cadr  pipe-cmd-list))
          (redirect-split (string-split (string-join  tail-cmd-list) ">"))   )
         (if(and ( > (length redirect-split) 2 ))
            (print "sgrep  cmd cannot accept > " (string-join redirect-split) " as an argument!!" )  
         (if (not (equal? resolved-path #f))
           (if (null? resolved-path) 
             (print "Path could not be resolved!!")
           (let* ((target-path (sauth-common:get-target-path  base-pathlist  ext-path top-areas base-path))
                  (restrictions (if (equal? target-path #f)
                                                 ""
                                               (sretrieve:shell-lookup base-path)))
                 (rest-str  (string-split (conc " --exclude-dir=" (string-join (string-split restrictions ",") " --exclude-dir=") ))))
             (if (not (file-exists? target-path))
               (print "Target path does not exist!") 
               (begin 
                 (cond
	 	  ((and (null? pipe-cmd) (string-null? options))
	 	     (run (pipe
      	      	      (grep ,pattern ,target-path ))))
		  ((and (null? pipe-cmd) (not (string-null? options)))
		     (run (pipe
      	      	      (begin (process-execute "/usr/bin/grep" (append (list options pattern target-path) rest-str))))))
                  ((and (not (null? pipe-cmd)) (string-null? options))
                        (run (pipe
      	      	      (grep ,exclude-dir ,pattern ,target-path)
                      (begin (system (string-join pipe-cmd))))))
                  (else   
                      (run (pipe
      	      	      ;(grep  ,options ,exclude-dir ,pattern ,target-path)
                       (begin (process-execute "/usr/bin/grep" (append (list options pattern target-path) rest-str)))

                      (begin (system (string-join  pipe-cmd)))))))
))))
             (print "Path could not be resolved!!")))))


(define (sretrieve:shell-less-cmd base-pathlist ext-path top-areas base-path)
  (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas )))
         (if (not (equal? resolved-path #f))
           (if (null? resolved-path) 
             (print "Path could not be resolved!!")
           (let* ((target-path (sauth-common:get-target-path  base-pathlist  ext-path top-areas base-path)))
               (if (not (equal? target-path #f))
           	 (if (or (not (file-exists? target-path)) (directory? target-path))
                   (print "Target path does not exist or is a directory!") 
                   (begin 
                     ;(sretrieve:shell-db-do
         	     ;     db-location
     		     ;	  (lambda (db)
       		;		(sretrieve:register-action db "less" (current-user-name) target-path (conc "Executing cmd: less "  target-path))))   
 
                     (setenv "LESSSECURE" "1")
                     (run (pipe
      	      	     (less ,target-path))))))))
             (print "Path could not be resolved!!"))))



(define (sretrieve:shell-lookup base-path)
  (let* ((usr (current-user-name))
          (value (get-restrictions base-path usr)))
                              value))
             

(define (sretrieve:load-shell-config fname)
          (if (file-exists? fname)
	(read-config fname #f #f)
	))


(define (is_directory target-path) 
  (let* ((retval #f))
  (sretrieve:do-as-calling-user
    	(lambda ()
          ;(print (current-effective-user-id) ) 
          (if (directory? target-path)
               (set! retval  #t))))
             ;(print (current-effective-user-id))
     retval)) 

(define (make-exclude-pattern  restriction-list  )
  (if (null? restriction-list)
     ""
   (let loop ((hed (car restriction-list))
		 (tal (cdr restriction-list))
                  (ret-str ""))
                   (cond
                   ((null? tal)
                      (conc ret-str ".+" hed ".*")) 
                   (else 
		  	(loop (car tal)(cdr tal)(conc ret-str ".+" hed ".*|"))))))    )

(define (sretrieve:get-shell-cmd target-path base-path restrictions iport)
     (if (not (file-exists? target-path))
        (print "Target path does not exist!")
    (begin
    (if (not (equal? target-path #f))
    (begin     
        (if (is_directory target-path) 
        (begin
           (let* ((tmpfile (conc "/tmp/" (current-user-name) "/my-pipe"))
                  (parent-dir target-path)
                  (last-dir-name (if  (pathname-extension target-path)  
                                      (conc(pathname-file target-path) "." (pathname-extension target-path))
                                      (pathname-file target-path)))
                  (curr-dir (current-directory))   
                  (start-dir (conc (current-directory) "/" last-dir-name))
                  (execlude (make-exclude-pattern (string-split restrictions ","))))
                  ; (print tmpfile)
                    (if  (file-exists? start-dir)
                    (begin
                         (print last-dir-name " already exist in your work dir. Do you want to over write it? [y|n]")
                        (let* ((inl (read-line iport)))
                            (if (equal? inl "y")
                              (begin
                                 (change-directory parent-dir)
                                  (create-fifo  tmpfile)
                                  (process-fork 
    				   (lambda()
                                       (sleep 1) 
       					(with-output-to-file tmpfile
         				(lambda ()
            				(sretrieve:make_file parent-dir execlude parent-dir)))))
 
                                  (run (pipe
                   		   (tar "chfv" "-" "-T" ,tmpfile )
                   		   (begin (system (conc "cd " start-dir ";tar  xUf - "   )))))
                                   (change-directory curr-dir)
                                    (system (conc "rm " tmpfile)) )
			      (begin	
                               (print  "Nothing has been retrieved!!  ")))))
                     (begin
                       (sretrieve:do-as-calling-user
                    (lambda ()
		      (create-directory start-dir #t)))
                          (change-directory parent-dir)
                          ; (print execlude)
                           (create-fifo tmpfile)
                            (process-fork 
    				   (lambda()
                                       (sleep 1) 
       					(with-output-to-file tmpfile
         				(lambda ()
            				(sretrieve:make_file parent-dir execlude parent-dir)))))

                                  (run (pipe
                   		   (tar "chfv" "-"  "-T" ,tmpfile)
                   		   (begin (system (conc "cd " start-dir ";tar  xUf - "    )))))
                           (change-directory curr-dir)
                            (system (conc "rm " tmpfile)))))) 
        (begin
           (let*((parent-dir (pathname-directory target-path))
                 (start-dir (current-directory))
                 (filename (if  (pathname-extension target-path)  
                                      (conc(pathname-file target-path) "." (pathname-extension target-path))
                                      (pathname-file target-path)))
                 (work-dir-file (conc (current-directory) "/" filename)))
                 (if  (file-exists? work-dir-file)
                    (begin
                       (print filename " already exist in your work dir. Do you want to over write it? [y|n]")
                        (let* ((inl (read-line iport)))
                            (if (equal? inl "y")
                              (begin
                                 (change-directory parent-dir)
                                  (run (pipe
                   		   (tar "chfv" "-" ,filename)
                   		   (begin (system (conc "cd " start-dir ";tar  xUf - "   )))))
                                     (change-directory start-dir))
			      (begin	
                               (print  "Nothing has been retrieved!!  ")))))
                    (begin
               (change-directory parent-dir)  
                 (run (pipe
                   (tar "chfv" "-" ,filename)
                   (begin (system (conc "cd " start-dir ";tar xUf -")))))
                    (change-directory start-dir)))))))))))

(define (sretrieve:get-shell-cmd-line target-path base-path restrictions iport)
     (if (not (file-exists? target-path))
        (print "Target path does not exist!")
    (begin
    (if (not (equal? target-path #f))
    (begin     
        (if (is_directory target-path) 
        (begin
           (let* ((parent-dir target-path)
                  (last-dir-name (if  (pathname-extension target-path)  
                                      (conc(pathname-file target-path) "." (pathname-extension target-path))
                                      (pathname-file target-path)))
                  (curr-dir (current-directory))   
                  (start-dir (conc (current-directory) "/" last-dir-name))
                  (execlude (make-exclude-pattern (string-split restrictions ",")))
                   (tmpfile (conc "/tmp/" (current-user-name) "/my-pipe-" (current-process-id))))
                    (if  (file-exists? start-dir)
                    (begin
                         (print last-dir-name " already exist in your work dir.")
                         (print  "Nothing has been retrieved!!  "))
                     (begin
                   ;    (sretrieve:do-as-calling-user
                   ; (lambda ()
		      ;(create-directory start-dir #t)))
                          (change-directory parent-dir)
                            (create-fifo  tmpfile)
                                  (process-fork 
    				   (lambda()
                                       (sleep 1) 
       					(with-output-to-file tmpfile
         				(lambda ()
            				(sretrieve:make_file parent-dir execlude parent-dir)))))

                           (process-execute "/bin/tar" (append (list  "chfv" "-"  "-T" tmpfile)  (list "--ignore-failed-read")))    
                                  ;(run (pipe
                   		   ;(tar "chfv" "-" "." )
                   		   ;(begin (system (conc "cd " start-dir ";tar  xUf - "   execlude )))))
                            (system (conc "rm " tmpfile))    
                           (change-directory curr-dir))))) 
        (begin
           (let*((parent-dir (pathname-directory target-path))
                 (start-dir (current-directory))
                 (filename (if  (pathname-extension target-path)  
                                      (conc(pathname-file target-path) "." (pathname-extension target-path))
                                      (pathname-file target-path)))
                 (work-dir-file (conc (current-directory) "/" filename)))
                 (if  (file-exists? work-dir-file)
                    (begin
                       (print filename " already exist in your work dir.")
                               (print  "Nothing has been retrieved!!  "))
                    (begin
               (change-directory parent-dir)
                (process-execute "/bin/tar" (append (append (list  "chfv" "-") (list filename)) (list "--ignore-failed-read"))) 
                 ;(run (pipe
                  ; (tar "chfv" "-" ,filename)
                  ; (begin (system (conc "cd " start-dir ";tar xUf -")))))
                    (change-directory start-dir)))))))))))

(define (sretrieve:make_file path exclude base_path)
   (find-files 
     path
     action: (lambda (p res)
           (cond
                ((symbolic-link? p)   
                 (if (directory?(read-symbolic-link p)) 
                      (sretrieve:make_file p exclude base_path)
                      (print (string-substitute (conc base_path "/") "" p "-"))))
                 ((directory? p)              
                 ;;do nothing for dirs)
                 ) 
                (else 
                                        
                     (if (not (string-match (regexp exclude)  p ))
                        (print (string-substitute (conc base_path "/") "" p "-"))))))))

(define (sretrieve:shell-help)
(conc "Usage: " *exe-name* " [action [params ...]]

  ls    [target path]               	  : list contents of target area. The output of the cmd can be piped into other system cmd. eg ls <path> | grep txt
  cd    <target directory>	     	  : To change the current directory within the sretrive shell. 
  pwd				     	  : Prints the full pathname of the current directory within the sretrive shell.
  get   <file or directory path>     	  : download directory/files into the directory where sretrieve shell cmd was invoked   
  less  <file path>		     	  : Read input file to allows backward movement in the file as well as forward movement 
  cat   <file path>                  	  : show the contents of a file. The output of the cmd can be piped into other system cmd.

  sgrep <search path> <pattern> [options] : Similar to unix grep cmd But with diffrent parameter ordering. The output of the cmd can be piped into other system cmd. 
Part of the Megatest tool suite.
Learn more at http://www.kiatoa.com/fossils/megatest

Version: " megatest-fossil-hash)
)	
;(define (toplevel-command . args) #f)
(define (sretrieve:shell area)
 ; (print area)
  (use readline)
  (let* ((path      '())
	 (prompt    "sretrieve> ")
	 (args      (argv))
         (usr (current-user-name) )   
         (top-areas (sretrieve:get-accessable-projects area))
         (close-port     #f)
         (area-obj  (get-obj-by-code area))
         (user-obj (get-user usr)) 
         (base-path (if (null? area-obj) 
                         "" 
                        (caddr (cdr area-obj))))      
	 (iport     (make-readline-port prompt)))
        (if (null? area-obj)

          (begin 
             (print "Area " area " does not exist")
          (exit 1)))
	(let loop ((inl (read-line iport)))
          ;(print 1) 
	  (if (not (or (or (eof-object? inl)
		       (equal? inl "exit")) (port-closed? iport)))
	      (let* ((parts (string-split inl))
		     (cmd   (if (null? parts) #f (car parts))))
              ;  (print "2")
		(if (and (not cmd) (not (port-closed? iport)))
		    (loop (read-line))
		    (case (string->symbol cmd)
		      ((cd)
		       (if (> (length parts) 1) ;; have a parameter
                           (begin
                             (let*((arg (cadr parts))
                                   (resolved-path (sauth-common:resolve-path  arg path top-areas))
                                   (target-path (sauth-common:get-target-path path  arg top-areas base-path)))
                                 (if (not (equal? target-path #f))
                                 (if (or (equal? resolved-path #f) (not (file-exists? target-path)))    
                                 (print "Invalid argument " arg ".. ")
                                  (begin      
			            (set! path resolved-path)
                                     (sauthorize:do-as-calling-user
                              (lambda ()
			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "cd"))))
                                  )))))  
   			   (set! path '())))
                      ((pwd)
                         (if (null? path)
                           (print "/")  
                           (print "/" (string-join path "/")))) 
		      ((ls)
		       (let* ((thepath (if (> (length parts) 1) ;; have a parameter
					   (cdr parts)
					   `()))
			      (plen    (length thepath)))
                         (cond
			  ((null? thepath)
                           (sauth-common:shell-ls-cmd path "" top-areas base-path  '())
                            (sauthorize:do-as-calling-user
                              (lambda ()
			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "ls"))))   )
			  ((< plen 2)
                  
                            (sauth-common:shell-ls-cmd path  (car thepath) top-areas base-path '())
                              (sauthorize:do-as-calling-user
                              (lambda ()
			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "ls")))))
                          (else 
                            (if (equal? (car thepath) "|")
                              (sauth-common:shell-ls-cmd path "" top-areas base-path thepath)
                              (sauth-common:shell-ls-cmd path  (car thepath) top-areas base-path (cdr thepath)))
                           (sauthorize:do-as-calling-user
                              (lambda ()
			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "ls"))))))))
                       ((cat)
		       (let* ((thepath (if (> (length parts) 1) ;; have a parameter
					   (cdr parts)
					   `()))
			      (plen    (length thepath)))
			 (cond
			  ((null? thepath)
                          (print "Error: Missing argument to cat"))
			  ((< plen 2)
                            (sretrieve:shell-cat-cmd path  (car thepath) top-areas base-path '())
                              (sauthorize:do-as-calling-user
                              (lambda ()
			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "cat")))))

			  (else
                             (sretrieve:shell-cat-cmd path  (car thepath) top-areas base-path (cdr thepath))
                             (sauthorize:do-as-calling-user
                              (lambda ()
			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "cat"))))
))))
                       ((sgrep)
		       (let* ((thepath (if (> (length parts) 1) ;; have a parameter
					   (cdr parts)
					   `()))
			      (plen    (length thepath)))
			 (cond
			  ((null? thepath) 
                            (print "Error: Missing arguments to grep!! Useage: grep <search path> <pattern> [options] "))
                          ((< plen  2)
                          (print "Error: Missing arguments to grep!! Useage: grep <search path> <pattern> [options] "))
			  (else
                             (sretrieve:shell-grep-cmd path  (car thepath) top-areas base-path  (cdr thepath))
				(sauthorize:do-as-calling-user
                              (lambda ()
			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "grep"))))))))

                      ((less)
		       (let* ((thepath (if (> (length parts) 1) ;; have a parameter
					   (cdr parts)
					   `()))
			      (plen    (length thepath)))
			 (cond
			  ((null? thepath)
                          (print "Error: Missing argument to less"))
			  ((< plen 2)
                            (sretrieve:shell-less-cmd path  (car thepath) top-areas base-path)
                             (sauthorize:do-as-calling-user
                              (lambda ()
			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "less")))))
			  (else
                             (print "less cmd takes only one (<file path>) argument!!")))))
                      ((get)
                         (let* ((thepath (if (> (length parts) 1) ;; have a parameter
					   (cdr parts)
					   `()))
			      (plen    (length thepath)))
			 (cond
			  ((null? thepath)
                          (print "Error: Missing argument <path> to get"))
			  ((< plen 2)
                           (let* ((target-path (sauth-common:get-target-path path  (car thepath) top-areas base-path))
				 (restrictions (if (equal? target-path #f)
                                                 ""
                                               (sretrieve:shell-lookup base-path))))
                               (if (not (equal? target-path #f))
                             (begin  
                                 (sretrieve:get-shell-cmd target-path base-path restrictions iport)
                                  (sauthorize:do-as-calling-user
                              (lambda ()
			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "get"))))))))
			  (else
                            (print "Error: get cmd takes only one argument ")))))
                      ((exit)
                          (print "got exit"))  
                      ((help)
                          (print (sretrieve:shell-help)))

		      (else 
		       (print "Got command: " inl))))
                 (loop (read-line iport)))))))
;;))
    

;;======================================================================
;; MAIN
;;======================================================================
;;(define *default-log-port* (current-error-port))

(define (sretrieve:load-config exe-dir exe-name)
  (let* ((fname   (conc exe-dir "/." exe-name ".config")))
    ;; (ini:property-separator-patt " *  *")
    ;; (ini:property-separator #\space)
    (if (file-exists? fname)
	;; (ini:read-ini fname)
	(read-config fname #f #f)
	(make-hash-table))))

;; package-type is "megatest", "builds", "kits" etc.
;;

(define (sretrieve:load-packages configdat exe-dir package-type)
  (push-directory exe-dir)
  (let* ((packages-metadir  (configf:lookup configdat "settings" "packages-metadir"))
	 (conversion-script (configf:lookup configdat "settings" "conversion-script"))
	 (upstream-file     (configf:lookup configdat "settings" "upstream-file"))
	 (package-config    (conc packages-metadir "/" package-type ".config")))



       (if (file-exists? upstream-file)
	(if (or (not (file-exists? package-config)) ;; if not created call the updater, otherwise call only if upstream newer
		(> (file-modification-time upstream-file)(file-modification-time package-config)))
	    (handle-exceptions
	     exn
	     (debug:print 0 "ERROR: failed to run script " conversion-script " with params " upstream-file " " package-config)
	     (let ((pid (process-run conversion-script (list upstream-file package-config))))
	       (process-wait pid)))
	    (debug:print 0 "Skipping update of " package-config " from " upstream-file))
	(debug:print 0 "Skipping update of " package-config " as " upstream-file " not found"))


       (let ((res (if (file-exists? package-config)
		   (begin
		     (debug:print 0 "Reading package config " package-config)
		     (read-config package-config #f #t))
		   (make-hash-table))))
      (pop-directory)
      res)))

;(define (toplevel-command . args) #f)
(define (sretrieve:process-action configdat action . args)







 ;  (use readline)












    (case (string->symbol action)
      ((get)
       (if (< (length args) 2)
	   (begin 
	     (print  "ERROR: Missing arguments; <area> <relative path>" )
	     (exit 1)))
       (let* ((remargs     (args:get-args args '("-m" ) '() args:arg-hash 0))
              (iport (make-readline-port ">"))
              (area     (car args))
              (usr (current-user-name))
              (area-obj  (get-obj-by-code area))
              (user-obj (get-user usr))
              (top-areas (sretrieve:get-accessable-projects area)) 
              (base-path (if (null? area-obj) 
                                      "" 
                                     (caddr (cdr area-obj))))
	      (sub-path       (if (null? remargs) 
                                       "" 
                                       (car remargs))))

          (if (null? area-obj)
          	    (begin 
             		(print "Area " area " does not exist")
          	         (exit 1)))
              (let* ((target-path (sauth-common:get-target-path '()  (conc area "/" sub-path) top-areas base-path))
				 (restrictions (if (equal? target-path #f)
                                                 ""

                                               (sretrieve:shell-lookup base-path))))
             (if (not (equal? target-path #f))
                 (begin  
                   (sauthorize:do-as-calling-user
                      (lambda ()
   		        (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "get " area " " sub-path) (number->string (car user-obj))  (number->string (caddr area-obj))  "get"))))

                        (sretrieve:get-shell-cmd-line target-path base-path restrictions  iport))))))
         ((cp)
             (if (< (length args) 2)
	   (begin 
	     (print  "ERROR: Missing arguments; <area> <relative path>" )
	     (exit 1)))
       (let* ((remargs     (args:get-args args '("-m" ) '() args:arg-hash 0))
              (iport (make-readline-port ">"))
              (area     (car args))
              (usr (current-user-name))
              (area-obj  (get-obj-by-code area))
              (user-obj (get-user usr))
              (top-areas (sretrieve:get-accessable-projects area)) 
              (base-path (if (null? area-obj) 
                                      "" 
                                     (caddr (cdr area-obj))))
	      (sub-path       (if (null? remargs) 
                                       "" 
                                       (car remargs))))
         ;  (print args)
          (if (null? area-obj)
          	    (begin 
             		(print "Area " area " does not exist")
          	         (exit 1)))
              (let* ((target-path (sauth-common:get-target-path '()  (conc area "/" sub-path) top-areas base-path))
				 (restrictions (if (equal? target-path #f)
                                                 ""
                                              (sretrieve:shell-lookup base-path))))
                          ;(print target-path) 
                          (if (not (equal? target-path #f))
                             (begin  
                              (sauthorize:do-as-calling-user
                              (lambda ()
			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "get " area " " sub-path) (number->string (car user-obj))  (number->string (caddr area-obj))  "get"))))
                            (sretrieve:get-shell-cmd-line target-path base-path restrictions  iport))))))
      ((ls)
          (cond
            ((< (length args) 1)
              (begin 
	      (print  "ERROR: Missing arguments; <area> ")
	      (exit 1)))
              ((equal? (length args) 1)
                 (let*  ((area     (car args))
                         (usr (current-user-name))
                         (area-obj  (get-obj-by-code area))
                         (user-obj (get-user usr))
                         (top-areas (sretrieve:get-accessable-projects area)) 
                         (base-path (if (null? area-obj) 
                                      "" 
                                     (caddr (cdr area-obj)))))
                  (if (null? area-obj)
          	    (begin 
             		(print "Area " area " does not exist")
          	         (exit 1)))
           	 (sauth-common:shell-ls-cmd '() area top-areas base-path  '())
                 (sauthorize:do-as-calling-user
                   (lambda ()
		    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" "ls" (number->string (car user-obj)) (number->string (caddr area-obj)) "ls"))))))
             ((> (length args) 1)
               (let*  ((remargs     (args:get-args args '("-m" ) '() args:arg-hash 0))
                        (usr (current-user-name))
                        (user-obj (get-user usr))
                         (area     (car args)))
                         (let* ((area-obj  (get-obj-by-code area))
                               (top-areas (sretrieve:get-accessable-projects area)) 
                               (base-path (if (null? area-obj) 
                                      "" 
                                     (caddr (cdr area-obj))))
                                 
                               (sub-path (if (null? remargs) 
                                       area 
                                      (conc area "/" (car remargs)))))
                             ;(print "sub path "  sub-path)
                            (if (null? area-obj)
          	              (begin 
             		        (print "Area " area " does not exist")
          	                 (exit 1)))
                              (sauth-common:shell-ls-cmd `()  sub-path top-areas base-path '())
                            (sauthorize:do-as-calling-user
				(lambda ()
                       	       (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "ls " sub-path) (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))))))))

       ((shell)
          (if (< (length args) 1)
             (begin 
	     (print  "ERROR: Missing arguments <area>!!" )
	     (exit 1))

             (sretrieve:shell (car args)))) 
      (else (debug:print 0 "Unrecognised command " action))))


(define (main)
  (let* ((args      (argv))
	 (prog      (car args))
	 (rema      (cdr args))
	 (exe-name  (pathname-file (car (argv))))
	 (exe-dir   (or (pathname-directory prog)
			(sretrieve:find exe-name (string-split (get-environment-variable "PATH") ":"))))
	 (configdat (sretrieve:load-config exe-dir exe-name)))
    ;; preserve the exe data in the config file
    (hash-table-set! configdat "exe-info" (list (list "exe-name" exe-name)
						(list "exe-dir"  exe-dir)))
    (cond
     ;; one-word commands
     ((eq? (length rema) 1)
      (case (string->symbol (car rema))
	((help -h -help --h --help)
	 (print sretrieve:help))




















	(else
	 (print "ERROR: Unrecognised command. Try \"sretrieve help\""))))
     ;; multi-word commands
     ((null? rema)(print sretrieve:help))
     ((>= (length rema) 2)
      (apply sretrieve:process-action configdat (car rema)(cdr rema)))
     (else (debug:print 0 "ERROR: Unrecognised command. Try \"sretrieve help\"")))))

(main)


      

(define (tasks:hostinfo-get-interface   vec)    (vector-ref  vec 1))
(define (tasks:hostinfo-get-port        vec)    (vector-ref  vec 2))
(define (tasks:hostinfo-get-pubport     vec)    (vector-ref  vec 3))
(define (tasks:hostinfo-get-transport   vec)    (vector-ref  vec 4))
(define (tasks:hostinfo-get-pid         vec)    (vector-ref  vec 5))
(define (tasks:hostinfo-get-hostname    vec)    (vector-ref  vec 6))

(define (tasks:server-lock-slot mdb run-id transport-type)
  (tasks:server-clean-out-old-records-for-run-id mdb run-id " tasks:server-lock-slot")
  (if (< (tasks:num-in-available-state mdb run-id) 4)
      (begin 
	(tasks:server-set-available mdb run-id transport-type)
	(thread-sleep! (/ (random 1500) 1000)) ;; (thread-sleep! 2) ;; Try removing this. It may not be needed.
	(tasks:server-am-i-the-server? mdb run-id))
      #f))
	
;; register that this server may come online (first to register goes though with the process)
(define (tasks:server-set-available mdb run-id transport-type)
  (sqlite3:execute 
   mdb 
   "INSERT INTO servers (pid,hostname,port,pubport,start_time,      priority,state,mt_version,heartbeat,   interface,transport,run_id)
                   VALUES(?, ?,       ?,   ?, strftime('%s','now'), ?,       ?,    ?,-1,?,        ?,        ?);"
   (current-process-id)          ;; pid
   (get-host-name)               ;; hostname
   -1                            ;; port
   -1                            ;; pubport
   (random 1000)                 ;; priority (used a tiebreaker on get-available)
   "available"                   ;; state
   (common:version-signature)    ;; mt_version
   -1                            ;; interface
   ;; (conc (server:get-transport)) ;; transport
   (symbol->string transport-type)    ;; transport
   run-id
   ))

(define (tasks:num-in-available-state mdb run-id)
  (let ((res 0))
    (sqlite3:for-each-row
     (lambda (num-in-queue)

	     (delay-time 0))
      (if (and (not server-dat)
	       (< delay-time delay-max-tries))
	  (begin
	    (if (common:low-noise-print 60 "tasks:start-and-wait-for-server" run-id)
		(debug:print 0 *default-log-port* "Try starting server for run-id " run-id))
	    (thread-sleep! (/ (random 2000) 1000))
	    (server:kind-run run-id)
	    (thread-sleep! (min delay-time 1))
            (if (not (or (server:start-attempted? *toppath*)
                         (server:read-dotserver *toppath*))) ;; no point in trying
                (loop (tasks:get-server (db:delay-if-busy tdbdat) run-id)(+ delay-time 1))
                #f))
          #f)))

      (items:get-items-from-config tconfig))
     (else #f))))                           ;; not iterated


;; returns waitons waitors tconfigdat
;;
(define (tests:get-waitons test-name all-tests-registry)
   (let* ((config  (tests:get-testconfig test-name all-tests-registry 'return-procs)))
     (let ((instr (if config 
		      (config-lookup config "requirements" "waiton")
		      (begin ;; No config means this is a non-existant test
			(debug:print-error 0 *default-log-port* "non-existent required test \"" test-name "\"")
			(exit 1))))
	   (instr2 (if config
		       (config-lookup config "requirements" "waitor")

		    (loop (car tal)(cdr tal)(cons qry res)))))))
      #f))

;; Check for waiver eligibility
;;
(define (tests:check-waiver-eligibility testdat prev-testdat)
  (let* ((test-registry (make-hash-table))
	 (testconfig  (tests:get-testconfig (db:test-get-testname testdat) test-registry #f))
	 (test-rundir ;; (sdb:qry 'passstr 
	  (db:test-get-rundir testdat)) ;; )
	 (prev-rundir ;; (sdb:qry 'passstr 
	  (db:test-get-rundir prev-testdat)) ;; )
	 (waivers     (if testconfig (configf:section-vars testconfig "waivers") '()))
	 (waiver-rx   (regexp "^(\\S+)\\s+(.*)$"))
	 (diff-rule   "diff %file1% %file2%")

      #f))

;; if .testconfig exists in test directory read and return it
;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata"
;; else read the testconfig file
;;   if have path to test directory save the config as .testconfig and return it
;;
(define (tests:get-testconfig test-name test-registry system-allowed #!key (force-create #f))
  (let* ((cache-path   (tests:get-test-path-from-environment))
	 (cache-file   (and cache-path (conc cache-path "/.testconfig")))
	 (cache-exists (and cache-file
			    (not force-create)  ;; if force-create then pretend there is no cache to read
			    (file-exists? cache-file)))
	 (cached-dat   (if (and (not force-create)
				cache-exists)
			   (handle-exceptions
			    exn
			    #f ;; any issues, just give up with the cached version and re-read
			    (configf:read-alist cache-file))
			   #f)))



    (if cached-dat
	cached-dat
	(let ((dat (hash-table-ref/default *testconfigs* test-name #f)))
	  (if (and  dat ;; have a locally cached version
		    (hash-table-ref/default dat "have fulldata" #f)) ;; marked as good data?
	      dat
	      ;; no cached data available
	      (let* ((treg         (or test-registry
				       (tests:get-all)))
		     (test-path    (or (hash-table-ref/default treg test-name #f)
				       (conc *toppath* "/tests/" test-name)))
		     (test-configf (conc test-path "/testconfig"))
		     (testexists   (and (file-exists? test-configf)(file-read-access? test-configf)))
		     (tcfg         (if testexists
				       (read-config test-configf #f system-allowed
						    environ-patt: (if system-allowed
								      "pre-launch-env-vars"
								      #f))
				       #f)))
		(if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data
		(if tcfg (hash-table-set! *testconfigs* test-name tcfg))
		(if (and testexists
			 cache-file
			 (file-write-access? cache-path))
		    (let ((tpath (conc cache-path "/.testconfig")))
		      (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath)
		      (configf:write-alist tcfg tpath)))
		tcfg))))))

;; hed is the test name
;; test-records is a hash of test-name => test record
(define (tests:get-full-data test-names test-records required-tests all-tests-registry)
  (if (not (null? test-names))
      (let loop ((hed (car test-names))
		 (tal (cdr test-names)))         ;; 'return-procs tells the config reader to prep running system but return a proc
	(debug:print-info 4 *default-log-port* "hed=" hed " at top of loop")

	(let* ((config  (tests:get-testconfig hed all-tests-registry 'return-procs))
	       (waitons (let ((instr (if config 
					 (config-lookup config "requirements" "waiton")
					 (begin ;; No config means this is a non-existant test
					   (debug:print-error 0 *default-log-port* "non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.")
					     ""))))
			  (debug:print-info 8 *default-log-port* "waitons string is " instr)
			  (string-split (cond

[server]

# force use of server always
# required yes

# Use http instead of direct filesystem access
transport rpc
# transport http
# transport fs
# transport nmsg

synchronous 0

# If the server can't be started on this port it will try the next port until
# it succeeds

#  greater. See the accompanying file COPYING for details.
# 
#  This program is distributed WITHOUT ANY WARRANTY; without even the
#  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
#  PURPOSE.

echo You may need to do the following first:
echo sudo apt-get install libreadline-dev libsqlite3-dev libwebkitgtk-dev 

echo sudo apt-get install libpangox-1.0-0 zlib1g-dev libfreetype6-dev cmake
echo sudo apt-get install libssl-dev uuid-dev libglu1-mesa-dev
echo sudo apt-get install libmotif3 -OR- set KTYPE=26g4
echo
echo Set OPTION to std, currently OPTION=$OPTION
echo
echo Additionally, if you want mysql-client, you will need to make sure
echo mysql_config is in your path
echo
echo You are using PREFIX=$PREFIX
echo You are using proxy="$proxy"
echo 
echo "Set additional_libpath to help find gtk or other libraries, don't forget a leading :"

if [[ "$OPTION"x == "x" ]];then
  OPTION=std
fi

SYSTEM_TYPE=$(lsb_release -irs |tr ' ' '_' |tr '\n' '-')$(uname -i)-$OPTION

# default chicken version variables. Override in case statement as appropriate
CHICKEN_VERSION=4.10.0
CHICKEN_BASEVER=4.10.0

# Set up variables
#
case $SYSTEM_TYPE in
Ubuntu-16.04-x86_64-std)
	KTYPE=32
	CDVER=5.10
	IUPVER=3.17
	IMVER=3.11
	;;
Ubuntu-16.04-x86_64-new)
	KTYPE=32
	CDVER=5.10
	IUPVER=3.17
	IMVER=3.11
	CHICKEN_VERSION=4.10.0
	CHICKEN_BASEVER=4.10.0
	;;
Ubuntu-16.04-i686-std)
	KTYPE=32
	CDVER=5.10
	IUPVER=3.17
	IMVER=3.11
	;;
SUSE_LINUX_11-x86_64-std)

  echo Using KTYPE=$KTYPE
fi

# Put all the downloaded tar files in tgz
mkdir -p tgz

# http://code.call-cc.org/releases/4.8.0/chicken-4.8.0.5.tar.gz


chicken_targz=chicken-${CHICKEN_VERSION}.tar.gz
if ! [[ -e tgz/$chicken_targz ]]; then 
    wget http://code.call-cc.org/releases/${CHICKEN_BASEVER}/${chicken_targz}
    mv $chicken_targz tgz
fi 

BUILDHOME=$PWD

	fi
fi
cd $BUILDHOME

# Some eggs are quoted since they are reserved to Bash
# for f in matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5; do
# $CHICKEN_INSTALL $PROX -keep-installed matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb http-client spiffy-request-vars md5 message-digest http-client spiffy-directory-listing
for egg in matchable readline apropos dbi base64 regex-literals format "regex-case" "test" \
	coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo \
	tcp rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb http-client \
	spiffy-request-vars s md5 message-digest spiffy-directory-listing ssax sxml-serializer \
	sxml-modifications logpro z3 call-with-environment-variables \
	pathname-expand typed-records simple-exceptions numbers crypt parley srfi-42 \
	alist-lib ansi-escape-sequences args basic-sequences bindings chicken-doc chicken-doc-cmd \
	cock condition-utils debug define-record-and-printer easyffi easyffi-base \

	cd opensrc
	#fossil open ../opensrc.fossil
	cd histstore
	$PREFIX/bin/csc histstore.scm -o hs 
	cp -f hs $PREFIX/bin/hs 
	cd ../mutils
	$PREFIX/bin/chicken-install
	# cd ../dbi 
	# $PREFIX/bin/chicken-install
	cd ../margs
	$PREFIX/bin/chicken-install
fi
cd $BUILDHOME

if ! [[ -e $PREFIX/bin/stmlrun ]] ; then
	#fossil clone http://www.kiatoa.com/fossils/stml stml.fossil