Megatest

           portlogger.scm archive.scm env.scm diff-report.scm		\
           cgisetup/models/pgdb.scm

# server.scm http-transport.scm client.scm rmt.scm

# module source files
MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \
            configfmod.scm servermod.scm clientmod.scm rmtmod.scm        \
            artifacts.scm 

all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut

# dbmod.import.o is just a hack here
mofiles/dbfile.o     : mofiles/debugprint.o mofiles/commonmod.o dbmod.import.o
db.o : dbmod.import.o
mofiles/debugprint.o : mofiles/mtargs.o

	       (vector #f res))
             (begin
               #;(common:telemetry-log (conc "api-out:"(->string cmd))
               payload: `((params . ,params)
               (ok-res . #f)))
               (vector #t res))))))))

write-bundle
read-bundle

;; new artifacts db
with-todays-adb
get-all-artifacts
refresh-artifacts-db
)

(import scheme)

(cond-expand
 (chicken-5
  (import (chicken base)
	  (chicken process) (chicken time posix)
	(chicken io) (chicken file) (chicken pathname)
        chicken.process-context.posix (chicken string)
	(chicken time) (chicken sort) (chicken file posix) (chicken condition)
	(chicken port) (chicken process-context)
	))
 (chicken-4
  (import chicken
	  posix
	  data-structures
	  extras
	  ports
	  files
	  setup-api
	  )
  (define file-executable? file-execute-access?))
 (else))

 (import  srfi-69 srfi-1
	  regex srfi-13 srfi-69
	  crypt sha1 matchable message-digest sqlite3 typed-records
	  directory-utils
	  scsh-process)
 
;;======================================================================
;; DATA MANIPULATION UTILS
;;======================================================================

(define-inline (unescape-data data)
  (string-translate* data '(("\\n" . "\n") ("\\\\" . "\\"))))

;;     (conc "<table>"
;; 	  (string-intersperse
;; 	   (map (lambda (stat)
;; 		  (conc "<tr><td>" (car stat) "</td><td>" (cadr stat) "</td></tr>"))
;; 		stats)
;; 	   " ")
;; 	  "</table>")))
;; 
;; ;; http-server  send-response
;; ;;                 api:process-request
;; ;;                    db:*
;; ;;
;; ;; NB// Runs on the server as part of the server loop
;; ;;
;; (define (api:process-request dbstruct $) ;; the $ is the request vars proc
;;   (debug:print 4 *default-log-port* "server-id:"  *server-id*)
;;   (let* ((cmd     ($ 'cmd))
;; 	 (paramsj ($ 'params))
;;          (key     ($ 'key))   
;; 	 (params  (db:string->obj paramsj transport: 'http))) ;; incoming data from the POST (or is it a GET?)
;;     (debug:print 4 *default-log-port* "cmd:" cmd " with params " params "key " key)
;;     (if (equal? key *server-id*)
;;       (begin
;;         (set! *api-process-request-count* (+ *api-process-request-count* 1))
;;  	(let* ((resdat  (api:execute-requests dbstruct (vector cmd params))) ;; process the request, resdat = #( flag result )
;; 	       (success (vector-ref resdat 0))
;; 	       (res     (vector-ref resdat 1))) ;; (vector flag payload), get the payload, ignore the flag (why?)
;; 	  (debug:print 4 *default-log-port* "res:" res)
;; 	  (if (not success)
;; 	      (debug:print 0 *default-log-port* "ERROR: success flag is #f for " cmd " with params " params))
;; 	  (if (> *api-process-request-count* *max-api-process-requests*)
;; 	      (set! *max-api-process-requests* *api-process-request-count*))
;; 	  (set! *api-process-request-count* (- *api-process-request-count* 1))
;; 	  ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds
;; 	  ;; (rmt:dat->json-str
;; 	  ;;  (if (or (string? res)
;; 	  ;;          (list?   res)
;; 	  ;;          (number? res)
;; 	  ;;          (boolean? res))
;; 	  ;;      res 
;; 	  ;;      (list "ERROR, not string, list, number or boolean" 1 cmd params res)))))
;; 	  (db:obj->string res transport: 'http)))
;; 	(begin
;; 	  (debug:print 0 *default-log-port*   "Server refused to process request. Server id mismatch. recived " key " expected:  " *server-id* ".\nOther arguments recived: cmd=" cmd " params = " params) 
;; 	  (db:obj->string (conc "Server refused to process request server-id mismatch: " key ", " *server-id*) transport: 'http)))))
;; 
;; 

;; (include "common.scm")
;; (include "megatest-version.scm")

;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)

(use srfi-1 posix srfi-69 readline ;;  regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
     srfi-19  srfi-18 extras format regex regex-case
     (prefix dbi dbi:)
     matchable
     )

;; (declare (uses common))
(declare (uses margs))
(declare (uses configfmod))
(declare (uses servermod))


(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")



(define help (conc "
mtserv, part of the Megatest tool suite, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright Matt Welland 2006-2017

Usage: mtserv action [options]
  -h                         : this help
  -manual                    : show the Megatest user manual
  -version                   : print megatest version (currently " megatest-version ")
  -start-dir path            : switch to dir at start

actions:

  server                     : start server
  repl                       : start repl
			     
Examples:

Called as " (string-intersperse (argv) " ") "
Version " megatest-version ", built from " megatest-fossil-hash ))
  ;; first token is our action, but only if no leading dash

(define *action* (if (and (> (length (argv)) 1)
                          (not (string-match "^\\-.*" (cadr (argv)))))
		     (cadr (argv))
		     #f))

(define *remargs*
  (args:get-args
   (if *action* (cdr (argv)) (argv))
   '("-log")
   '("-h"
     )
   args:arg-hash
   0))

(if (args:get-arg "-h")
    (begin
      (print help)
      (exit)))

(if (args:get-arg "-start-dir")
    (let* ((start-dir (args:get-arg "-start-dir")))
      (if (and (file-exists? start-dir)
	       (directory?   start-dir))
	  (change-directory start-dir)
	  (begin
	    (print "FATAL: cannot find or access "start-dir)
	    (exit 1)))))

(if *action*
    (case (string->symbol *action*)
      ((server)    (server:run))
      ((repl)
       (import extras) ;; might not be needed
       ;; (import csi)
       (import readline)
       (import apropos)
       ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
       
       (install-history-file (get-environment-variable "HOME") ".mtserv_history") ;;  [homedir] [filename] [nlines])
       (current-input-port (make-readline-port "mtserv> "))
       (print "Starting repl...")
       (repl))
        ;; (if (args:get-arg "-load")
	;;    (load (args:get-arg "-load"))
	;;   (repl)))
      (else
       (print "Action \""*action*"\" not recognised.")
       (print help)))
    (begin
      (print "No action provided.")
      (print help)))

#|
(define mtconf (car (simple-setup #f)))
(define dat (common:with-queue-db mtconf (lambda (conn)(get-pkts conn '()))))
(pp (pkts#flatten-all dat '((cmd . ((parent . P)(url . M)))(runtype . ((parent . P)))) 'id 'group-id 'uuid 'parent 'pkt-type 'pkt 'processed))
|#

;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

(declare (unit servermod))

(use md5 message-digest posix typed-records extras)

(module servermod
*

(import scheme
	chicken

	extras
	md5
	message-digest
	ports
	posix

	typed-records
	data-structures
	)

(define *client-server-id* #f)

(defstruct srv
  (areapath #f)
  (host     #f)
  (pid      #f)
  (type     #f)
  (dir      #f)
  )
;;======================================================================
;; S E R V E R   U T I L I T I E S 
;;======================================================================

;; Generate a unique signature for this server
(define (mk-signature)
  (message-digest-string (md5-primitive) 
			 (with-output-to-string
			   (lambda ()
			     (write (list (current-directory)
                                          (current-process-id)
					  (argv)))))))

(define (get-client-server-id)
  (if *client-server-id* *client-server-id*
      (let ((sig (mk-signature))) ;; clients re-use the server:mk-signature logic
        (set! *client-server-id* sig)
        *client-server-id*)))

;; if srvdat is #f calculate host.pid
(define (get-host.pid srvdat)
  (if srvdat
      (conc (srv-host srvdat)"."(srv-pid srvdat))
      (conc (get-host-name)"."(current-process-id))))

;; nearly every process in Megatest (if write access) starts a server so it
;; can receive messages to exit on request

;; one server per run db file would be ideal.

;; servers have a type, mtserve, dboard, runner, execute

;; mtrah/.servers/<type>/<host>.<pid>/incoming/*.artifact
;;                                   |        `attic
;;                                   |
;;    (note: not needed? (i))        `outgoing/<clienthost>.<clientpid>/*.artifact
;;                                   |                                 `attic
;;                                   `<tcp|http|nmsg|?>.host:port

;; (i) Not needed if it is expected that all processes run a server

;; on exit processes clean up. only mtserv or dboard clean up abandoned records?

;; server:setup          - setup the directory
;; server:launch         - start a new mtserve process, possibly
;;                         using a launcher
;; server:run            - run the long running thread that monitors
;;                         the .server area
;; server:exit           - shutdown the server and exit
;; server:handle-request - take incoming request, process it, send response
;;                         back via best or fastest available transport

;; set up the server area and return a server struct
;; NOTE: This will need to be gated by write-access
;;
(define (server:setup srvtype areapath)
  (let* ((srvdat (make-srv
		  areapath: areapath
		  host:     (get-host-name) ;; likely need to replace with ip address
		  pid:      (current-process-id)
		  type:     srvtype))
	 (srvdir (conc areapath"/"srvtype"/"(get-host.pid srvdat))))
    (srv-dir-set! srvdat srvdir)
    (create-directory srvdir #t)
    srvdat))

;; maybe check load before calling this?
(define (server:launch areapath)
  (let* ((logd (conc areapath"/logs"))
	 (logf (conc logd"/from-"(get-host.pid #f)".log")))
    (if (not (file-exists? logd))(create-directory logd #t))
    (setenv "NBFAKE_LOG" logf)
    (system (conc "nbfake mtserve -start-dir "areapath))))
    
;; ;; When using zmq this would send the message back (two step process)
;; ;; with spiffy or rpc this simply returns the return data to be returned
;; ;; 
;; (define (server:reply return-addr query-sig success/fail result)
;;   (debug:print-info 11 *default-log-port* "server:reply return-addr=" return-addr ", result=" result)
;;   ;; (send-message pubsock target send-more: #t)
;;   ;; (send-message pubsock