Megatest

#  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/>.

# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)'
# rm <files>.o ; make install CSCOPTS='-profile' ; ... ;  chicken-profile | less
SHELL=/bin/bash
PREFIX=$(PWD)
CSCOPTS=
INSTALL=install

all: archive.scm
	csc -static -L -static -L -lsqlite3 -L -lm -L -ldl -L -lpthread archive.scm

(import 
  big-chicken
  regex 
  sqlite3
)

(define (copy-database workweek)
  (print "Copy megatest.db to mt_archive/" workweek "/megatest.db")
  (if (file-exists? (conc "mt_archive/" workweek "/megatest.db"))
    (begin (print "Archive already exists.  Exiting") (quit))
  )
  (if (not (file-exists? (conc "mt_archive/" workweek)))
    (begin 
      (print "Create archive dir")
      (create-directory (conc "mt_archive/" workweek) #t)
    )
    (print "Archive dir already exists")
  )
  (copy-file "megatest.db" (conc "mt_archive/" workweek "/megatest.db"))
  (with-output-to-file (conc "mt_archive/" workweek "/megatest.config") 
    (lambda() (print "[include ../../megatest.config]"))
  )
  ;;(create-symbolic-link "megatest.config" (conc "mt_archive/" workweek "/megatest.config"))
  ;;(create-symbolic-link "configs" (conc "mt_archive/" workweek "/configs"))
  ;;(create-symbolic-link "runconfigs.config" (conc "mt_archive/" workweek "/runconfigs.config"))
)

(define (delete-orphan-tests db)
  (execute db (conc "DELETE FROM tests where run_id NOT IN (select distinct id from runs)"))
)
 
(define (delete-orphan-steps db)
  (execute db (conc "DELETE FROM test_steps where test_id NOT IN (select distinct id from tests)"))
)

(define (vacuum-db db)
  (execute db (conc "VACUUM;"))
)

(define (trim-runs file operand timestamp)
  (print "Trim Runs from " file " where timestamp is " operand " " timestamp)
  (let* ((db (open-database file))
         (cmd (conc "DELETE FROM runs WHERE event_time " operand " " timestamp)))
    (print (database? db))
    (print "CMD: " cmd)
    (with-transaction db 
      (lambda () 
        (execute db cmd)
        (delete-orphan-tests db)
        (delete-orphan-steps db)
      )
    )
    (vacuum-db db)
  )
)

(let* ((workweek (string-chomp (call-with-input-pipe "date +%yww%V" (lambda (port) (read-string #f  port))  ) ))
       (fortyfive-days-ago (- (current-seconds) (* 60 60 24 45)) )
       ;;(user (get-environment-variable "USER"))
       (area "libanatmpltsqa")
       (user (current-user-name))
       (path (string-translate (current-directory) "/" ".")))
  (print "Path: " path)
  (print "User: " user)
  (print "Megatest.db: "  (conc "/tmp/" user "/megatest_localdb/" area "/" path "/megatest.db") )
  (print "Megatest_ref.db: "  (conc "/tmp/" user "/megatest_localdb/" area "/" path "/megatest_ref.db") )
  ;;(quit)
  (copy-database workweek)
  (trim-runs "megatest.db" "<" fortyfive-days-ago)
  (trim-runs (conc "/tmp/" user "/megatest_localdb/" area "/" path "/megatest.db") "<" fortyfive-days-ago)
  (trim-runs (conc "/tmp/" user "/megatest_localdb/" area "/" path "/megatest_ref.db") "<" fortyfive-days-ago)
  (trim-runs (conc "mt_archive/" workweek "/megatest.db") ">=" fortyfive-days-ago)
)

       (conc (configf:lookup *configdat* "setup" "free-space-script") " " path)
       (lambda ()
	 (let ((res (read-line)))
	   (if (string? res)
	       (string->number res)))))
      (get-unix-df path)))

(define (get-free-inodes path)
  (if (configf:lookup *configdat* "setup" "free-inodes-script")
      (with-input-from-pipe 
       (conc (configf:lookup *configdat* "setup" "free-inodes-script") " " path)
       (lambda ()
	 (let ((res (read-line)))
	   (if (string? res)
	       (string->number res)))))
      (get-unix-inodes path)))

(define (get-unix-df path)
  (let* ((df-results (process:cmd-run->list (conc "df " path)))
	 (space-rx   (regexp "([0-9]+)\\s+([0-9]+)%"))
	 (freespc    #f))
    ;; (write df-results)
    (for-each (lambda (l)
		(let ((match (string-search space-rx l)))
		  (if match 
		      (let ((newval (string->number (cadr match))))
			(if (number? newval)
			    (set! freespc newval))))))
	      (car df-results))
    freespc))

(define (get-unix-inodes path)
  (let* ((df-results (process:cmd-run->list (conc "df -i " path)))
	 (space-rx   (regexp "([0-9]+)\\s+([0-9]+)%"))
	 (freenodex    #f))
    ;; (write df-results)
    (for-each (lambda (l)
		(let ((match (string-search space-rx l)))
		  (if match 
		      (let ((newval (string->number (cadr match))))
			(if (number? newval)
			    (set! freenodes newval))))))
	      (car df-results))
    freenodes))

(define (common:check-space-in-dir dirpath required)
  (let* ((dbspace  (if (directory? dirpath)
		       (get-df dirpath)
		       0)))
    (list (> dbspace required)
	  dbspace

	  (debug:print-error 0 *default-log-port* "Insufficient space in " dbdir ", require " required ", have " dbspace  ", exiting now.")
	  (exit 1)))))
  
;; paths is list of lists ((name path) ... )
;;
(define (common:get-disk-with-most-free-space disks minsize)
  (let ((best     #f)
	(bestsize 0))
	(bestsize 0)
        (min-inodes (or (string->number (if (configf:lookup *configdat* "setup" "min_inodes") (configf:lookup *configdat* "setup" "min_inodes") "0")) 0)))
    (for-each 
     (lambda (disk-num)
       (let* ((dirpath    (cadr (assoc disk-num disks)))
	      (freespc    (cond
			   ((not (directory? dirpath))
			    (if (common:low-noise-print 300 "disks not a dir " disk-num)
				(debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it."))
			    -1)
			   ((not (file-write-access? dirpath))
			    (if (common:low-noise-print 300 "disks not writeable " disk-num)
				(debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it."))
			    -1)
			   ((not (eq? (string-ref dirpath 0) #\/))
			    (if (common:low-noise-print 300 "disks not a proper path " disk-num)
				(debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it."))
			    -1)
			   (else
			    (get-df dirpath)))))
	 (if (> freespc bestsize)
			    (get-df dirpath))))
             (free-inodes (get-free-inodes dirpath)))
	 (if (and (> freespc bestsize)(> free-inodes min-inodes ))
	     (begin
	       (set! best     (cons disk-num dirpath))
	       (set! bestsize freespc)))))
	       (set! bestsize freespc)))
        ;;(print "Processing: " disk-num " bestsize: " bestsize " best: " best " freespc: " freespc " min-inodes: " min-inodes " free-inodes: " free-inodes)
      ))
     (map car disks))
    (if (and best (> bestsize minsize))
	best
	#f))) ;; #f means no disk candidate found

;; convert a spec string to a list of vectors #( rx  action rx-string )
(define (common:spec-string->list-of-specs spec-string actions)

;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;; 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.6530)
(define megatest-version 1.6531)