Megatest

Diff
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Annotate Patch Side-by-side Diff

Differences From Artifact [55136b63dd]:

To Artifact [429d7d2934]:

︙
979
980
981
982
983
984
985
986
987
988


















989
990



991
992


993
994
995

















996
997
998
999
1000
1001
1002
1003
1004









































1005
1006
1007


1008
1009
1010
1011
1012



1013
1014
1015


1016
1017
1018
1019









1020
1021




1022
1023
1024
1025
1026
1027







1028
1029


1030
1031
1032
1033
1034
1035
1036

979
980
981
982
983
984
985



986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003


1004
1005
1006


1007
1008



1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025









1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066



1067
1068





1069
1070
1071



1072
1073




1074
1075
1076
1077
1078
1079
1080
1081
1082


1083
1084
1085
1086






1087
1088
1089
1090
1091
1092
1093


1094
1095
1096
1097
1098
1099
1100
1101
1102








-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
-
-
+
+
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
+
+
-
-
-
-
-
+
+
+
-
-
-
+
+
-
-
-
-
+
+
+
+
+
+
+
+
+
-
-
+
+
+
+
-
-
-
-
-
-
+
+
+
+
+
+
+
-
-
+
+








;; a specific Megatest area. Detail are being hashed out and this may change.
;;
(if (args:get-arg "-adjutant")
    (begin
      (adjutant-run)
      (set! *didsomething* #t)))

(if (or (args:get-arg "-list-servers")
        (args:get-arg "-kill-servers"))
    (let ((tl (launch:setup)))
(if (args:get-arg "-list-servers")
  (let* ((tl (launch:setup)) ;; need this to initialize *toppath*
        (servdir (tt:get-servinfo-dir *toppath*))
        (servfiles (glob (conc servdir "/*:*.db")))
        (fmtstr  "~10a~22a~10a~25a~25a~8a\n")
        (dbfiles (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db"))))
        (ttdat (make-tt areapath: *toppath*))
     )
     (format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state")
     (for-each
        (lambda (dbfile)
          (let* (
            (dbfname (conc (pathname-file dbfile) ".db"))
            (sfiles   (tt:find-server *toppath* dbfname))
            )
            (for-each 
              (lambda (sfile)
                (let (
      (debug:print 0 *default-log-port* "NOT YET REIMPLEMENTED FOR TCP/INMEM") ;; BUG
      (exit)
                  (sinfos (tt:get-server-info-sorted ttdat dbfname))
                  )
                  (for-each 
      (if tl ;; all roads from here exit
	  (let* ((servers (server:choose-server *toppath* 'all-valid)) ;; (server:get-list *toppath*))
                     (lambda (sinfo)
                       (let* (
		 (fmtstr  "~33a~22a~20a~20a~8a\n"))
            (if (not servers)
              (begin
                         (db (list-ref sinfo 5))
                         (pid (list-ref sinfo 4))
                         (host (list-ref sinfo 0))
                         (port (list-ref sinfo 1))
                         (server-id (list-ref sinfo 3))
                         (age (seconds->hr-min-sec (- (current-seconds) (list-ref sinfo 2))))
                         (last-mod (seconds->string (list-ref sinfo 2)))
                         (status (system (conc "ssh " host " ps " pid " > /dev/null")))
                         (state (if (> status 0)
                                  "dead"
                                  (tt:ping host port server-id 0)
                                ))
                         )
                         (format #t fmtstr db (conc host ":" port) pid age last-mod state)
                       )
                     )
                     sinfos
                (debug:print-info 1 *default-log-port* "No servers found")
                (exit)
              )
            )
       	    (format #t fmtstr "PID" "host:port" "age (hms)" "Last mod" "State")
	    (format #t fmtstr "===" "=========" "=========" "========" "=====")
	    (for-each ;;  (ip-addr port? mod-time host port start-time pid )
	     (lambda (server)
	       (let* ((mtm (any->number (caddr server)))
                  )
                ) 
              )
              sfiles
            )
          )
       )
       dbfiles
     )
     (set! *didsomething* #t)
     (exit)  
  )
)




(if (args:get-arg "-kill-servers")

  (let* ((tl (launch:setup)) ;; need this to initialize *toppath*
        (servdir (tt:get-servinfo-dir *toppath*))
        (servfiles (glob (conc servdir "/*:*.db")))
        (fmtstr  "~10a~22a~10a~25a~25a~8a\n")
        (dbfiles (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db"))))
        (ttdat (make-tt areapath: *toppath*))
     )
     (format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state")
     (for-each
        (lambda (dbfile)
          (let* (
            (dbfname (conc (pathname-file dbfile) ".db"))
            (sfiles   (tt:find-server *toppath* dbfname))
            )
            (for-each 
              (lambda (sfile)
                (let (
                  (sinfos (tt:get-server-info-sorted ttdat dbfname))
                  )
                  (for-each 
                     (lambda (sinfo)
                       (let* (
		      (mod (if mtm (- (current-seconds) mtm) "unk"))
		      (age (- (current-seconds)(or (any->number mtm) (current-seconds))))
		      (pid (list-ref server 4))
                         (db (list-ref sinfo 5))
                         (pid (list-ref sinfo 4))
		      (url (conc (car server) ":" (cadr server)))
		      (alv (if (number? mod)(< mod 360) #f)))
		 (format #t
			 fmtstr
			 pid
                         (host (list-ref sinfo 0))
                         (port (list-ref sinfo 1))
                         (server-id (list-ref sinfo 3))
			 url
			 (seconds->hr-min-sec age)
			 (seconds->hr-min-sec mod)
                         (age (seconds->hr-min-sec (- (current-seconds) (list-ref sinfo 2))))
                         (last-mod (seconds->string (list-ref sinfo 2)))
			 (if alv "alive" "dead"))
		 (if (and alv
			  (args:get-arg "-kill-servers"))
		     (begin
                         (killed (system (conc "ssh " host " kill " pid " > /dev/null")))
                         (dummy2 (sleep 1))
                         (state (if (> (system (conc "ssh " host " ps " pid " > /dev/null")) 0) "dead" "alive"))
                            )
                         (format #t fmtstr db (conc host ":" port) pid age last-mod state)
                         (system (conc "rm " sfile))
                       )
                     )
                     sinfos
		       (debug:print-info 0 *default-log-port* "Attempting to kill server with pid " pid)
		       (server:kill server)))))
                  )
                ) 
              )
              sfiles
	     (sort servers (lambda (a b)
			     (let ((ma (or (any->number (car a)) 9e9))
				   (mb (or (any->number (car b)) 9e9)))
			       (> ma mb)))))
	    (set! *didsomething* #t)
	    (exit))
            )
          )
       )
       dbfiles
     )
     (set! *didsomething* #t)
     (exit)  
	  (exit))))
      ;; must do, would have to add checks to many/all calls below
  )
)

;;======================================================================
;; Weird special calls that need to run *after* the server has started?
;;======================================================================

(if (args:get-arg "-list-targets")
    (if (launch:setup)
︙
2587
2588
2589
2590
2591
2592
2593
2594









2595
2596
2597
2598



2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617




2618
2619
2620
2621
2622
2623
2624

2653
2654
2655
2656
2657
2658
2659

2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670


2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691

2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702








-
+
+
+
+
+
+
+
+
+


-
-
+
+
+


















-
+
+
+
+








				(file-copy src-db dest-db)
				1)
			      (let ((res (dbmod:db-to-db-sync src-db dest-db last-update (dbfile:db-init-proc) keys)))
				(if res
				    (debug:print-info 0 *default-log-port* "Synced " res " records from "src-db" to "dest-db)
				    (debug:print-info 0 *default-log-port* "No sync due to permissions or other issue."))
				res))))
	   (start-time  (current-seconds)))
	   (start-time  (current-seconds))
           (synclock-mod-time (if (file-exists? lockfile)
             (handle-exceptions
		 exn
	       #f
	       (file-modification-time synclock-file))
	     #f))
            (age (if synclock-mod-time (- (current-seconds) synclock-mod-time) 1000))
           )
      (if (and src-db dest-db)
	  (if (file-exists? src-db)
	      (if (file-exists? lockfile)
		  (debug:print 0 *default-log-port* "Lock "lockfile" exists, skipping sync...")
	      (if (and (file-exists? lockfile) (< age 20))
		    (debug:print 0 *default-log-port* "Lock "lockfile" exists, skipping sync...")
                  (begin
		  (dbfile:with-simple-file-lock
		   lockfile
		   (lambda ()
		     (let loop ((last-changed (current-seconds))
				(last-update  0))
		       (let* ((changes (handle-exceptions
					   exn
					   (begin
					     (debug:print 0 *default-log-port* "Exception in sync: "(condition->list exn))
					     (delete-file lockfile)
					     (exit))
					 (thesync last-update)))
			      (now-time (current-seconds)))
			 (if (and sync-period sync-timeout) ;; 
			     (if (and (< (- now-time start-time) 600) ;; hard limit on how long we run for
				      (>  sync-timeout (- now-time last-changed)))
				 (begin
				   (if sync-period (thread-sleep! sync-period))
				   (loop (if (> changes 0) now-time last-changed) now-time)))))))))
				   (loop (if (> changes 0) now-time last-changed) now-time))))))))
                        (debug:print 0 *default-log-port* "Releasing lock file " lockfile)
                    )
               )
	      (debug:print 0 *default-log-port* "No sync due to unreadble or non-existant source file"src-db))
	  (debug:print 0 *default-log-port* "Usage for -db2db; -to and -from must be specified"))
      (set! *didsomething* #t)))

(if (args:get-arg "-list-test-time")
     (let* ((toppath (launch:setup))) 
     (task:get-test-times)
︙
This page was generated in about 0.122s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00