Megatest

mtserv.scm at [a51a5d6058]
Login

File mtserv.scm artifact ad1041ae0e part of check-in a51a5d6058


; Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

;; (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))
|#