;; Copyright 2006-2011, 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.
;; This is from the perl world, a hash of hashes is a super easy way to keep a handle on
;; lots of disparate data
;;
(module mutils
*
(import chicken scheme
;; data-structures posix
srfi-1
;; srfi-13
srfi-69
ports
extras
regex
posix
data-structures
matchable
)
(define (mutils:hierhash-ref hh . keys)
(if (null? keys)
#f
(let loop ((ht hh)
(key (car keys))
(tail (cdr keys)))
(if (null? tail)
(if (hash-table? ht)
(hash-table-ref/default ht key #f)
#f)
(if (hash-table? ht)
(loop (hash-table-ref/default ht key #f)
(car tail)
(cdr tail))
#f)))))
;; WATCH THE NON-INTUITIVE INTERFACE HERE!!!!
;; val comes first!
;;
(define (mutils:hierhash-set! hh val . keys)
(if (null? keys)
#f
(let loop ((ht hh)
(key (car keys))
(tail (cdr keys)))
(if (null? tail) ;; last one!
(hash-table-set! ht key val)
(let ((nh (hash-table-ref/default ht key #f)))
(if (not nh)(set! nh (make-hash-table)))
(hash-table-set! ht key nh)
(loop nh
(car tail)
(cdr tail)))))))
;; nice little routine to add an item to a list in a hashtable
;;
(define (mutils:hash-table-add-to-list htbl key item)
(let ((l (hash-table-ref/default htbl key #f)))
(if l
(hash-table-set! htbl key (cons item l))
(hash-table-set! htbl key (list item)))))
(define (mutils:hash-table-append-to-list htbl key lst)
(let ((l (hash-table-ref/default htbl key #f)))
(if l
(hash-table-set! htbl key (append lst l))
(hash-table-set! htbl key lst))))
;;======================================================================
;; Utils
;;======================================================================
(define (mutils:file->list fname)
(let ((fh (open-input-file fname))
(comment (regexp "^\\s*#"))
(blank (regexp "^\\s*$")))
(let loop ((l (read-line fh))
(res '()))
(if (eof-object? l)
(reverse res)
(if (or (string-match comment l)
(string-match blank l))
(loop (read-line fh) res)
(loop (read-line fh) (cons l res)))))))
(use sparse-vectors)
;; this is a simple two dimensional sparse array
;; ONLY TWO DIMENSIONS!!! SEE ARRAY-LIB IF YOUR NEEDS ARE GREATER!!
;;
(define (mutils:make-sparse-array)
(let ((a (make-sparse-vector)))
(sparse-vector-set! a 0 (make-sparse-vector))
a))
(define (mutils:sparse-array? a)
(and (sparse-vector? a)
(sparse-vector? (sparse-vector-ref a 0))))
(define (mutils:sparse-array-ref a x y)
(let ((row (sparse-vector-ref a x)))
(if row
(sparse-vector-ref row y)
#f)))
(define (mutils:sparse-array-set! a x y val)
(let ((row (sparse-vector-ref a x)))
(if row
(sparse-vector-set! row y val)
(let ((new-row (make-sparse-vector)))
(sparse-vector-set! a x new-row)
(sparse-vector-set! new-row y val)))))
;; some routines for treating assoc lists a bit like hash tables
(define (mutils:assoc-get/default alist key default)
(let ((res (assoc key alist)))
(if (and res (list? res)(> (length res) 1))
(cadr res)
default)))
(define (mutils:assoc-get alist key)
(cadr (assoc key alist)))
(define (mutils:hier-list? @hierlist)
(and (list? @hierlist)
(> (length @hierlist) 0)
(list? (car @hierlist))
(> (length (car @hierlist)) 1)))
(define (mutils:hier-list-get @hierlist . @path)
(if (list? @hierlist)
(let* (($path (car @path))
(@rempath (cdr @path))
(@match (assoc $path @hierlist)))
(if @match
(if (or (not (list? @rempath))(null? @rempath))
(cadr @match)
(apply mutils:hier-list-get (cadr @match) @rempath))
#f))
#f))
(define (mutils:hier-list-put! @hierlist . @path)
(let* (($path (car @path))
(@rempath (cdr @path))
($value (cadr @path))
(@match (assoc $path @hierlist))
(@remhierlist (remove (lambda (a)
(equal? a @match))
@hierlist))
(@old-pair (let (($value (mutils:hier-list-get @hierlist $path))) (if $value $value '())))
(@new-pair (list $path (if (eq? (length @rempath) 1)
(car @rempath)
(apply mutils:hier-list-put! @old-pair @rempath)))))
(cons @new-pair @remhierlist)))
(define (mutils:hier-list-remove! @hierlist . @path)
(let (($path (car @path)))
(if (eq? (length @path) 1)
(remove (lambda (a)
(equal? a (assoc $path @hierlist)))
@hierlist)
(let* ((@rempath (cdr @path))
(@match (assoc $path @hierlist))
(@remhierlist (remove (lambda (a)
(equal? @match a))
@hierlist))
(@old-pair (let (($value (mutils:hier-list-get @hierlist $path))) (if $value $value '())))
(@new-pair (list $path (apply mutils:hier-list-remove! @old-pair @rempath))))
(cons @new-pair @remhierlist)))))
(define (mutils:keys @hierlist . @path)
(map (lambda (@l)
(if (and (list? @l)(not (null? @l)))
(car @l)))
(if (null? @path) @hierlist
(apply mutils:hier-list-get @hierlist @path))))
;;======================================================================
;; Other utils
;;======================================================================
(define (check-write-create fpath)
(and (file-write-access? fpath)
(let ((fname (conc fpath "/.junk-" (current-seconds) "-" (random 10000))))
;;(print "trying to create/remove " fname)
(handle-exceptions
exn
#f
(begin
(with-output-to-file fname
(lambda ()
(print "You can delete this file")))
(delete-file fname)
#t)))))
(define (run-and-return-output cmd . params)
(let-values (((inp oup pid)
(process cmd params)))
(let ((res (with-input-from-port inp read-lines)))
(let-values (((pidres status estatus)
(process-wait pid)))
(and status (eq? estatus 0) res)))))
(define (confirm-ssh-access-to-host hostname)
(run-and-return-output "ssh" hostname "uptime"))
(define (check-display dsp)
(run-and-return-output "xdpyinfo" "-display" dsp))
#;(define (check-display dsp)
(let-values (((inp oup pid)
(process "xdpyinfo" `("-display" ,dsp))))
(let ((res (with-input-from-port inp read-lines)))
(let-values (((pidres status estatus)
(process-wait pid)))
(and status (eq? estatus 0) res)))))
;; do some sanity checks on the system
;;
(define (mutils:syscheck common:raw-get-remote-host-load
server:get-best-guess-address
read-config)
;; current dir writeable and do megatest.config, runconfigs.config files exist/readable
(print "Current directory " (current-directory) " writeable: "
(if (check-write-create ".") "yes" "NO"))
;; home dir writeable
(print "Home directory " (get-environment-variable "HOME") " writeable: "
(if (check-write-create (get-environment-variable "HOME")) "yes" "NO"))
;; /tmp writeable
(print "/tmp directory writeable: " (if (check-write-create "/tmp") "yes" "NO"))
;; load configs
(print "$DISPLAY set: " (if (get-environment-variable "DISPLAY")
(conc (get-environment-variable "DISPLAY") " yes")
"NO"))
(print "$DISPLAY accessible? "
;; (eq? (system "xdpyinfo -display $DISPLAY &>/dev/null") 0)
(if (check-display (get-environment-variable "DISPLAY"))
"yes" "NO"))
(print "Password-less ssh access to localhost: "
(if (confirm-ssh-access-to-host "localhost")
"yes"
"NO"))
;; if I'm in a Megatest area do some checks
(print "Have megatest.config: "
(if (file-exists? "megatest.config")
"yes"
"NO"))
(print "Have runconfigs.config: "
(if (file-exists? "runconfigs.config")
"yes"
"NO"))
(if (file-exists? ".homehost")
(let* ((homehost (with-input-from-file ".homehost"
read-line))
(currhost (get-host-name))
(bestadrs (server:get-best-guess-address currhost)))
(print "Have .homehost and it is the localhost: "
(if (equal? homehost bestadrs)
"yes"
(conc ".homehost=" homehost ", localhost=" bestadrs ", NO")))
(print "Have .homehost and it is reachable via ssh: "
(if (confirm-ssh-access-to-host homehost)
"yes"
"NO"))
))
(if (file-exists? "megatest.config")
(let* ((cdat (read-config "megatest.config" #f #f)))
(print "Have [disks] section: "
(if (hash-table-ref/default cdat "disks" #f)
(conc (hash-table-ref cdat "disks") " yes")
"NO"))
(for-each
(lambda (entry)
(match
entry
((dname path)
(print "Disk " dname " at " path " writeable: "
(if (check-write-create path) "yes" "NO")))
(else (print "bad entry: " entry))))
(hash-table-ref/default cdat "disks" '()))))
(print "Have link tree and it is writable: "
(if (and (file-exists? "lt")
(check-write-create "lt"))
"yes"
"NO"))
;; check load on homehost
)
;; Develop stuff here - then move to where it belongs.
)