| ︙ | | | ︙ | |
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
|
(declare (uses megatest-version))
;; (declare (uses tbd))
(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 *spublish:current-tab-number* 0)
(define *args-hash* (make-hash-table))
(define spublish:help (conc "Usage: spublish [action [params ...]]
|
|
>
|
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
|
(declare (uses megatest-version))
;; (declare (uses tbd))
(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")
(define (toplevel-command . args) #f)
(use readline)
;;
;; GLOBALS
;;
(define *spublish:current-tab-number* 0)
(define *args-hash* (make-hash-table))
(define spublish:help (conc "Usage: spublish [action [params ...]]
|
| ︙ | | | ︙ | |
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
|
"action is happening thread")))
(thread-start! th1)
(thread-start! th2)
(thread-join! th1)
(cons #t "Successfully saved data"))))
(define (spublish:shell-rm targ-path)
(if (not (file-exists? targ-path))
(begin
(print "ERROR: target path " targ-path " does not exist!!"))
(let* ((th1 (make-thread
(lambda ()
(delete-file targ-path )
(print " ... path " targ-path " deleted"))
"rm thread"))
(th2 (make-thread
(lambda ()
(let loop ()
(thread-sleep! 15)
(display ".")
(flush-output)
(loop)))
"action is happening thread")))
(thread-start! th1)
(thread-start! th2)
(thread-join! th1)
(cons #t "Successfully saved data"))))
(define (spublish:shell-ln src-path target-path sub-path)
(if (not (file-exists? sub-path))
(print "ERROR: Path " sub-path " does not exist!! cannot proceed with link creation!!")
(begin
(if (not (file-exists? src-path))
(print "ERROR: Path " src-path " does not exist!! cannot proceed with link creation!!")
|
|
>
>
>
>
|
|
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
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
|
"action is happening thread")))
(thread-start! th1)
(thread-start! th2)
(thread-join! th1)
(cons #t "Successfully saved data"))))
(define (spublish:shell-rm targ-path iport)
(if (not (file-exists? targ-path))
(begin
(print "ERROR: target path " targ-path " does not exist!!"))
(begin
(print "Are you sure you want to delete " targ-path "?[y/n]")
(let* ((inl (read-line iport)))
(if (equal? inl "y")
(let* ((th1 (make-thread
(lambda ()
;(print "hi")
(if (directory? targ-path)
(delete-directory targ-path #t)
(delete-file targ-path ))
(print " ... path " targ-path " deleted"))
"rm thread"))
(th2 (make-thread
(lambda ()
(let loop ()
(thread-sleep! 15)
(display ".")
(flush-output)
(loop)))
"action is happening thread")))
(thread-start! th1)
(thread-start! th2)
(thread-join! th1)
(cons #t "Successfully saved data")))))))
(define (spublish:shell-ln src-path target-path sub-path)
(if (not (file-exists? sub-path))
(print "ERROR: Path " sub-path " does not exist!! cannot proceed with link creation!!")
(begin
(if (not (file-exists? src-path))
(print "ERROR: Path " src-path " does not exist!! cannot proceed with link creation!!")
|
| ︙ | | | ︙ | |
510
511
512
513
514
515
516
517
518
519
520
521
522
523
|
)
(define (toplevel-command . args) #f)
(define (spublish:shell area)
; (print area)
(use readline)
(let* ((path '())
(prompt "spublish> ")
(args (argv))
(usr (current-user-name) )
(top-areas (spublish:get-accessable-projects area))
(close-port #f)
(area-obj (get-obj-by-code area))
|
>
|
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
|
)
(define (toplevel-command . args) #f)
(define (spublish:shell area)
; (print area)
(use readline)
(let* ((path '())
(prompt "spublish> ")
(args (argv))
(usr (current-user-name) )
(top-areas (spublish:get-accessable-projects area))
(close-port #f)
(area-obj (get-obj-by-code area))
|
| ︙ | | | ︙ | |
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
|
(let*((rm-path (cadr parts))
(resolved-path (sauth-common:resolve-path rm-path path top-areas))
(target-path (sauth-common:get-target-path path rm-path top-areas base-path)))
(if (not (equal? target-path #f))
(if (equal? resolved-path #f)
(print "Invalid argument " rm-path ".. ")
(begin
(spublish:shell-rm target-path)
(sauthorize:do-as-calling-user
(lambda ()
(run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "rm")))))))
)))))
((cp publish)
(let* ((thepath (if (> (length parts) 1) ;; have a parameter
|
|
|
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
|
(let*((rm-path (cadr parts))
(resolved-path (sauth-common:resolve-path rm-path path top-areas))
(target-path (sauth-common:get-target-path path rm-path top-areas base-path)))
(if (not (equal? target-path #f))
(if (equal? resolved-path #f)
(print "Invalid argument " rm-path ".. ")
(begin
(spublish:shell-rm target-path iport)
(sauthorize:do-as-calling-user
(lambda ()
(run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "rm")))))))
)))))
((cp publish)
(let* ((thepath (if (> (length parts) 1) ;; have a parameter
|
| ︙ | | | ︙ | |
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
|
(if (< (length remargs) 1)
(begin
(print "ERROR: Missing arguments; <area> <path> ")
(exit 1)))
(let* ((filter-args (args:get-args args '("-m") '() args:arg-hash 0))
(rm-path (car filter-args))
(resolved-path (sauth-common:resolve-path rm-path (list area) top-areas))
(target-path (sauth-common:get-target-path (list area) rm-path top-areas base-path)))
(if (not (equal? target-path #f))
(if (equal? resolved-path #f)
(print "Invalid argument " rm-path ".. ")
(begin
(spublish:shell-rm target-path)
(sauthorize:do-as-calling-user
(lambda ()
(run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" rm " rm-path "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "rm")))))))))
((shell)
(if (< (length args) 1)
(begin
(print "ERROR: Missing arguments area!!" )
|
>
>
|
|
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
|
(if (< (length remargs) 1)
(begin
(print "ERROR: Missing arguments; <area> <path> ")
(exit 1)))
(let* ((filter-args (args:get-args args '("-m") '() args:arg-hash 0))
(rm-path (car filter-args))
(resolved-path (sauth-common:resolve-path rm-path (list area) top-areas))
(prompt ">")
(iport (make-readline-port prompt))
(target-path (sauth-common:get-target-path (list area) rm-path top-areas base-path)))
(if (not (equal? target-path #f))
(if (equal? resolved-path #f)
(print "Invalid argument " rm-path ".. ")
(begin
(spublish:shell-rm target-path iport)
(sauthorize:do-as-calling-user
(lambda ()
(run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" rm " rm-path "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "rm")))))))))
((shell)
(if (< (length args) 1)
(begin
(print "ERROR: Missing arguments area!!" )
|
| ︙ | | | ︙ | |