Changes In Branch v1.6569-newdiet Through [433155d663] Excluding Merge-Ins
This is equivalent to a diff from 80a01976f7 to 433155d663
2021-03-09
| ||
18:45 | merged v1.65-real-button-img check-in: 7a3804ade8 user: mmgraham tags: v1.65-real | |
2021-03-06
| ||
21:28 | Added img to buttons for GTK3 change check-in: c350a6b24f user: matt tags: v1.65-real-button-img | |
04:39 | Try a grounds-up switch to chicken-5 check-in: 101ee7c52b user: matt tags: v1.65-real-chicken-5 | |
2021-02-26
| ||
07:43 | Start from low load node and add diet one by one From: f462c25d37b9b9f978673390d0906efa6dbed868 User: matt check-in: 1706e8d4fe user: matt tags: v1.65-diet2-cm1 (unpublished) | |
07:37 | Partial work on fixing rerun From: b5b72d675da2eba5c01850ea653e0451706a04c2 User: mrwellan check-in: 3c92e0ef5f user: matt tags: v1.65-rerun-fixes-cm1 (unpublished) | |
2021-02-25
| ||
23:22 | eval-string-in-environment if was disabled, re-enabled From: 9564772564650055d045983029236da1cf850ca7 User: matt check-in: cc82a07623 user: matt tags: v1.65-real-reenable-eval-if (unpublished) | |
23:12 | Working on ulex again From: 1db1be496dd6a3b45eb72b3be1dd6a921509edfc User: matt check-in: cef3d0f7a8 user: matt tags: v1.65-real-ulex (unpublished) | |
22:24 | rebased lazy-queue rollup From: 07ab120544e101aafc5dd80650cb243bb7f5ff4e User: matt check-in: df4852aa6d user: matt tags: v1.65-lazyqueue-items-rollup-2 (unpublished) | |
21:48 | begin diet From: badd71f3b34a7dc4f4bdf120b79438d403fd0733 User: matt check-in: c556f6d31c user: matt tags: v1.6569-diet-3 (unpublished) | |
21:39 | Merged diet2 and fixed wrong use of optional (should be key). From: 8a73112be852c6b8910157005985773a412cf768 User: matt check-in: 08108473c8 user: matt tags: v1.6569-diet-2 (unpublished) | |
16:24 | begin diet From: badd71f3b34a7dc4f4bdf120b79438d403fd0733 User: matt check-in: 28303029ea user: matt tags: v1.6569-new-diet (unpublished) | |
16:00 | Missed couple leftovers in dashboard.scm From: f32c8343a23eefbfb0303043805d677ab0f3c5d9 User: mrwellan check-in: 4b2ebfc4f3 user: matt tags: v1.6569-newdiet | |
15:50 | Moved sauth files to subdir. Improved show-uncalled-procedures output. Removed few unused procedures. From: c9e2628a917d4690ad4ffc35a95f5d5000c90cc5 User: matt check-in: 433155d663 user: matt tags: v1.6569-newdiet | |
15:49 | Sort danglers by name if same count. Few more orpaned functions commented out From: 4f82003dc0af1a95e10a23cc60a91b9b5ce9b461 User: matt check-in: 1dabfeb322 user: matt tags: v1.6569-newdiet | |
15:46 | Create new branch named "v1.6569-newdiet" check-in: d0d7abb726 user: matt tags: v1.6569-newdiet | |
15:46 | Missing dep. check-in: 80a01976f7 user: matt tags: v1.65-real | |
2021-02-15
| ||
20:34 | Oops. Dropped a function. Added it back... check-in: 405c573a88 user: matt tags: v1.65-real | |
Modified archive.scm from [35b9e5966e] to [318f092a8a].
︙ | ︙ | |||
29 30 31 32 33 34 35 | ;;====================================================================== ;; ;;====================================================================== ;; NOT CURRENTLY USED ;; | | | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | ;;====================================================================== ;; ;;====================================================================== ;; NOT CURRENTLY USED ;; #;(define (archive:main linktree target runname testname itempath options) (let ((testdir (conc linktree "/" target "/" runname "/" testname "/" itempatt)) (flavor 'plain) ;; type of machine to run jobs on (maxload 1.5) ;; max allowed load for this work (adisks (archive:get-archive-disks))) ;; get testdir size ;; - hand off du to job mgr (if (and (common:file-exists? testdir) |
︙ | ︙ | |||
387 388 389 390 391 392 393 | (debug:print-error 0 *default-log-port* "There was an error archiving data with bup. Archive failed.") (exit 1)) (debug:print-info 0 *default-log-port* "To restore megatest.db run megatest -archive replicacte-db -source archive-dir -time-stamp <ts>. Current timestamp: " (seconds->std-time-str (current-seconds))))))) (else (debug:print-info 0 *default-log-port* "No support for databse archiving with " archiver))) (debug:print-error 0 *default-log-port* "There was an error rsyncing tmp database"))))) | | | 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 | (debug:print-error 0 *default-log-port* "There was an error archiving data with bup. Archive failed.") (exit 1)) (debug:print-info 0 *default-log-port* "To restore megatest.db run megatest -archive replicacte-db -source archive-dir -time-stamp <ts>. Current timestamp: " (seconds->std-time-str (current-seconds))))))) (else (debug:print-info 0 *default-log-port* "No support for databse archiving with " archiver))) (debug:print-error 0 *default-log-port* "There was an error rsyncing tmp database"))))) #;(define (archive:restore-db archive-path ts) (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) (archive-internal-path (conc (common:get-testsuite-name) "-megatest-db/" ts "/megatest.db" )) (bup-restore-params (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path))) (debug:print-info 2 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path) (run-n-wait bup-exe params: bup-restore-params print-cmd: "Running:")) (sleep 2) (db:multi-db-sync |
︙ | ︙ |
Modified client.scm from [dc4c7b41e8] to [bed3bdf664].
︙ | ︙ | |||
29 30 31 32 33 34 35 | (declare (uses common)) (declare (uses db)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. (include "common_records.scm") (include "db_records.scm") | | | | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | (declare (uses common)) (declare (uses db)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. (include "common_records.scm") (include "db_records.scm") ;; client:get-signature, not used right now but likely needed #;(define (client:get-signature) (if *my-client-signature* *my-client-signature* (let ((sig (conc (get-host-name) " " (current-process-id)))) (set! *my-client-signature* sig) *my-client-signature*))) ;; Not currently used! But, I think it *should* be used!!! #;(define (client:logout serverdat) |
︙ | ︙ |
Deleted codescanlib.scm version [6e625610ce].
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Modified common.scm from [82673dacdb] to [fdeca0aaad].
︙ | ︙ | |||
661 662 663 664 665 666 667 | (sparse-vector-set! new-row y val))))) ;;====================================================================== ;; L O C K E R S A N D B L O C K E R S ;;====================================================================== ;; block further accesses to databases. Call this before shutting db down | | | | 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 | (sparse-vector-set! new-row y val))))) ;;====================================================================== ;; L O C K E R S A N D B L O C K E R S ;;====================================================================== ;; block further accesses to databases. Call this before shutting db down #;(define (common:db-block-further-queries) (mutex-lock! *db-access-mutex*) (set! *db-access-allowed* #f) (mutex-unlock! *db-access-mutex*)) #;(define (common:db-access-allowed?) (let ((val (begin (mutex-lock! *db-access-mutex*) *db-access-allowed* (mutex-unlock! *db-access-mutex*)))) val)) ;;====================================================================== |
︙ | ︙ | |||
2625 2626 2627 2628 2629 2630 2631 | (sort (hash-table-keys directories) (lambda (a b)(> (string-length a)(string-length b)))))) )) ;;====================================================================== ;; E N V I R O N M E N T V A R S ;;====================================================================== | | | 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 | (sort (hash-table-keys directories) (lambda (a b)(> (string-length a)(string-length b)))))) )) ;;====================================================================== ;; E N V I R O N M E N T V A R S ;;====================================================================== #;(define (bb-check-path #!key (msg "check-path: ")) (let ((path (or (get-environment-variable "PATH") "none"))) (debug:print-info 0 *default-log-port* (conc msg" : $PATH="path)) (if (string-match "^.*/isoenv-core/.*" path) (debug:print-error 0 *default-log-port* (conc msg" : !!ISOENV PRESENT!!")) ;; remove for prod (debug:print-info 1 *default-log-port* (conc msg" : **no isoenv present**"))))) (define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF" "MAKEOVERRIDES"))) |
︙ | ︙ | |||
3609 3610 3611 3612 3613 3614 3615 | (begin (debug:print 0 *default-log-port* "joining threads failed. exn=" exn) #t) ;; just ignore it, it might have died in the meantime so joining it will throw an exception (thread-join! thread)) ))) (hash-table-keys *common:thread-punchlist*))) | < | > | | | 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 | (begin (debug:print 0 *default-log-port* "joining threads failed. exn=" exn) #t) ;; just ignore it, it might have died in the meantime so joining it will throw an exception (thread-join! thread)) ))) (hash-table-keys *common:thread-punchlist*))) #;(define *common:telemetry-log-state* 'startup) #;(define *common:telemetry-log-socket* #f) ;; (define *common:telemetry-log-socket* #f) #;(define (common:telemetry-log-open) ;; (define (common:telemetry-log-open) ;; (if (eq? *common:telemetry-log-state* 'startup) ;; (let* ((serverhost (configf:lookup *configdat* "telemetry" "host")) ;; (serverport (configf:lookup-number *configdat* "telemetry" "port")) ;; (user (or (get-environment-variable "USER") "unknown")) ;; (host (or (get-environment-variable "HOST") "unknown"))) ;; (set! *common:telemetry-log-state* ;; (handle-exceptions ;; exn ;; (begin ;; (debug:print-info 0 *default-log-port* "common-telemetry-log open udp port failure") ;; 'broken) ;; (if (and serverhost serverport user host) ;; (let* ((s (udp-open-socket))) ;; ;;(udp-bind! s #f 0) ;; (udp-connect! s serverhost serverport) ;; (set! *common:telemetry-log-socket* s) ;; 'open) ;; 'not-needed)))))) #;(define (common:telemetry-log event #!key (payload '())) ;; (define (common:telemetry-log event #!key (payload '())) ;; (if (eq? *common:telemetry-log-state* 'startup) ;; (common:telemetry-log-open)) ;; ;; (if (eq? 'open *common:telemetry-log-state*) ;; (handle-exceptions ;; exn |
︙ | ︙ | |||
3659 3660 3661 3662 3663 3664 3665 | ;; (payload-serialized ;; (base64:base64-encode ;; (z3:encode-buffer ;; (with-output-to-string (lambda () (pp payload)))))) ;; (msg (conc user":"host":"start":"(current-process-id)":"(car (argv))":" ;; toppath":"payload-serialized))) ;; (udp-send *common:telemetry-log-socket* msg)))))) | | | 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 | ;; (payload-serialized ;; (base64:base64-encode ;; (z3:encode-buffer ;; (with-output-to-string (lambda () (pp payload)))))) ;; (msg (conc user":"host":"start":"(current-process-id)":"(car (argv))":" ;; toppath":"payload-serialized))) ;; (udp-send *common:telemetry-log-socket* msg)))))) #;(define (common:telemetry-log-close) ;; (define (common:telemetry-log-close) ;; (when (or (member *common:telemetry-log-state* '(broken-or-no-server-preclose open)) *common:telemetry-log-socket*) ;; (handle-exceptions ;; exn ;; (begin ;; (define *common:telemetry-log-state* 'closed-fail) ;; (debug:print-info 0 *default-log-port* "common-telemetry-log closure failure") ;; ) ;; (begin ;; (define *common:telemetry-log-state* 'closed) ;; (udp-close-socket *common:telemetry-log-socket*) ;; (set! *common:telemetry-log-socket* #f))))) |
Added danglers-to-ignore.txt version [b2a2845e76].
> > > > | 1 2 3 4 | spublish:lst->path megatest-param->mtutil-param add-target-mapper add-runname-mapper |
Added datashare-src/datashare.scm version [2c1663032f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 | ;; Copyright 2006-2013, 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/>. (use ssax) (use sxml-serializer) (use sxml-modifications) (use regex) (use srfi-69) (use regex-case) (use posix) (use json) (use csv) (use srfi-18) (use format) (require-library iup) (import (prefix iup iup:)) (require-library ini-file) (import (prefix ini-file ini:)) (use canvas-draw) (import canvas-draw-iup) (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) (declare (uses configf)) (declare (uses tree)) (declare (uses margs)) ;; (declare (uses dcommon)) ;; (declare (uses launch)) ;; (declare (uses gutils)) ;; (declare (uses db)) ;; (declare (uses synchash)) ;; (declare (uses server)) ;; (declare (uses megatest-version)) ;; (declare (uses tbd)) (include "megatest-fossil-hash.scm") ;; ;; GLOBALS ;; (define *datashare:current-tab-number* 0) (define *args-hash* (make-hash-table)) (define datashare:help (conc "Usage: datashare [action [params ...]] Note: run datashare without parameters to start the gui. list-areas : List the allowed areas list-versions <area> : List versions available in <area> options : -full, -vpatt patt publish <path> <area> <version> : Publish data for area and with version get <area> <version> : Get a link to data, put the link in destpath options : -i iteration update <area> : Update the link to data to the latest iteration. Part of the Megatest tool suite. Learn more at http://www.kiatoa.com/fossils/megatest Version: " megatest-fossil-hash)) ;; " ;;====================================================================== ;; RECORDS ;;====================================================================== ;; make-vector-record "testing" datastore pkg id area version_name store_type copied source_path iteration submitter datetime storegrp datavol quality disk_id comment ;; testing (define (make-datashare:pkg)(make-vector 15)) (define-inline (datashare:pkg-get-id vec) (vector-ref vec 0)) (define-inline (datashare:pkg-get-area vec) (vector-ref vec 1)) (define-inline (datashare:pkg-get-version_name vec) (vector-ref vec 2)) (define-inline (datashare:pkg-get-store_type vec) (vector-ref vec 3)) (define-inline (datashare:pkg-get-copied vec) (vector-ref vec 4)) (define-inline (datashare:pkg-get-source_path vec) (vector-ref vec 5)) (define-inline (datashare:pkg-get-iteration vec) (vector-ref vec 6)) (define-inline (datashare:pkg-get-submitter vec) (vector-ref vec 7)) (define-inline (datashare:pkg-get-datetime vec) (vector-ref vec 8)) (define-inline (datashare:pkg-get-storegrp vec) (vector-ref vec 9)) (define-inline (datashare:pkg-get-datavol vec) (vector-ref vec 10)) (define-inline (datashare:pkg-get-quality vec) (vector-ref vec 11)) (define-inline (datashare:pkg-get-disk_id vec) (vector-ref vec 12)) (define-inline (datashare:pkg-get-comment vec) (vector-ref vec 13)) (define-inline (datashare:pkg-get-stored_path vec) (vector-ref vec 14)) (define-inline (datashare:pkg-set-id! vec val)(vector-set! vec 0 val)) (define-inline (datashare:pkg-set-area! vec val)(vector-set! vec 1 val)) (define-inline (datashare:pkg-set-version_name! vec val)(vector-set! vec 2 val)) (define-inline (datashare:pkg-set-store_type! vec val)(vector-set! vec 3 val)) (define-inline (datashare:pkg-set-copied! vec val)(vector-set! vec 4 val)) (define-inline (datashare:pkg-set-source_path! vec val)(vector-set! vec 5 val)) (define-inline (datashare:pkg-set-iteration! vec val)(vector-set! vec 6 val)) (define-inline (datashare:pkg-set-submitter! vec val)(vector-set! vec 7 val)) (define-inline (datashare:pkg-set-datetime! vec val)(vector-set! vec 8 val)) (define-inline (datashare:pkg-set-storegrp! vec val)(vector-set! vec 9 val)) (define-inline (datashare:pkg-set-datavol! vec val)(vector-set! vec 10 val)) (define-inline (datashare:pkg-set-quality! vec val)(vector-set! vec 11 val)) (define-inline (datashare:pkg-set-disk_id! vec val)(vector-set! vec 12 val)) (define-inline (datashare:pkg-set-comment! vec val)(vector-set! vec 13 val)) (define-inline (datashare:pkg-set-stored_path! vec val)(vector-set! vec 14 val)) ;;====================================================================== ;; DB ;;====================================================================== (define (datashare:initialize-db db) (for-each (lambda (qry) (sqlite3:execute db qry)) (list "CREATE TABLE pkgs (id INTEGER PRIMARY KEY, area TEXT, version_name TEXT, store_type TEXT DEFAULT 'copy', copied INTEGER DEFAULT 0, source_path TEXT, stored_path TEXT, iteration INTEGER DEFAULT 0, submitter TEXT, datetime TIMESTAMP DEFAULT (strftime('%s','now')), storegrp TEXT, datavol INTEGER, quality TEXT, disk_id INTEGER, comment TEXT);" "CREATE TABLE refs (id INTEGER PRIMARY KEY, pkg_id INTEGER, destlink TEXT);" "CREATE TABLE disks (id INTEGER PRIMARY KEY, storegrp TEXT, path TEXT);"))) (define (datashare:register-data db area version-name store-type submitter quality source-path comment) (let ((iter-qry (sqlite3:prepare db "SELECT max(iteration) FROM pkgs WHERE area=? AND version_name=?;")) (next-iteration 0)) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (iteration) (if (and (number? iteration) (>= iteration next-iteration)) (set! next-iteration (+ iteration 1)))) iter-qry area version-name) ;; now store the data (sqlite3:execute db "INSERT INTO pkgs (area,version_name,iteration,store_type,submitter,source_path,quality,comment) VALUES (?,?,?,?,?,?,?,?);" area version-name next-iteration (conc store-type) submitter source-path quality comment))) (sqlite3:finalize! iter-qry) next-iteration)) (define (datashare:get-id db area version-name iteration) (let ((res #f)) (sqlite3:for-each-row (lambda (id) (set! res id)) db "SELECT id FROM pkgs WHERE area=? AND version_name=? AND iteration=?;" area version-name iteration) res)) (define (datashare:set-stored-path db id path) (sqlite3:execute db "UPDATE pkgs SET stored_path=? WHERE id=?;" path id)) (define (datashare:set-copied db id value) (sqlite3:execute db "UPDATE pkgs SET copied=? WHERE id=?;" value id)) (define (datashare:get-pkg-record db area version-name iteration) (let ((res #f)) (sqlite3:for-each-row (lambda (a . b) (set! res (apply vector a b))) db "SELECT * FROM pkgs WHERE area=? AND version_name=? AND iteration=?;" area version-name iteration) res)) ;; take version-name iteration and register or update "lastest/0" ;; (define (datashare:set-latest db id area version-name iteration) (let* ((rec (datashare:get-pkg-record db area version-name iteration)) (latest-id (datashare:get-id db area "latest" 0)) (stored-path (datashare:pkg-get-stored_path rec))) (if latest-id ;; have a record - bump the link pointer (datashare:set-stored-path db latest-id stored-path) (datashare:register-data db area "latest" 'link "auto" "na" stored-path "latest data")))) ;; set a package ref, this is the location where the link back to the stored data ;; is put. ;; ;; if there is nothing at that location then the record can be removed ;; if there are no refs for a particular pkg-id then that pkg-id is a ;; candidate for removal ;; (define (datashare:record-pkg-ref db pkg-id dest-link) (sqlite3:execute db "INSERT INTO refs (pkg_id,destlink) VALUES (?,?);" pkg-id dest-link)) (define (datashare:count-refs db pkg-id) (let ((res 0)) (sqlite3:for-each-row (lambda (count) (set! res count)) db "SELECT count(id) FROM refs WHERE pkg_id=?;" pkg-id) res)) ;; Create the sqlite db (define (datashare:open-db configdat) (let ((path (configf:lookup configdat "database" "location"))) (if (and path (directory? path) (file-read-access? path)) (let* ((dbpath (conc path "/datashare.db")) (writeable (file-write-access? dbpath)) (dbexists (common:file-exists? dbpath)) (handler (make-busy-timeout 136000))) (handle-exceptions exn (begin (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath ((condition-property-accessor 'exn 'message) exn)) (exit)) (set! db (sqlite3:open-database dbpath))) (if *db-write-access* (sqlite3:set-busy-handler! db handler)) (if (not dbexists) (begin (datashare:initialize-db db))) db) (print "ERROR: invalid path for storing database: " path)))) (define (open-run-close-exception-handling proc idb . params) (handle-exceptions exn (let ((sleep-time (random 30)) (err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) (case err-status ((busy) (thread-sleep! sleep-time)) (else (print "EXCEPTION: database overloaded or unreadable.") (print " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) (print " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (print-call-chain (current-error-port)) (thread-sleep! sleep-time) (print "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up"))) (apply open-run-close-exception-handling proc idb params)) (apply open-run-close-no-exception-handling proc idb params))) (define (open-run-close-no-exception-handling proc idb . params) ;; (print "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) (let* ((db (cond ((sqlite3:database? idb) idb) ((not idb) (print "ERROR: cannot open-run-close with #f anymore")) ((procedure? idb) (idb)) (else (print "ERROR: cannot open-run-close with #f anymore")))) (res #f)) (set! res (apply proc db params)) (if (not idb)(sqlite3:finalize! dbstruct)) ;; (print "open-run-close-no-exception-handling END" ) res)) (define open-run-close open-run-close-no-exception-handling) (define (datashare:get-pkgs db area-filter version-filter iter-filter) (let ((res '())) (sqlite3:for-each-row ;; replace with fold ... (lambda (a . b) (set! res (cons (list->vector (cons a b)) res))) db (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path " " FROM pkgs WHERE area like ? AND version_name LIKE ? AND iteration " iter-filter ";") area-filter version-filter) (reverse res))) (define (datashare:get-pkg db area-name version-name #!key (iteration #f)) (let ((dat '()) (res #f)) (sqlite3:for-each-row ;; replace with fold ... (lambda (a . b) (set! dat (cons (list->vector (cons a b)) dat))) db (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path " " FROM pkgs WHERE area=? AND version_name=? ORDER BY iteration ASC;") area-name version-name) ;; now filter for iteration, either max if #f or specific one (if (null? dat) #f (let loop ((hed (car dat)) (tal (cdr dat)) (cur 0)) (let ((itr (datashare:pkg-get-iteration hed))) (if (equal? itr iteration) ;; this is the one if iteration is specified hed (if (null? tal) hed (loop (car tal)(cdr tal))))))))) (define (datashare:get-versions-for-area db area-name #!key (version-patt #f)) (let ((res '()) (data (make-hash-table))) (sqlite3:for-each-row (lambda (version-name submitter iteration submitted-time comment) ;; 0 1 2 3 4 (hash-table-set! data version-name (vector version-name submitter iteration submitted-time comment))) db "SELECT version_name,submitter,iteration,datetime,comment FROM pkgs WHERE area='megatest' AND version_name != 'latest' AND version_name LIKE ? ORDER BY datetime asc;" (or version-patt "%")) (map (lambda (x)(hash-table-ref data x))(sort (hash-table-keys data) string-ci>=)))) ;;====================================================================== ;; DATA IMPORT/EXPORT ;;====================================================================== (define (datashare:import-data configdat source-path dest-path area version iteration) (let* ((space-avail (car dest-path)) (disk-path (cdr dest-path)) (targ-path (conc disk-path "/" area "/" version "/" iteration)) (id (datashare:get-id db area version iteration)) (db (datashare:open-db configdat))) (if (> space-avail 10000) ;; dumb heuristic (begin (create-directory targ-path #t) (datashare:set-stored-path db id targ-path) (print "Running command: rsync -av " source-path "/ " targ-path "/") (let ((th1 (make-thread (lambda () (let ((pid (process-run "rsync" (list "-av" (conc source-path "/") (conc targ-path "/"))))) (process-wait pid) (datashare:set-copied db id "yes") (sqlite3:finalize! db))) "Data copy"))) (thread-start! th1)) #t) (begin (print "ERROR: Not enough space in storage area " dest-path) (datashare:set-copied db id "no") (sqlite3:finalize! db) #f)))) (define (datashare:get-areas configdat) (let* ((areadat (configf:get-section configdat "areas")) (areas (if areadat (map car areadat) '()))) areas)) (define (datashare:publish configdat publish-type area-name version comment spath submitter quality) ;; input checks (cond ((not (member area-name (datashare:get-areas configdat))) (cons #f (conc "Illegal area name \"" area-name "\""))) (else (let ((db (datashare:open-db configdat)) (iteration (datashare:register-data db area-name version publish-type submitter quality spath comment)) (dest-store (datashare:get-best-storage configdat))) (if iteration (if (eq? 'copy publish-type) (begin (datashare:import-data configdat spath dest-store area-name version iteration) (let ((id (datashare:get-id db area-name version iteration))) (datashare:set-latest db id area-name version iteration))) (let ((id (datashare:get-id db area-name version iteration))) (datashare:set-stored-path db id spath) (datashare:set-copied db id "yes") (datashare:set-copied db id "n/a") (datashare:set-latest db id area-name version iteration))) (print "ERROR: Failed to get an iteration number")) (sqlite3:finalize! db) (cons #t "Successfully saved data"))))) (define (datashare:get-best-storage configdat) (let* ((storage (configf:lookup configdat "settings" "storage")) (store-areas (if storage (string-split storage) '()))) (print "Looking for available space in " store-areas) (datashare:find-most-space store-areas))) ;; (string->number (list-ref (with-input-from-pipe "df -B1000000 /tmp" (lambda ()(read-line)(string-split (read-line)))) 3)) (define (datashare:find-most-space paths) (fold (lambda (area res) ;; (print "area=" area " res=" res) (let ((maxspace (car res)) (currpath (cdr res))) ;; (print currpath " " maxspace) (if (file-write-access? area) (let ((currspace (string->number (list-ref (with-input-from-pipe ;; (conc "df --output=avail " area) (conc "df -B1000000 " area) ;; (lambda ()(read)(read)) (lambda ()(read-line)(string-split (read-line)))) 3)))) (if (> currspace maxspace) (cons currspace area) res)) res))) (cons 0 #f) paths)) ;; remove existing link and if possible ... ;; create path to next of tip of target, create link back to source (define (datashare:build-dir-make-link source target) (if (common:file-exists? target)(datashare:backup-move target)) (create-directory (pathname-directory target) #t) (create-symbolic-link source target)) (define (datashare:backup-move path) (let* ((trashdir (conc (pathname-directory path) "/.trash")) (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path)))) (create-directory trashdir #t) (if (directory? path) (system (conc "mv " path " " trashfile)) (file-move path trash-file)))) ;;====================================================================== ;; GUI ;;====================================================================== ;; The main menu (define (datashare:main-menu) (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top) (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options (iup:menu-item "Open" action: (lambda (obj) (iup:show (iup:file-dialog)) (print "File->open " obj))) (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) (iup:menu-item "Tools" (iup:menu (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) ;; (iup:menu-item "Show dialog" #:action (lambda (obj) ;; (show message-window ;; #:modal? #t ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current ;; ;; #:x 'mouse ;; ;; #:y 'mouse ;; ) )))) (define (datashare:publish-view configdat) ;; (pp (hash-table->alist configdat)) (let* ((areas (configf:get-section configdat "areas")) (label-size "70x") (areas-sel (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES")) (version-tb (iup:textbox #:expand "HORIZONTAL")) ;; #:size "50x")) (areas-sel (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES")) (component (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" )) (version-val (iup:textbox #:expand "HORIZONTAL" #:size "50x")) ;; (copy-link (iup:toggle #:expand "HORIZONTAL")) ;; (iteration (iup:textbox #:expand "YES" #:size "20x")) ;; (iteration (iup:textbox #:expand "HORIZONTAL" #:size "20x")) (area-filter (iup:textbox #:expand "HORIZONTAL" #:value "%")) (comment-tb (iup:textbox #:expand "YES" #:multiline "YES")) (source-tb (iup:textbox #:expand "HORIZONTAL" #:value (or (configf:lookup configdat "settings" "basepath") ""))) (publish (lambda (publish-type) (let* ((area-num (or (string->number (iup:attribute areas-sel "VALUE")) 0)) (area-dat (if (> area-num 0)(list-ref areas (- area-num 1))'("NOT SELECTED" "NOT SELECTED"))) (area-path (cadr area-dat)) (area-name (car area-dat)) (version (iup:attribute version-tb "VALUE")) (comment (iup:attribute comment-tb "VALUE")) (spath (iup:attribute source-tb "VALUE")) (submitter (current-user-name)) (quality 2)) (datashare:publish configdat publish-type area-name version comment spath submitter quality)))) (copy (iup:button "Copy and Publish" #:expand "HORIZONTAL" #:action (lambda (obj) (publish 'copy)))) (link (iup:button "Link and Publish" #:expand "HORIZONTAL" #:action (lambda (obj) (publish 'link)))) (browse-btn (iup:button "Browse" #:size "40x" #:action (lambda (obj) (let* ((fd (iup:file-dialog #:dialogtype "DIR")) (top (iup:show fd #:modal? "YES"))) (iup:attribute-set! source-tb "VALUE" (iup:attribute fd "VALUE")) (iup:destroy! fd)))))) (print "areas") ;; (pp areas) (fold (lambda (areadat num) ;; (print "Adding num=" num ", areadat=" areadat) (iup:attribute-set! areas-sel (conc num) (car areadat)) (+ 1 num)) 1 areas) (iup:vbox (iup:hbox (iup:label "Area:" #:size label-size) ;; area-filter areas-sel) (iup:hbox (iup:label "Version:" #:size label-size) version-tb) ;; (iup:hbox (iup:label "Link only" #:size label-size) copy-link) ;; (iup:label "Iteration:") iteration) (iup:hbox (iup:label "Comment:" #:size label-size) comment-tb) (iup:hbox (iup:label "Source base path:" #:size label-size) source-tb browse-btn) (iup:hbox copy link)))) (define (datashare:lst->path pathlst) (conc "/" (string-intersperse (map conc pathlst) "/"))) (define (datashare:path->lst path) (string-split path "/")) (define (datashare:pathdat-apply-heuristics configdat path) (cond ((common:file-exists? path) "found") (else (conc path " not installed")))) (define (datashare:get-view configdat) (iup:vbox (iup:hbox (let* ((label-size "60x") ;; filter elements (area-filter "%") (version-filter "%") (iter-filter ">= 0") ;; reverse lookup from path to data for src and installed (srcdat (make-hash-table)) ;; reverse lookup (installed-dat (make-hash-table)) ;; config values (basepath (configf:lookup configdat "settings" "basepath")) ;; gui elements (submitter (iup:label "" #:expand "HORIZONTAL")) (date-submitted (iup:label "" #:expand "HORIZONTAL")) (comment (iup:label "" #:expand "HORIZONTAL")) (copy-link (iup:label "" #:expand "HORIZONTAL")) (quality (iup:label "" #:expand "HORIZONTAL")) (installed-status (iup:label "" #:expand "HORIZONTAL")) ;; misc (curr-record #f) ;; (source-data (iup:label "" #:expand "HORIZONTAL")) (tb (iup:treebox #:value 0 #:name "Packages" #:expand "YES" #:addexpanded "NO" #:selection-cb (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((path (datashare:lst->path (cdr (tree:node->path obj id)))) (record (hash-table-ref/default srcdat path #f))) (if record (begin (set! curr-record record) (iup:attribute-set! submitter "TITLE" (datashare:pkg-get-submitter record)) (iup:attribute-set! date-submitted "TITLE" (time->string (seconds->local-time (datashare:pkg-get-datetime record)))) (iup:attribute-set! comment "TITLE" (datashare:pkg-get-comment record)) (iup:attribute-set! quality "TITLE" (datashare:pkg-get-quality record)) (iup:attribute-set! copy-link "TITLE" (datashare:pkg-get-store_type record)) )) ;; (print "id=" id " path=" path " record=" record);; (tree:node->path obj id) " run-id: " run-id) )))) (tb2 (iup:treebox #:value 0 #:name "Installed" #:expand "YES" #:addexpanded "NO" #:selection-cb (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((path (datashare:lst->path (cdr (tree:node->path obj id)))) (status (hash-table-ref/default installed-dat path #f))) (iup:attribute-set! installed-status "TITLE" (if status status "")) )))) (refresh (lambda (obj) (let* ((db (datashare:open-db configdat)) (areas (or (configf:get-section configdat "areas") '()))) ;; ;; first update the Sources ;; (for-each (lambda (pkgitem) (let* ((pkg-path (list (datashare:pkg-get-area pkgitem) (datashare:pkg-get-version_name pkgitem) (datashare:pkg-get-iteration pkgitem))) (pkg-id (datashare:pkg-get-id pkgitem)) (path (datashare:lst->path pkg-path))) ;; (print "tree:add-node tb=" tb ", pkg-path=" pkg-path ", pkg-id=" pkg-id) (if (not (hash-table-ref/default srcdat path #f)) (tree:add-node tb "Packages" pkg-path userdata: (conc "pkg-id: " pkg-id))) ;; (print "path=" path " pkgitem=" pkgitem) (hash-table-set! srcdat path pkgitem))) (datashare:get-pkgs db area-filter version-filter iter-filter)) ;; ;; then update the installed ;; (for-each (lambda (area) (let* ((path (conc "/" (cadr area))) (fullpath (conc basepath path))) (if (not (hash-table-ref/default installed-dat path #f)) (tree:add-node tb2 "Installed" (datashare:path->lst path))) (hash-table-set! installed-dat path (datashare:pathdat-apply-heuristics configdat fullpath)))) areas) (sqlite3:finalize! db)))) (apply (iup:button "Apply" #:action (lambda (obj) (if curr-record (let* ((area (datashare:pkg-get-area curr-record)) (stored-path (datashare:pkg-get-stored_path curr-record)) (source-type (datashare:pkg-get-store_type curr-record)) (source-path (case source-type ;; (equal? source-type "link")) ((link)(datashare:pkg-get-source-path curr-record)) ((copy)stored-path) (else #f))) (dest-stub (configf:lookup configdat "areas" area)) (target-path (conc basepath "/" dest-stub))) (datashare:build-dir-make-link stored-path target-path) (print "Creating link from " stored-path " to " target-path))))))) (iup:vbox (iup:hbox tb tb2) (iup:frame #:title "Source Info" (iup:vbox (iup:hbox (iup:button "Refresh" #:action refresh) apply) (iup:hbox (iup:label "Submitter: ") ;; #:size label-size) submitter (iup:label "Submitted on: ") ;; #:size label-size) date-submitted) (iup:hbox (iup:label "Data stored: ") copy-link (iup:label "Quality: ") quality) (iup:hbox (iup:label "Comment: ") comment))) (iup:frame #:title "Installed Info" (iup:vbox (iup:hbox (iup:label "Installed status/path: ") installed-status))) ))))) (define (datashare:manage-view configdat) (iup:vbox (iup:hbox (iup:button "Pushme" #:expand "YES" )))) (define (datashare:gui configdat) (iup:show (iup:dialog #:title (conc "DataShare dashboard " (current-user-name) ":" (current-directory)) #:menu (datashare:main-menu) (let* ((tabs (iup:tabs #:tabchangepos-cb (lambda (obj curr prev) (set! *datashare:current-tab-number* curr)) (datashare:publish-view configdat) (datashare:get-view configdat) (datashare:manage-view configdat) ))) ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) (iup:attribute-set! tabs "TABTITLE0" "Publish") (iup:attribute-set! tabs "TABTITLE1" "Get") (iup:attribute-set! tabs "TABTITLE2" "Manage") ;; (iup:attribute-set! tabs "BGCOLOR" "190 190 190") tabs))) (iup:main-loop)) ;;====================================================================== ;; MISC ;;====================================================================== (define (datashare:do-as-calling-user proc) (let ((eid (current-effective-user-id)) (cid (current-user-id))) (if (not (eq? eid cid)) ;; running suid (set! (current-effective-user-id) cid)) ;; (print "running as " (current-effective-user-id)) (proc) (if (not (eq? eid cid)) (set! (current-effective-user-id) eid)))) (define (datashare:find name paths) (if (null? paths) #f (let loop ((hed (car paths)) (tal (cdr paths))) (if (common:file-exists? (conc hed "/" name)) hed (if (null? tal) #f (loop (car tal)(cdr tal))))))) ;;====================================================================== ;; MAIN ;;====================================================================== (define (datashare:load-config exe-dir exe-name) (let* ((fname (conc exe-dir "/." exe-name ".config"))) (ini:property-separator-patt " * *") (ini:property-separator #\space) (if (common:file-exists? fname) ;; (ini:read-ini fname) (read-config fname #f #t) (make-hash-table)))) (define (datashare:process-action configdat action . args) (case (string->symbol action) ((get) (if (< (length args) 2) (begin (print "ERROR: Missing arguments; " (string-intersperse args ", ")) (exit 1)) (let* ((basepath (configf:lookup configdat "settings" "basepath")) (db (datashare:open-db configdat)) (area (car args)) (version (cadr args)) ;; iteration (remargs (args:get-args args '("-i") '() args:arg-hash 0)) (iteration (if (args:get-arg "-i")(string->number (args:get-arg "-i")) #f)) (curr-record (datashare:get-pkg db area version iteration: iteration))) (if (not curr-record) (begin (print "ERROR: No matching record found; area=" area ", version=" version ", iteration=" (if iteration iteration "(max)")) (exit 1)) (let* ((stored-path (datashare:pkg-get-stored_path curr-record)) (source-type (datashare:pkg-get-store_type curr-record)) (source-path (case source-type ;; (equal? source-type "link")) ((link) (datashare:pkg-get-source-path curr-record)) ((copy) stored-path) (else #f))) (dest-stub (configf:lookup configdat "areas" area)) (target-path (conc basepath "/" dest-stub))) (datashare:build-dir-make-link stored-path target-path) (datashare:record-pkg-ref db (datashare:pkg-get-id curr-record) target-path) (sqlite3:finalize! db) (print "Creating link from " stored-path " to " target-path)))))) ((publish) (if (< (length args) 3) (begin (print "ERROR: Missing arguments; " (string-intersperse args ", ")) (exit 1)) (let* ((srcpath (list-ref args 0)) (areaname (list-ref args 1)) (version (list-ref args 2)) (remargs (args:get-args (drop args 2) '("-type" ;; link or copy (default is copy) "-m") '() args:arg-hash 0)) (publish-type (if (equal? (args:get-arg "-type") "link") 'link 'copy)) (comment (or (args:get-arg "-m") "")) (submitter (current-user-name)) (quality (args:get-arg "-quality")) (publish-res (datashare:publish configdat publish-type areaname version comment srcpath submitter quality))) (if (not (car publish-res)) (begin (print "ERROR: " (cdr publish-res)) (exit 1)))))) ((list-versions) (let ((area-name (car args)) ;; version patt full print (remargs (args:get-args args '("-vpatt") '("-full") args:arg-hash 0)) (db (datashare:open-db configdat)) (versions (datashare:get-versions-for-area db (car args) version-patt: (args:get-arg "-vpatt")))) ;; (print "area-name=" area-name " args=" args " *args-hash*=" (hash-table->alist *args-hash*)) (map (lambda (x) (if (args:get-arg "-full") (format #t "~10a~10a~4a~27a~30a\n" (vector-ref x 0) (vector-ref x 1) (vector-ref x 2) (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"") (conc "\"" (vector-ref x 4) "\"")) (print (vector-ref x 0)))) versions) (sqlite3:finalize! db))))) ;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION! (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.datasharerc"))) (if (common:file-exists? debugcontrolf) (load debugcontrolf))) (define (main) (let* ((args (argv)) (prog (car args)) (rema (cdr args)) (exe-name (pathname-file (car (argv)))) (exe-dir (or (pathname-directory prog) (datashare:find exe-name (string-split (get-environment-variable "PATH") ":")))) (configdat (datashare:load-config exe-dir exe-name))) (cond ;; one-word commands ((eq? (length rema) 1) (case (string->symbol (car rema)) ((help -h -help --h --help) (print datashare:help)) ((list-areas) (map print (datashare:get-areas configdat))) (else (print "ERROR: Unrecognised command. Try \"datashare help\"")))) ;; multi-word commands ((null? rema)(datashare:gui configdat)) ((>= (length rema) 2) (apply datashare:process-action configdat (car rema)(cdr rema))) (else (print "ERROR: Unrecognised command. Try \"datashare help\""))))) (main) |
Deleted datashare.scm version [2c1663032f].
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Modified db.scm from [ed256dd44f] to [373c9e3316].
︙ | ︙ | |||
1995 1996 1997 1998 1999 2000 2001 | ;; 1. Look at test records either deleted or part of deleted run: ;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown' ;; b. If test dir gone, delete the test record ;; 2. Look at run records ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; | | | 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 | ;; 1. Look at test records either deleted or part of deleted run: ;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown' ;; b. If test dir gone, delete the test record ;; 2. Look at run records ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; #;(define (db:clean-up-rundb dbdat) ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") (let* ((db (db:dbdat-get-db dbdat)) (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);")) (statements (map (lambda (stmt) (sqlite3:prepare db stmt)) (list |
︙ | ︙ | |||
2300 2301 2302 2303 2304 2305 2306 | (lambda (runname) (set! res runname)) db "SELECT runname FROM runs WHERE id=?;" run-id) res)))) | | | 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 | (lambda (runname) (set! res runname)) db "SELECT runname FROM runs WHERE id=?;" run-id) res)))) #;(define (db:get-run-key-val dbstruct run-id key) (db:with-db dbstruct #f #f (lambda (db) (let ((res #f)) (sqlite3:for-each-row |
︙ | ︙ | |||
3319 3320 3321 3322 3323 3324 3325 | 0)))) ;; tags: '("tag%" "tag2" "%ag6") ;; ;; done with run when: ;; 0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING | | | 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 | 0)))) ;; tags: '("tag%" "tag2" "%ag6") ;; ;; done with run when: ;; 0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING #;(define (db:estimated-tests-remaining dbstruct run-id) (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:first-result db |
︙ | ︙ | |||
3450 3451 3452 3453 3454 3455 3456 | (loop (+ new-id 1)) (begin (debug:print-info 0 *default-log-port* "New test id " new-id " selected for test with id " test-id) (sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id))))))) ;; move test ids into the 30k * run_id range ;; | | | | 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 | (loop (+ new-id 1)) (begin (debug:print-info 0 *default-log-port* "New test id " new-id " selected for test with id " test-id) (sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id))))))) ;; move test ids into the 30k * run_id range ;; #;(define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs) (debug:print-info 0 *default-log-port* "Adjusting test ids in megatest.db for run " run-id) (let ((min-test-id (* run-id 30000))) (for-each (lambda (testrec) (let* ((test-id (vector-ref testrec (db:field->number "id" db:test-record-fields)))) (db:adj-test-id (db:dbdat-get-db mtdb) min-test-id test-id))) testrecs))) ;; 1. move test ids into the 30k * run_id range ;; 2. move step ids into the 30k * run_id range ;; #;(define (db:prep-megatest.db-for-migration mtdb) (let* ((run-ids (db:get-all-run-ids mtdb))) (for-each (lambda (run-id) (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id))) (db:prep-megatest.db-adj-test-ids (db:dbdat-get-db mtdb) run-id testrecs))) run-ids))) |
︙ | ︙ |
Modified mt.scm from [e9055c2687] to [283ae4be89].
︙ | ︙ | |||
100 101 102 103 104 105 106 | (if last-time (< (current-seconds)(+ last-time 5)) #f)))) (if useres (let ((result (vector-ref res 1))) (debug:print 4 *default-log-port* "Using lazy value res: " result) result) | | | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 | (if last-time (< (current-seconds)(+ last-time 5)) #f)))) (if useres (let ((result (vector-ref res 1))) (debug:print 4 *default-log-port* "Using lazy value res: " result) result) (let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode itemmaps))) (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres)) newres)))) (define (mt:get-run-stats dbstruct run-id) ;; Get run stats from local access, move this ... but where? (db:get-run-stats dbstruct run-id)) |
︙ | ︙ |
Modified mtut.scm from [ead30f316f] to [88e0c0a24a].
︙ | ︙ | |||
53 54 55 56 57 58 59 | in-stml)))) ;; helpers for mappers/checkers (define (add-target-mapper name proc) (hash-table-set! *target-mappers* name proc)) (define (add-runname-mapper name proc) (hash-table-set! *runname-mappers* name proc)) | | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | in-stml)))) ;; helpers for mappers/checkers (define (add-target-mapper name proc) (hash-table-set! *target-mappers* name proc)) (define (add-runname-mapper name proc) (hash-table-set! *runname-mappers* name proc)) (define (add-area-checker name proc) ;; util, USED EXTERNALLY, do not remove. (hash-table-set! *area-checkers* name proc)) ;; given a runkey, xlatr-key and other info return one of the following: ;; list of targets, null list to skip processing ;; (define (map-targets mtconf aval-alist runkey area contour #!key (xlatr-key-in #f)) (pp aval-alist) |
︙ | ︙ | |||
1690 1691 1692 1693 1694 1695 1696 | (prev-seen (make-hash-table))) ;; catch duplicates (if user-info (begin (for-each (lambda (listener) (let ((host-port (car listener)) (attrib (val->alist (cadr listener)))) | | > | 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 | (prev-seen (make-hash-table))) ;; catch duplicates (if user-info (begin (for-each (lambda (listener) (let ((host-port (car listener)) (attrib (val->alist (cadr listener)))) (if (and (equal? msg "time-to-die") (not (can-user-kill-listner user-info attrib))) (begin (debug:print-error 0 *default-log-port* "User " (car user-info) " is not allowed to send message '" msg"'") (exit 1))) (print "sending " msg " to " host-port ) (open-send-close-nn host-port msg attrib timeout: time-out ))) listeners)) (begin |
︙ | ︙ | |||
1718 1719 1720 1721 1722 1723 1724 | (prev-seen (make-hash-table))) ;; catch duplicates (if user-info (begin (for-each (lambda (listener) (let ((host-port (car listener)) (attrib (val->alist (cadr listener)))) | | > | 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 | (prev-seen (make-hash-table))) ;; catch duplicates (if user-info (begin (for-each (lambda (listener) (let ((host-port (car listener)) (attrib (val->alist (cadr listener)))) (if (and (equal? msg "time-to-die") (not (can-user-kill-listner user-info attrib))) (begin (debug:print-error 0 *default-log-port* "User " (car user-info) " is not allowed to send message '" msg"'") (exit 1))) (print "sending " msg " to " host-port ) (open-send-receive-nn host-port msg attrib timeout: time-out ))) listeners)) (begin |
︙ | ︙ |
Modified rmt.scm from [ed2cbd88f2] to [e8352fc67e].
︙ | ︙ | |||
673 674 675 676 677 678 679 | (define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname) (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt))) (apply append (map (lambda (run-id) (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname))) run-ids)))) | > | | 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 | (define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname) (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt))) (apply append (map (lambda (run-id) (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname))) run-ids)))) ;; NOTE: rmt functions can NEVER have key params as they might be called as local (define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmaps #f)) (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps))) (define (rmt:get-count-tests-running-for-run-id run-id) (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id))) (define (rmt:get-not-completed-cnt run-id) (rmt:send-receive 'get-not-completed-cnt run-id (list run-id))) |
︙ | ︙ |
Modified runs.scm from [2583922f1c] to [78e08647d1].
︙ | ︙ | |||
58 59 60 61 62 63 64 | (last-load-check-time 0) (last-jobs-check-time 0) ) (defstruct runs:testdat hed tal reg reruns test-record test-name item-path jobgroup | | > > > > | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 | (last-load-check-time 0) (last-jobs-check-time 0) ) (defstruct runs:testdat hed tal reg reruns test-record test-name item-path jobgroup waitons testmode newtal itemmaps (prereqs-not-met #f) (last-update 0) ;; ) ;; look in the $MT_RUN_AREA_HOME/.softlocks directory for key-host-pid.softlock files ;; - remove any that are over 3600 seconds old ;; - if there are any that are younger than 10 seconds ;; * sleep 10 seconds ;; * touch my key-host-pid.softlock file ;; * return |
︙ | ︙ | |||
884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 | ;; => review of a previously seen test is higher priority of never visited test ;; reg - list of previously visited tests ;; tal - list of never visited tests ;; prefer next hed to be from reg than tal. (define runs:nothing-left-in-queue-count 0) ;;====================================================================== ;; runs:expand-items is called by runs:run-tests-queue ;;====================================================================== ;; ;; return value of runs:expand-items is passed back to runs-tests-queue and is fed to named loop with this signature: ;; (let loop ((hed (car sorted-test-names)) ;; (tal (cdr sorted-test-names)) ;; (reg '()) ;; registered, put these at the head of tal ;; (reruns '())) | > > > > > > > > > > > > > > > > | > | < < < < < < < | < | 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 | ;; => review of a previously seen test is higher priority of never visited test ;; reg - list of previously visited tests ;; tal - list of never visited tests ;; prefer next hed to be from reg than tal. (define runs:nothing-left-in-queue-count 0) (define (runs:lazy-get-prereqs-not-met testdat run-id waitons hed item-path #!key (mode '(normal))(itemmaps #f)) ;; mode: testmode itemmaps: itemmaps) (if (and (runs:testdat-prereqs-not-met testdat) (< (- (current-seconds) (runs:testdat-last-update testdat)) 10)) ;; only refresh for this test if it has been at least 10 seconds (runs:testdat-prereqs-not-met testdat) (let* ((res (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode itemmaps))) (if (list? res) res (begin (debug:print 0 *default-log-port* "ERROR: rmt:get-prereqs-not-met returned non-list!\n" " res=" res " run-id=" run-id " waitons=" waitons " hed=" hed " item-path=" item-path " testmode=" mode " itemmaps=" itemmaps) '()))))) (runs:testdat-prereqs-not-met-set! testdat res) (runs:testdat-last-update-set! testdat (current-seconds)) res))) ;;====================================================================== ;; runs:expand-items is called by runs:run-tests-queue ;;====================================================================== ;; ;; return value of runs:expand-items is passed back to runs-tests-queue and is fed to named loop with this signature: ;; (let loop ((hed (car sorted-test-names)) ;; (tal (cdr sorted-test-names)) ;; (reg '()) ;; registered, put these at the head of tal ;; (reruns '())) (define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps testdat) (let* ((loop-list (list hed tal reg reruns)) (prereqs-not-met (runs:lazy-get-prereqs-not-met testdat run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) (have-itemized (not (null? (lset-intersection eq? testmode '(itemmatch itemwait))))) (fails (runs:calc-fails prereqs-not-met)) (prereq-fails (runs:calc-prereq-fail prereqs-not-met)) (non-completed (runs:calc-not-completed prereqs-not-met)) (runnables (runs:calc-runnable prereqs-not-met)) (unexpanded-prereqs (filter (lambda (testname) (let* ((test-rec (hash-table-ref test-records testname)) |
︙ | ︙ | |||
1150 1151 1152 1153 1154 1155 1156 | (run-limits-info (runs:dat-can-run-more-tests runsdat)) ;; (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running (have-resources (car run-limits-info)) (num-running (list-ref run-limits-info 1)) (num-running-in-jobgroup(list-ref run-limits-info 2)) (max-concurrent-jobs (list-ref run-limits-info 3)) (job-group-limit (list-ref run-limits-info 4)) | < < | 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 | (run-limits-info (runs:dat-can-run-more-tests runsdat)) ;; (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running (have-resources (car run-limits-info)) (num-running (list-ref run-limits-info 1)) (num-running-in-jobgroup(list-ref run-limits-info 2)) (max-concurrent-jobs (list-ref run-limits-info 3)) (job-group-limit (list-ref run-limits-info 4)) (fails (if (list? prereqs-not-met) ;; TODO: rename fails to failed-prereqs (runs:calc-fails prereqs-not-met) (begin (debug:print-error 0 *default-log-port* "prereqs-not-met is not a list! " prereqs-not-met) '()))) (non-completed (filter (lambda (x) ;; remove hed from not completed list, duh, of course it is not completed! (not (equal? x hed))) |
︙ | ︙ | |||
1551 1552 1553 1554 1555 1556 1557 | registry-mutex: registry-mutex flags: flags keyvals: keyvals run-info: run-info ;; newtal: newtal all-tests-registry: all-tests-registry ;; itemmaps: itemmaps | < | 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 | registry-mutex: registry-mutex flags: flags keyvals: keyvals run-info: run-info ;; newtal: newtal all-tests-registry: all-tests-registry ;; itemmaps: itemmaps ;; can-run-more-tests: (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs) ;; look at the test jobgroup and tot jobs running ))) ;; Initialize the test-registery hash with tests that already have a record ;; convert state to symbol and use that as the hash value (for-each (lambda (trec) (let ((id (db:test-get-id trec)) |
︙ | ︙ | |||
1770 1771 1772 1773 1774 1775 1776 | ;; wait for load here (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) (loop-can-run-more (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs) (- remtries 1))))))) ))))) ;; I'm not clear on why prereqs are gathered here TODO: verfiy this is needed | > > | | 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 | ;; wait for load here (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) (loop-can-run-more (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs) (- remtries 1))))))) ))))) ;; I'm not clear on why prereqs are gathered here TODO: verfiy this is needed (runs:lazy-get-prereqs-not-met testdat run-id waitons hed item-path mode: testmode itemmaps: itemmaps) ;; I'm not clear on why we'd capture running job counts here TODO: verify this is needed (runs:dat-can-run-more-tests-set! runsdat (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)) (let ((loop-list (runs:process-expanded-tests runsdat testdat))) ;; in process-expanded-tests ultimately run:test -> launch-test -> test actually running (if loop-list (apply loop loop-list)))) |
︙ | ︙ | |||
1841 1842 1843 1844 1845 1846 1847 | ;; - but only do that if resources exist to kick off the job ;; EXPAND ITEMS ((or (procedure? items)(eq? items 'have-procedure)) (debug:print-info 4 *default-log-port* "cond branch - " "rtq-4") (let ((can-run-more #f)) ;; (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs))) (if (not can-run-more) #;(and (list? can-run-more) (car can-run-more)) | | | 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 | ;; - but only do that if resources exist to kick off the job ;; EXPAND ITEMS ((or (procedure? items)(eq? items 'have-procedure)) (debug:print-info 4 *default-log-port* "cond branch - " "rtq-4") (let ((can-run-more #f)) ;; (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs))) (if (not can-run-more) #;(and (list? can-run-more) (car can-run-more)) (let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps testdat))) ;; itemized test expanded here (if loop-list (apply loop loop-list) (debug:print-info 4 *default-log-port* " -- Can't expand hed="hed) ) ) ;; if can't run more just loop with next possible test (loop (car newtal)(cdr newtal) reg reruns)))) |
︙ | ︙ |
Deleted sauth-common.scm version [5771575e2e].
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Added sauth-src/sauth-common.scm version [5771575e2e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 | ;; 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/>. ;; Create the sqlite db (define (sauthorize:db-do proc) (if (or (not *db-path*) (not (file-exists? *db-path*))) (begin (print 0 "[database]\nlocation " *db-path* " \n\n Is missing from the config file!") (exit 1))) (if (and *db-path* (directory? *db-path*) (file-read-access? *db-path*)) (let* ((dbpath (conc *db-path* "/sauthorize.db")) (writeable (file-write-access? dbpath)) (dbexists (file-exists? dbpath))) (handle-exceptions exn (begin (print 2 "ERROR: problem accessing db " dbpath ((condition-property-accessor 'exn 'message) exn)) (exit 1)) ;(print "calling proc " proc "db path " dbpath ) (call-with-database dbpath (lambda (db) ;(print 0 "calling proc " proc " on db " db) (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout (if (not dbexists)(sauthorize:initialize-db db)) (proc db))))) (print 0 "ERROR: invalid path for storing database: " *db-path*))) ;;execute a query (define (sauthorize:db-qry db qry) ;(print qry) (exec (sql db qry))) (define (sauthorize:do-as-calling-user proc) (let ((eid (current-effective-user-id)) (cid (current-user-id))) (if (not (eq? eid cid)) ;; running suid (set! (current-effective-user-id) cid)) ;(print 0 "cid " cid " eid:" eid) (proc) (if (not (eq? eid cid)) (set! (current-effective-user-id) eid)))) (define (run-cmd cmd arg-list) ; (print (current-effective-user-id)) ;(handle-exceptions ; exn ; (print 0 "ERROR: failed to run script " cmd " with params " arg-list " " (exn assert)) (let ((pid (process-run cmd arg-list))) (process-wait pid)) ) ;) (define (regster-log inl usr-id area-id cmd) (sauth-common:shell-do-as-adm (lambda () (sauthorize:db-do (lambda (db) (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sretrieve " inl "'," usr-id "," area-id ", 'cat' )"))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Check user types ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;check if a user is an admin (define (is-admin username) (let* ((admin #f)) (sauthorize:db-do (lambda (db) (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM users where users.username = '" username "'"))))) (if (not (null? data-row)) (let ((col (car data-row))) (if (equal? col "yes") (set! admin #t))))))) admin)) ;;check if a user is an read-admin (define (is-read-admin username) (let* ((admin #f)) (sauthorize:db-do (lambda (db) (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM users where users.username = '" username "'"))))) (if (not (null? data-row)) (let ((col (car data-row))) (if (equal? col "read-admin") (set! admin #t))))))) admin)) ;;check if user has specifc role for a area (define (is-user role username area) (let* ((has-access #f)) (sauthorize:db-do (lambda (db) (let* ((data-row (query fetch (sql db (conc "SELECT permissions.access_type, permissions.expiration FROM users , areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "' and areas.code = '" area "'"))))) (if (not (null? data-row)) (begin (let* ((access-type (car data-row)) (exdate (cadr data-row))) (if (not (null? exdate)) (begin (let ((valid (is-access-valid exdate))) ;(print valid) (if (and (equal? access-type role) (equal? valid #t)) (set! has-access #t)))) (print "Access expired")))))))) ;(print has-access) has-access)) (define (is-access-valid exp-str) (let* ((ret-val #f ) (date-parts (string-split exp-str "/")) (yr (string->number (car date-parts))) (month (string->number(car (cdr date-parts)))) (day (string->number(caddr date-parts))) (exp-date (make-date 0 0 0 0 day month yr ))) ;(print exp-date) ;(print (current-date)) (if (> (date-compare exp-date (current-date)) 0) (set! ret-val #t)) ;(print ret-val) ret-val)) ;check if area exists (define (area-exists area) (let* ((area-defined #f)) (sauthorize:db-do (lambda (db) (let* ((data-row (query fetch (sql db (conc "SELECT id FROM areas where areas.code = '" area "'"))))) (if (not (null? data-row)) (set! area-defined #t))))) area-defined)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Get Record from database ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;gets area id by code (define (get-area area) (let* ((area-defined '())) (sauthorize:db-do (lambda (db) (let* ((data-row (query fetch (sql db (conc "SELECT id FROM areas where areas.code = '" area "'"))))) (set! area-defined data-row)))) area-defined)) ;get id of users table by user name (define (get-user user) (let* ((user-defined '())) (sauthorize:db-do (lambda (db) (let* ((data-row (query fetch (sql db (conc "SELECT id FROM users where users.username = '" user "'"))))) (set! user-defined data-row)))) user-defined)) ;get permissions id by userid and area id (define (get-perm userid areaid) (let* ((user-defined '())) (sauthorize:db-do (lambda (db) (let* ((data-row (query fetch (sql db (conc "SELECT id FROM permissions where user_id = " userid " and area_id = " areaid))))) (set! user-defined data-row)))) user-defined)) (define (get-restrictions base-path usr) (let* ((user-defined '())) (sauthorize:db-do (lambda (db) (let* ((data-row (query fetch (sql db (conc "SELECT restriction FROM areas, users, permissions where areas.id = permissions.area_id and users.id = permissions.user_id and users.username = '" usr "' and areas.basepath = '" base-path "'"))))) ;(print data-row) (set! user-defined data-row)))) ; (print user-defined) (if (null? user-defined) "" (car user-defined)))) (define (get-obj-by-path path) (let* ((obj '())) (sauthorize:db-do (lambda (db) (let* ((data-row (query fetch (sql db (conc "SELECT code,exe_name, id, basepath FROM areas where areas.basepath = '" path "'"))))) (set! obj data-row)))) obj)) (define (get-obj-by-code code ) (let* ((obj '())) (sauthorize:db-do (lambda (db) ;(print (conc "SELECT code, exe_name, id, basepath, required_grps FROM areas where areas.code = '" code "'")) (let* ((data-row (query fetch (sql db (conc "SELECT code, exe_name, id, basepath, required_grps FROM areas where areas.code = '" code "'"))))) ;(print data-row) (set! obj data-row) ;(print obj) ))) (if (not (null? obj)) (begin (let* ((req-grp (caddr (cddr obj)))) (sauthorize:do-as-calling-user (lambda () (sauth-common:check-user-groups req-grp)))))) obj)) (define (sauth-common:check-user-groups req-grp) (let* ((current-groups (get-groups) ) (req-grp-list (string-split req-grp ","))) ;(print req-grp-list) (for-each (lambda (grp) (let ((grp-info (group-information grp))) ;(print grp-info " " grp) (if (not (equal? grp-info #f)) (begin (if (not (member (caddr grp-info) current-groups)) (begin (sauth:print-error (conc "Please wash " grp " group in your xterm!! " )) (exit 1))))))) req-grp-list))) (define (get-obj-by-code-no-grp-validation code ) (let* ((obj '())) (sauthorize:db-do (lambda (db) (let* ((data-row (query fetch (sql db (conc "SELECT code, exe_name, id, basepath FROM areas where areas.code = '" code "'"))))) (set! obj data-row)))) ;(print obj) obj)) (define (sauth-common:src-size path) (let ((output (with-input-from-pipe (conc "/usr/bin/du -s " path " | awk '{print $1}'") (lambda() (read-line))))) (string->number output))) (define (sauth-common:space-left-at-dest path) (let* ((output (run/string (pipe (df ,path ) (tail -1)))) (size (caddr (cdr (string-split output " "))))) (string->number size))) ;; function to validate the users input for target path and resolve the path ;; TODO: Check for restriction in subpath (define (sauth-common:resolve-path new current allowed-sheets) (let* ((target-path (append current (string-split new "/"))) (target-path-string (string-join target-path "/")) (normal-path (normalize-pathname target-path-string)) (normal-list (string-split normal-path "/")) (ret '())) (if (string-contains normal-path "..") (begin (print "ERROR: Path " new " resolved outside target area ") #f) (if(equal? normal-path ".") ret (if (not (member (car normal-list) allowed-sheets)) (begin (print "ERROR: Permision denied to " new ) #f) normal-list))))) (define (sauth-common:get-target-path base-path-list ext-path top-areas base-path) (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas )) (usr (current-user-name) ) ) (if (not (equal? resolved-path #f)) (if (null? resolved-path) #f (let* ((sheet (car resolved-path)) (restricted-areas (get-restrictions base-path usr)) (restrictions (conc ".*" (string-join (string-split restricted-areas ",") ".*|.*") ".*")) (target-path (if (null? (cdr resolved-path)) base-path (conc base-path "/" (string-join (cdr resolved-path) "/"))))) (if (and (not (equal? restricted-areas "" )) (string-match (regexp restrictions) target-path)) (begin (sauth:print-error (conc "Access denied to " (string-join resolved-path "/"))) ;(exit 1) #f) target-path) )) #f))) (define (sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list) (if (and (null? base-path-list) (equal? ext-path "") ) (print (string-intersperse top-areas " ")) (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas ))) ;(print resolved-path) (if (not (equal? resolved-path #f)) (if (null? resolved-path) (print (string-intersperse top-areas " ")) (let* ((target-path (sauth-common:get-target-path base-path-list ext-path top-areas base-path))) (print target-path) (if (not (equal? target-path #f)) (begin (cond ((null? tail-cmd-list) (run (pipe (ls "-lrt" ,target-path)))) ((not (equal? (car tail-cmd-list) "|")) (print "ls cmd cannot accept " (string-join tail-cmd-list) " as an argument!!")) (else (run (pipe (ls "-lrt" ,target-path) (begin (system (string-join (cdr tail-cmd-list)))))))))))))))) (define (sauth:print-error msg) (with-output-to-port (current-error-port) (lambda () (print (conc "ERROR: " msg))))) |
Added sauth-src/sauthorize.scm version [b4d2f08e65].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 | ;; Copyright 2006-2013, 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/>. ;; (use defstruct) (use scsh-process) (use srfi-18) (use srfi-19) (use refdb) (use sql-de-lite srfi-1 posix regex regex-case srfi-69) ;(declare (uses common)) ;(declare (uses configf)) (declare (uses margs)) (include "megatest-version.scm") (include "megatest-fossil-hash.scm") ;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm. (include "sauth-paths.scm") (include "sauth-common.scm") ;; ;; GLOBALS ;; (define *verbosity* 1) (define *logging* #f) (define *exe-name* (pathname-file (car (argv)))) (define *sretrieve:current-tab-number* 0) (define *args-hash* (make-hash-table)) (define sauthorize:help (conc "Usage: " *exe-name* " [action [params ...]] list : list areas $USER's can access log : get listing of recent activity. sauth list-area-user <area code> : list the users that can access the area. sauth open <path> --group <grpname> : Open up an area. User needs to be the owner of the area to open it. --code <unique short identifier for an area> --retrieve|--publish [--additional-grps <comma separated unix grps requierd to get to the path>] sauth update <area code> --retrieve|--publish : update the binaries with the lates changes sauth grant <username> --area <area identifier> : Grant permission to read or write to a area that is alrady opend up. --expiration yyyy/mm/dd --retrieve|--publish [--restrict <comma separated directory names> ] sauth read-shell <area identifier> : Open sretrieve shell for reading. sauth write-shell <area identifier> : Open spublish shell for writing. Part of the Megatest tool suite. Learn more at http://www.kiatoa.com/fossils/megatest Version: " megatest-fossil-hash)) ;; " ;;====================================================================== ;; RECORDS ;;====================================================================== ;;====================================================================== ;; DB ;;====================================================================== ;; replace (strftime('%s','now')), with datetime('now')) (define (sauthorize:initialize-db db) (for-each (lambda (qry) (exec (sql db qry))) (list "CREATE TABLE IF NOT EXISTS actions (id INTEGER PRIMARY KEY, cmd TEXT NOT NULL, user_id INTEGER NOT NULL, datetime TIMESTAMP DEFAULT (datetime('now','localtime')), area_id INTEGER NOT NULL, comment TEXT DEFAULT '' NOT NULL, action_type TEXT NOT NULL);" "CREATE TABLE IF NOT EXISTS users (id INTEGER PRIMARY KEY, username TEXT NOT NULL, is_admin TEXT NOT NULL, datetime TIMESTAMP DEFAULT (datetime('now','localtime')) );" "CREATE TABLE IF NOT EXISTS areas (id INTEGER PRIMARY KEY, basepath TEXT NOT NULL, code TEXT NOT NULL, exe_name TEXT NOT NULL, required_grps TEXT DEFAULT '' NOT NULL, datetime TIMESTAMP DEFAULT (datetime('now','localtime')) );" "CREATE TABLE IF NOT EXISTS permissions (id INTEGER PRIMARY KEY, access_type TEXT NOT NULL, user_id INTEGER NOT NULL, datetime TIMESTAMP DEFAULT (datetime('now','localtime')), area_id INTEGER NOT NULL, restriction TEXT DEFAULT '' NOT NULL, expiration TIMESTAMP DEFAULT NULL);" ))) (define (get-access-type args) (let loop ((hed (car args)) (tal (cdr args))) (cond ((equal? hed "--retrieve") "retrieve") ((equal? hed "--publish") "publish") ((equal? hed "--area-admin") "area-admin") ((equal? hed "--writer-admin") "writer-admin") ((equal? hed "--read-admin") "read-admin") ((null? tal) #f) (else (loop (car tal)(cdr tal)))))) ;; check if user can gran access to an area (define (can-grant-perm username access-type area) (let* ((isadmin (is-admin username)) (is-area-admin (is-user "area-admin" username area )) (is-read-admin (is-user "read-admin" username area) ) (is-writer-admin (is-user "writer-admin" username area) ) ) (cond ((equal? isadmin #t) #t) ((equal? is-area-admin #t ) #t) ((and (equal? is-writer-admin #t ) (equal? access-type "retrieve")) #t) ((and (equal? is-read-admin #t ) (equal? access-type "retrieve")) #t) (else #f)))) (define (sauthorize:list-areausers area ) (sauthorize:db-do (lambda (db) (print "Users having access to " area ":") (query (for-each-row (lambda (row) (let* ((exp-date (cadr row))) (if (is-access-valid exp-date) (apply print (intersperse row " | ")))))) (sql db (conc "SELECT users.username, permissions.expiration, permissions.access_type FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and areas.code = '" area "'")))))) ; check if executable exists (define (exe-exist exe access-type) (let* ((filepath (conc *exe-path* "/" access-type "/" exe))) ; (print filepath) (if (file-exists? filepath) #t #f))) (define (copy-exe access-type exe-name group) (run-cmd "/bin/chmod" (list "g+w" (conc *exe-path* "/" access-type))) (let* ((spath (conc *exe-src* "/s" access-type)) (dpath (conc *exe-path* "/" access-type "/" exe-name))) (sauthorize:do-as-calling-user (lambda () (run-cmd "/bin/cp" (list spath dpath )) (if (equal? access-type "publish") (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath)) (begin (if (equal? group "none") (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath)) (begin (run-cmd "/bin/chgrp" (list group dpath)) (run-cmd "/bin/chmod" (list "g+s,o+rx" dpath)))))))) (run-cmd "chmod" (list "g-w" (conc *exe-path* "/" access-type))))) (define (get-exe-name path group) (let ((name "")) (sauthorize:do-as-calling-user (lambda () (if (equal? (current-effective-user-id) (file-owner path)) (set! name (conc (current-user-name) "_" group)) (begin (print "You cannot open areas that you dont own!!") (exit 1))))) name)) (define (sauthorize:valid-unix-user username) (let* ((ret-val #f)) (let-values (((inp oup pid) (process "/usr/bin/id" (list username)))) (let loop ((inl (read-line inp))) (if (string? inl) (if (string-contains inl "No such user") (set! ret-val #f) (set! ret-val #t))) (if (eof-object? inl) (begin (close-input-port inp) (close-output-port oup)) (loop (read-line inp))))) ret-val)) ;check if a paths/codes are vaid and if area is alrady open (define (open-area group path code access-type other-grps) (let* ((exe-name (get-exe-name path group)) (path-obj (get-obj-by-path path)) (code-obj (get-obj-by-code-no-grp-validation code))) ;(print path-obj) (cond ((not (null? path-obj)) (if (equal? code (car path-obj)) (begin (if (equal? exe-name (cadr path-obj)) (begin (if (not (exe-exist exe-name access-type)) (copy-exe access-type exe-name group) (begin (print "Area already open!!") (exit 1)))) (begin (if (not (exe-exist exe-name access-type)) (copy-exe access-type exe-name group)) ;; update exe-name in db (sauthorize:db-do (lambda (db) (sauthorize:db-qry db (conc "update areas set exe_name = '" exe-name "' where id = " (caddr path-obj))))) ))) (begin (print "Path " path " is registered with --code " (car path-obj) ". To open this area please execute following cmd: \n sauthorize open " path " --group " group " --code " (car path-obj) " --" access-type ) (exit 1)))) ((not (null? code-obj)) (print "Code " code " is used for diffrent path. Please try diffrent value of --code" ) (exit 1)) (else ; (print (exe-exist exe-name access-type)) (if (not (exe-exist exe-name access-type)) (copy-exe access-type exe-name group)) (sauthorize:db-do (lambda (db) (print conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') ") (sauthorize:db-qry db (conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') ")))))))) (define (user-has-open-perm user path access) (let* ((has-access #f) (eid (current-user-id))) (cond ((is-admin user) (set! has-access #t )) ((and (is-read-admin user) (equal? access "retrieve")) (set! has-access #t )) (else (print "User " user " does not have permission to open areas"))) has-access)) ;;check if user has group access (define (is-group-washed req_grpid current-grp-list) (let loop ((hed (car current-grp-list)) (tal (cdr current-grp-list))) (cond ((equal? hed req_grpid) #t) ((null? tal) #f) (else (loop (car tal)(cdr tal)))))) ;create executables with appropriate suids (define (sauthorize:open user path group code access-type other-groups) (let* ((gpid (group-information group)) (req_grpid (if (equal? group "none") group (if (equal? gpid #f) #f (caddr gpid)))) (current-grp-list (get-groups)) (valid-grp (if (equal? group "none") group (is-group-washed req_grpid current-grp-list)))) (if (and (not (equal? group "none")) (equal? valid-grp #f )) (begin (print "Group " group " is not washed in the current xterm!!") (exit 1)))) (if (not (file-write-access? path)) (begin (print "You can open areas owned by yourself. You do not have permissions to open path." path) (exit 1))) (if (user-has-open-perm user path access-type) (begin ;(print "here") (open-area group path code access-type other-groups) (sauthorize:grant user user code "2017/12/25" "read-admin" "") (sauthorize:db-do (lambda (db) (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize open " path " --code " code " --group " group " --" access-type "'," (car (get-user user)) "," (car (get-area code)) ", 'open' )")))) (print "Area has " path " been opened for " access-type )))) (define (sauthorize:update username exe area access-type) (let* ((parts (string-split exe "_")) (owner (car parts)) (group (cadr parts)) (gpid (group-information group)) (req_grpid (if (equal? group "none") group (if (equal? gpid #f) #f (caddr gpid)))) (current-grp-list (get-groups)) (valid-grp (if (equal? group "none") group (is-group-washed req_grpid current-grp-list)))) (if (not (equal? username owner)) (begin (print "You cannot update " area ". Only " owner " can update this area!!") (exit 1))) (copy-exe access-type exe group) (print "recording action..") (sauthorize:db-do (lambda (db) (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize update " area " --" access-type "'," (car (get-user username)) "," (car (get-area area)) ", 'update' )")))) (print "Area has " area " been update!!" ))) (define (sauthorize:grant auser guser area exp-date access-type restrict) ; check if user exist in db (let* ((area-obj (get-area area)) (auser-obj (get-user auser)) (user-obj (get-user guser))) (if (null? user-obj) (begin ;; is guser a valid unix user (if (not (sauthorize:valid-unix-user guser)) (begin (print "User " guser " is Invalid unix user!!") (exit 1))) (sauthorize:db-do (lambda (db) (sauthorize:db-qry db (conc "insert into users (username, is_admin) values ('" guser "', 'no') ")))) (set! user-obj (get-user guser)))) (let* ((perm-obj (get-perm (car user-obj) (car area-obj)))) (if(null? perm-obj) (begin ;; insert permissions (sauthorize:db-do (lambda (db) (sauthorize:db-qry db (conc "insert into permissions (access_type, user_id, area_id, restriction, expiration ) values ('" access-type "', " (car user-obj) ", " (car area-obj) ", '" restrict "', '" exp-date "')"))))) (begin ;update permissions (sauthorize:db-do (lambda (db) (sauthorize:db-qry db (conc "update permissions set access_type = '" access-type "' , restriction = '" restrict "', expiration = '" exp-date "' where user_id = " (car user-obj) " and area_id = " (car area-obj))))))) (sauthorize:db-do (lambda (db) (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize grant " guser " --area " area " --expiration " exp-date " --" access-type " --restrict " restrict "'," (car auser-obj) "," (car area-obj) ", 'grant' )")))) (print "Permission has been sucessfully granted to user " guser)))) (define (sauthorize:process-action username action . args) (case (string->symbol action) ((grant) (if (< (length args) 6) (begin (print "ERROR: Missing arguments; " (string-intersperse args ", ")) (exit 1))) (let* ((remargs (args:get-args args '("--area" "--expiration" "--restrict") '() args:arg-hash 0)) (guser (car args)) (restrict (or (args:get-arg "--restrict") "")) (area (or (args:get-arg "--area") "")) (exp-date (or (args:get-arg "--expiration") "")) (access-type (get-access-type remargs))) ; (print "version " guser " restrict " restrict ) ; (print "area " area " exp-date " exp-date " access-type " access-type) (cond ((equal? guser "") (print "Username not found!! Try \"sauthorize help\" for useage ") (exit 1)) ((equal? area "") (print "Area not found!! Try \"sauthorize help\" for useage ") (exit 1)) ((equal? access-type #f) (print "Access type not found!! Try \"sauthorize help\" for useage ") (exit 1)) ((equal? exp-date "") (print "Date of expiration not found!! Try \"sauthorize help\" for useage ") (exit 1))) (if (not (area-exists area)) (begin (print "Area does not exisit!!") (exit 1))) (if (can-grant-perm username access-type area) (begin (print "calling sauthorize:grant ") (sauthorize:grant username guser area exp-date access-type restrict)) (begin (print "User " username " does not have permission to grant permissions to area " area "!!") (exit 1))))) ((list-area-user) (if (not (equal? (length args) 1)) (begin (print "Missing argument area code to list-area-user ") (exit 1))) (let* ((area (car args))) (if (not (area-exists area)) (begin (print "Area does not exisit!!") (exit 1))) (sauthorize:list-areausers area ) )) ((read-shell) (if (not (equal? (length args) 1)) (begin (print "Missing argument area code to read-shell ") (exit 1))) (let* ((area (car args)) (code-obj (get-obj-by-code area))) (if (or (null? code-obj) (not (exe-exist (cadr code-obj) "retrieve"))) (begin (print "Area " area " is not open for reading!!") (exit 1))) (sauthorize:do-as-calling-user (lambda () (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (list "shell" area )))))) ((write-shell) (if (not (equal? (length args) 1)) (begin (print "Missing argument area code to read-shell ") (exit 1))) (let* ((area (car args)) (code-obj (get-obj-by-code area))) (if (or (null? code-obj) (not (exe-exist (cadr code-obj) "publish"))) (begin (print "Area " area " is not open for Writing!!") (exit 1))) (sauthorize:do-as-calling-user (lambda () (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (list "shell" area)))))) ((publish) (if (< (length args) 2) (begin (print "Missing argument to publish. \n publish <action> <area> [opts] ") (exit 1))) (let* ((action (car args)) (area (cadr args)) (cmd-args (cddr args)) (code-obj (get-obj-by-code area))) ;(print "area " area) ;(print "code: " code-obj) ;(print (exe-exist (cadr code-obj) "publish")) (if (or (null? code-obj) (not (exe-exist (cadr code-obj) "publish"))) (begin (print "Area " area " is not open for writing!!") (exit 1))) ;(print "hear") (sauthorize:do-as-calling-user (lambda () ; (print *exe-path* "/publish/" (cadr code-obj) action area cmd-args ) (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (append (list action area ) cmd-args)))))) ((retrieve) (if (< (length args) 2) (begin (print "Missing argument to publish. \n publish <action> <area> [opts] ") (exit 1))) (let* ((action (car args)) (area (cadr args)) (cmd-args (cddr args)) (code-obj (get-obj-by-code area))) (if (or (null? code-obj) (not (exe-exist (cadr code-obj) "retrieve"))) (begin (print "Area " area " is not open for reading!!") (exit 1))) ;(print (conc *exe-path* "/retrieve/" (cadr code-obj) " " action " " area " " (string-join cmd-args))) (sauthorize:do-as-calling-user (lambda () (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (append (list action area ) cmd-args)))))) ((open) (if (< (length args) 6) (begin (print "sauthorize open cmd takes 6 arguments!! \n Useage: sauthorize open <path> --group <grpname> --code <unique short identifier for an area> --retrieve|--publish") (exit 1))) (let* ((remargs (args:get-args args '("--group" "--code" "--additional-grps") '() args:arg-hash 0)) (path (car args)) (group (or (args:get-arg "--group") "")) (area (or (args:get-arg "--code") "")) (other-grps (or (args:get-arg "--additional-grps") "")) (access-type (get-access-type remargs))) (cond ((equal? path "") (print "path not found!! Try \"sauthorize help\" for useage ") (exit 1)) ((equal? area "") (print "--code not found!! Try \"sauthorize help\" for useage ") (exit 1)) ((equal? access-type #f) (print "Access type not found!! Try \"sauthorize help\" for useage ") (exit 1)) ((and (not (equal? access-type "publish")) (not (equal? access-type "retrieve"))) (print "Access type can be eiter --retrieve or --publish !! Try \"sauthorize help\" for useage ") (exit 1))) ; (print other-grps) (sauthorize:open username path group area access-type other-grps))) ((update) (if (< (length args) 2) (begin (print "sauthorize update cmd takes 2 arguments!! \n Useage: sauthorize update <area-code> --retrieve|--publish") (exit 1))) (let* ((area (car args)) (code-obj (get-obj-by-code area)) (access-type (get-access-type (cdr args)))) (if (and (not (equal? access-type "publish")) (not (equal? access-type "retrieve"))) (begin (print "Access type can be --retrieve|--publish ") (exit 1))) (if (or (null? code-obj) (not (exe-exist (cadr code-obj) access-type))) (begin (print "Area " area " is not open for reading!!") (exit 1))) (sauthorize:update username (cadr code-obj) area access-type ))) ((area-admin) (let* ((usr (car args)) (usr-obj (get-user usr)) (user-id (car (get-user username)))) (if (is-admin username) (begin ; (print usr-obj) (if (null? usr-obj) (begin (sauthorize:db-do (lambda (db) ;(print (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )")) (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )"))))) (begin ; (print (conc "update users set is_admin = 'no' where id = " (car usr-obj) )) (sauthorize:db-do (lambda (db) (sauthorize:db-qry db (conc "update users set is_admin = 'read-admin' where id = " (car usr-obj))))))) (print "User " usr " is updated with area-admin access!")) (print "Admin only function")) (sauthorize:db-do (lambda (db) (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('area-admin " usr " ', " user-id ",0, 'area-admin ')" )))))) ((mk-admin) (let* ((usr (car args)) (usr-obj (get-user usr)) (user-id (car (get-user username)))) (if (not (sauthorize:valid-unix-user usr)) (begin (print "User " usr " is Invalid unix user!!") (exit 1))) (if (member username *super-users*) (begin (if (null? usr-obj) (begin (sauthorize:db-do (lambda (db) (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'yes' )"))))) (begin (sauthorize:db-do (lambda (db) (sauthorize:db-qry db (conc "update users set is_admin = 'yes' where id = " (car usr-obj))))))) (print "User " usr " is updated with admin access!")) (print "Super-Admin only function")) (sauthorize:db-do (lambda (db) (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('mk-admin " usr " ', " user-id ",0, 'mk-admin ')" )))))) ((register-log) (if (< (length args) 4) (print "Invalid arguments")) ;(print args) (let* ((cmd-line (car args)) (user-id (cadr args)) (area-id (caddr args)) (user-obj (get-user username)) (cmd (cadddr args))) (if (and (not (null? user-obj)) (equal? user-id (number->string(car user-obj)))) (begin (sauthorize:db-do (lambda (db) (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('" cmd-line"', " user-id "," area-id ", '" cmd "')" ))))) (print "You ar not authorised to run this cmd") ))) (else (print 0 "Unrecognised command " action)))) (define (main) (let* ((args (argv)) (prog (car args)) (rema (cdr args)) (username (current-user-name))) ;; preserve the exe data in the config file (cond ;; one-word commands ((eq? (length rema) 1) (case (string->symbol (car rema)) ((help -h -help --h --help) (print sauthorize:help)) ((list) (sauthorize:db-do (lambda (db) (print "My Area accesses: ") (query (for-each-row (lambda (row) (let* ((exp-date (car row))) (if (is-access-valid exp-date) (apply print (intersperse (cdr row) " | ")))))) (sql db (conc "SELECT permissions.expiration, areas.basepath, areas.code, permissions.access_type FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "'")))))) ((log) (sauthorize:db-do (lambda (db) (print "Logs : ") (query (for-each-row (lambda (row) (apply print (intersperse row " | ")))) (sql db "SELECT actions.cmd, users.username, actions.action_type, actions.datetime, areas.code FROM actions, users, areas where actions.user_id = users.id and actions.area_id = areas.id "))))) (else (print "ERROR: Unrecognised command. Try \"sauthorize help\"")))) ;; multi-word commands ((null? rema)(print sauthorize:help)) ((>= (length rema) 2) (apply sauthorize:process-action username (car rema)(cdr rema))) (else (debug:print 0 "ERROR: Unrecognised command. Try \"sauthorize help\""))))) (main) |
Deleted sauthorize.scm version [b4d2f08e65].
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Modified server.scm from [5b645d5dff] to [53d68f7e36].
︙ | ︙ | |||
33 34 35 36 37 38 39 | ;;(declare (uses rpc-transport)) (declare (uses launch)) ;; (declare (uses daemon)) (include "common_records.scm") (include "db_records.scm") | | | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | ;;(declare (uses rpc-transport)) (declare (uses launch)) ;; (declare (uses daemon)) (include "common_records.scm") (include "db_records.scm") #;(define (server:make-server-url hostport) (if (not hostport) #f (conc "http://" (car hostport) ":" (cadr hostport)))) (define *server-loop-heart-beat* (current-seconds)) ;;====================================================================== |
︙ | ︙ | |||
357 358 359 360 361 362 363 | #f) (match-let (((mod-time host port start-time server-id pid) servr)) (if (and host port) (conc host ":" port) #f)))) | | | 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 | #f) (match-let (((mod-time host port start-time server-id pid) servr)) (if (and host port) (conc host ":" port) #f)))) #;(define (server:get-client-signature) ;; BB> why is this proc named "get-"? it returns nothing -- set! has not return value. (if *my-client-signature* *my-client-signature* (let ((sig (server:mk-signature))) (set! *my-client-signature* sig) *my-client-signature*))) ;; wait for server=start-last to be three seconds old ;; |
︙ | ︙ |
Deleted show-uncalled-procedures.scm version [0afd5cabda].
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Modified tasks.scm from [a73c5b318e] to [e04991d46c].
︙ | ︙ | |||
177 178 179 180 181 182 183 | ;; Server and client management ;;====================================================================== ;; make-vector-record tasks hostinfo id interface port pubport transport pid hostname (define (tasks:hostinfo-get-id vec) (vector-ref vec 0)) (define (tasks:hostinfo-get-interface vec) (vector-ref vec 1)) (define (tasks:hostinfo-get-port vec) (vector-ref vec 2)) | | | | 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 | ;; Server and client management ;;====================================================================== ;; make-vector-record tasks hostinfo id interface port pubport transport pid hostname (define (tasks:hostinfo-get-id vec) (vector-ref vec 0)) (define (tasks:hostinfo-get-interface vec) (vector-ref vec 1)) (define (tasks:hostinfo-get-port vec) (vector-ref vec 2)) ;; (define (tasks:hostinfo-get-pubport vec) (vector-ref vec 3)) (define (tasks:hostinfo-get-transport vec) (vector-ref vec 4)) ;; (define (tasks:hostinfo-get-pid vec) (vector-ref vec 5)) (define (tasks:hostinfo-get-hostname vec) (vector-ref vec 6)) (define (tasks:need-server run-id) (equal? (configf:lookup *configdat* "server" "required") "yes")) ;; no elegance here ... ;; |
︙ | ︙ |
Modified tdb.scm from [6edff6262d] to [107bd93069].
︙ | ︙ | |||
373 374 375 376 377 378 379 | (< (tdb:step-get-id a) (tdb:step-get-id b))) (else #f))))) res)) ;; ;; Move to steps.scm ;; | | | 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 | (< (tdb:step-get-id a) (tdb:step-get-id b))) (else #f))))) res)) ;; ;; Move to steps.scm ;; #;(define (tdb:get-compressed-steps comprsteps) ;; from tdb:get-steps-table (map (lambda (x) ;; take advantage of the \n on time->string (vector (vector-ref x 0) (let ((s (vector-ref x 1))) (if (number? s)(seconds->time-string s) s)) (let ((s (vector-ref x 2))) |
︙ | ︙ |
Deleted trackback.scm version [b547b4460b].
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Added utils/Makefile.utils version [df13f8bb7e].
> > > > > > > | 1 2 3 4 5 6 7 | all : show-uncalled-procedures trackback show-uncalled-procedures : show-uncalled-procedures.scm codescanlib.scm csc show-uncalled-procedures.scm trackback : trackback.scm codescanlib.scm csc trackback.scm |
Added utils/codescanlib.scm version [6e625610ce].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 | ;; 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/>. ;; ;; gotta compile with csc, doesn't work with csi -s for whatever reason (use srfi-69) (use matchable) (use utils) (use ports) (use extras) (use srfi-1) (use posix) (use srfi-12) ;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define (<procname> <args>) <body> ) (define (load-scm-file scm-file) ;;(print "load "scm-file) (handle-exceptions exn '() (with-input-from-string (conc "(" (with-input-from-file scm-file read-all) ")" ) read))) ;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file ;; -- be advised: ;; * this may be fooled by macros, since this code does not take them into account. ;; * this code does only checks for form (define (<procname> ... ) <body>) ;; so it excludes from reckoning ;; - generated functions, as in things like foo-set! from defstructs, ;; - define-inline, ( ;; - define procname (lambda .. ;; - etc... (define (get-toplevel-procs+file+args+body filename) (let* ((scm-tree (load-scm-file filename)) (procs (filter identity (map (match-lambda [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ... [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ... [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ... [('define (defname args ...) body ...) ;; match (define (procname <args>) <body>) (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??) (list defname filename args body) #f)] [else #f] ) scm-tree)))) procs)) ;; given a sexp, return a flat list of atoms in that sexp (define (get-atoms-in-body body) (cond ((null? body) '()) ((atom? body) (list body)) (else (apply append (map get-atoms-in-body body))))) ;; given a file, return a list of procname, file, list of atoms in said procname (define (get-procs+file+atoms file) (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file)) (res (map (lambda (item) (let* ((proc (car item)) (file (cadr item)) (args (caddr item)) (body (cadddr item)) (atoms (append (get-atoms-in-body args) (get-atoms-in-body body)))) (list proc file atoms))) toplevel-proc-items))) res)) ;; uniquify a list of atoms (define (unique-atoms lst) (let loop ((lst (flatten lst)) (res '())) (if (null? lst) (reverse res) (let ((c (car lst))) (loop (cdr lst) (if (member c res) res (cons c res))))))) ;; given a list of procname, filename, list of procs called from procname, cross reference and reverse ;; returning alist mapping procname to procname that calls said procname (define (get-callers-alist all-procs+file+calls) (let* ((all-procs (map car all-procs+file+calls)) (caller-ht (make-hash-table))) ;; let's cross reference with a hash table (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs) (for-each (lambda (item) (let* ((proc (car item)) (file (cadr item)) (calls (caddr item))) (for-each (lambda (callee) (hash-table-set! caller-ht callee (cons proc (hash-table-ref caller-ht callee)))) calls))) all-procs+file+calls) (map (lambda (x) (let ((k (car x)) (r (unique-atoms (cdr x)))) (cons k r))) (hash-table->alist caller-ht)))) ;; create a handy cross-reference of callees to callers in the form of an alist. (define (get-xref all-scm-files) (let* ((all-procs+file+atoms (apply append (map get-procs+file+atoms all-scm-files))) (all-procs (map car all-procs+file+atoms)) (all-procs+file+calls ; proc calls things in calls list (map (lambda (item) (let* ((proc (car item)) (file (cadr item)) (atoms (caddr item)) (calls (filter identity (map (lambda (x) (if (and ;; (not (equal? x proc)) ;; uncomment to prevent listing self (member x all-procs)) x #f)) atoms)))) (list proc file calls))) all-procs+file+atoms)) (callers (get-callers-alist all-procs+file+calls))) callers)) |
Added utils/show-uncalled-procedures.scm version [9e9d6c8594].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 | ;; 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/>. ;; ;; gotta compile with csc, doesn't work with csi -s for whatever reason (use srfi-69) (use matchable) (use utils) (use ports) (use extras) (use srfi-1) (use posix) (use srfi-12) ;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define (<procname> <args>) <body> ) (define (load-scm-file scm-file) ;;(print "load "scm-file) (handle-exceptions exn '() (with-input-from-string (conc "(" (with-input-from-file scm-file read-all) ")" ) read))) ;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file ;; -- be advised: ;; * this may be fooled by macros, since this code does not take them into account. ;; * this code does only checks for form (define (<procname> ... ) <body>) ;; so it excludes from reckoning ;; - generated functions, as in things like foo-set! from defstructs, ;; - define-inline, ( ;; - define procname (lambda .. ;; - etc... (define (get-toplevel-procs+file+args+body filename) (let* ((scm-tree (load-scm-file filename)) (procs (filter identity (map (match-lambda [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ... [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ... [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ... [('define (defname args ...) body ...) ;; match (define (procname <args>) <body>) (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??) (list defname filename args body) #f)] [else #f] ) scm-tree)))) procs)) ;; given a sexp, return a flat list of atoms in that sexp (define (get-atoms-in-body body) (cond ((null? body) '()) ((atom? body) (list body)) (else (apply append (map get-atoms-in-body body))))) ;; given a file, return a list of procname, file, list of atoms in said procname (define (get-procs+file+atoms file) (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file)) (res (map (lambda (item) (let* ((proc (car item)) (file (cadr item)) (args (caddr item)) (body (cadddr item)) (atoms (append (get-atoms-in-body args) (get-atoms-in-body body)))) (list proc file atoms))) toplevel-proc-items))) res)) ;; uniquify a list of atoms (define (unique-atoms lst) (let loop ((lst (flatten lst)) (res '())) (if (null? lst) (reverse res) (let ((c (car lst))) (loop (cdr lst) (if (member c res) res (cons c res))))))) ;; given a list of procname, filename, list of procs called from procname, cross reference and reverse ;; returning alist mapping procname to procname that calls said procname (define (get-callers-alist all-procs+file+calls) (let* ((all-procs (map car all-procs+file+calls)) (caller-ht (make-hash-table))) ;; let's cross reference with a hash table (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs) (for-each (lambda (item) (let* ((proc (car item)) (file (cadr item)) (calls (caddr item))) (for-each (lambda (callee) (hash-table-set! caller-ht callee (cons proc (hash-table-ref caller-ht callee)))) calls))) all-procs+file+calls) (map (lambda (x) (let ((k (car x)) (r (unique-atoms (cdr x)))) (cons k r))) (hash-table->alist caller-ht)))) ;; create a handy cross-reference of callees to callers in the form of an alist. (define (get-xref all-scm-files) (let* ((all-procs+file+atoms (apply append (map get-procs+file+atoms all-scm-files))) (all-procs (map car all-procs+file+atoms)) (all-procs+file+calls ; proc calls things in calls list (map (lambda (item) (let* ((proc (car item)) (file (cadr item)) (atoms (caddr item)) (calls (filter identity (map (lambda (x) (if (and ;; (not (equal? x proc)) ;; uncomment to prevent listing self (member x all-procs)) x #f)) atoms)))) (list proc file calls))) all-procs+file+atoms)) (callers (get-callers-alist all-procs+file+calls))) callers)) (define (get-danglers) (let* ((all-scm-files (glob "*.scm")) (xref (get-xref all-scm-files)) (dangling-procs (map car (filter (lambda (x) (equal? 1 (length x))) xref)))) dangling-procs)) (define (read-ignore-file fname) (let ((ht (make-hash-table))) (if (file-exists? fname) (for-each (lambda (x) (hash-table-set! ht x #t)) (with-input-from-file fname read-lines))) ht)) (define (show-danglers) (let ((ignores (read-ignore-file "danglers-to-ignore.txt")) (danglers (map get-stats (get-danglers)))) ;; (print "ignores: " (hash-table->alist ignores)) (for-each (lambda (dangler) (let* ((fnname (conc (cadr dangler)))) ;; (print "fnname="fnname" member: "(member fnname ignore-list)) (if (not (hash-table-exists? ignores fnname)) (apply print (intersperse dangler "\t")) #;(print "skipping "fnname)))) (sort danglers (lambda (a b)(< (car a)(car b))))))) ;; (for-each print dangling-procs) ;; our product. (define (get-stats fn) (let* ((data (with-input-from-pipe (conc "grep '"fn"' *.scm") read-lines)) (files (delete-duplicates (map (lambda (entry) (car (string-split entry ":"))) data)))) (list (length data) fn files))) (show-danglers) |
Added utils/trackback.scm version [b547b4460b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | ;; 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 "codescanlib.scm") ;; show call paths for named procedure (define (traceback-proc in-procname) (letrec* ((all-scm-files (glob "*.scm")) (xref (get-xref all-scm-files)) (have (alist-ref (string->symbol in-procname) xref eq? #f)) (lookup (lambda (path procname depth) (let* ((upcone-temp (filter (lambda (x) (eq? procname (car x))) xref)) (upcone-temp2 (cond ((null? upcone-temp) '()) (else (cdar upcone-temp)))) (upcone (filter (lambda (x) (not (eq? x procname))) upcone-temp2)) (uppath (cons procname path)) (updepth (add1 depth))) (if (null? upcone) (print uppath) (for-each (lambda (x) (if (not (member procname path)) (lookup uppath x updepth) )) upcone)))))) (if have (lookup '() (string->symbol in-procname) 0) (print "no such func - "in-procname)))) (if (eq? 1 (length (command-line-arguments))) (traceback-proc (car (command-line-arguments))) (print "Usage: trackback <procedure name>")) (exit 0) |