blob: ca8fdb08dfc65c44479db7af8d4acb9eca9ecb0d (
plain)
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
|
(import scheme
(chicken base)
(chicken process-context)
(chicken format)
matchable
test
desmo-apply
)
(define should-run-inline-tests?
(let ((v (get-environment-variable "INLINE_TESTS")))
(and (string? v)
(string=? v "1"))))
(define-syntax inline-tests
(syntax-rules ()
((_ expr ...)
(if should-run-inline-tests?
(begin expr ...)))))
; CLI arg parser
(define usage-string
(format (string-append
"Usage: desmoctl [-f cfg-path] SUBCOMMAND~%~%"
"Subcommands:~%"
" apply Apply the cluster config~%"
" status Show cluster status~%"
" logs Show cluster logs~%"
" help Show this help text~%~%"
"Top-level flags:~%"
" -f cfg-path Path to the cluster config file (default: desmo.scm)")))
(define initial-opts
'((cfg-path "desmo.scm")))
(define (is-flag-like? args)
(let ([first-char (string-ref (car args) 0)])
(eq? #\- first-char)))
(inline-tests
(test-group "is-flag-like?"
(test "returns true for valid list" #t (is-flag-like? '("-f" "desmo.scm")))
(test "returns false for invalid list" #f (is-flag-like? '("apply")))))
;;; Returns a list of parsed options and the remaining arguments.
(define (parse-top-level-flags opts args)
(match args
[()
`(parse-ok ,opts '())]
[("-f" cfg-path . rest)
(parse-top-level-flags (cons `(cfg-path ,cfg-path) opts)
rest)]
[(? is-flag-like?)
`(parse-error ,usage-string)]
[_
`(parse-ok ,opts ,args)]))
(inline-tests
(test-group "parse-top-level-flags"
(test "returns parse-error for invalid flag" 'parse-error
(car (parse-top-level-flags initial-opts '("--invalid-flag"))))
(test "returns parse-ok for empty args" 'parse-ok
(car (parse-top-level-flags initial-opts '())))
(test "returns parse-ok for valid flag" 'parse-ok
(car (parse-top-level-flags initial-opts '("-f" "foobar.scm" "status"))))
(test "returns parse-ok for valid flag and subcommand" 'parse-ok
(car (parse-top-level-flags initial-opts '("-f" "desmo.scm" "apply"))))))
(define (parse-subcommand args)
(match args
[("apply")
'(parse-ok cmd-apply ())]
[("status" . rest)
(print "TODO status subcommand")
(exit 0)]
[("logs" . rest)
(print "TODO logs subcommand")
(exit 0)]
[("help" . rest)
(print usage-string)
(exit 0)]
[_ `(parse-error ,usage-string)]))
(inline-tests
(test-group "parse-subcommand"
(test "returns parse-error for invalid subcommand" 'parse-error
(car (parse-subcommand '("invalid-subcommand"))))
(test "returns parse-ok for valid subcommand" 'parse-ok
(car (parse-subcommand '("apply"))))))
(define top-level-flags-parse-result (parse-top-level-flags initial-opts (command-line-arguments)))
(cond
[(eq? (car top-level-flags-parse-result) 'parse-error)
(print (cadr top-level-flags-parse-result))
(exit 1)])
(define cli-opts (cadr top-level-flags-parse-result))
(define cli-subcommand-args (caddr top-level-flags-parse-result))
(print (format "debug: cli-opts: ~A" cli-opts))
(print (format "debug: cli-subcommand-args: ~A" cli-subcommand-args))
(define subcommand-parse-result (parse-subcommand cli-subcommand-args))
(cond
[(eq? (car subcommand-parse-result) 'parse-error)
(print (cadr subcommand-parse-result))
(exit 1)])
(define cli-subcommand (cadr subcommand-parse-result))
(define cli-opts (append (caddr subcommand-parse-result) cli-opts))
(print (format "debug: cli-subcommand: ~A" cli-subcommand))
(print (format "debug: cli-opts: ~A" cli-opts))
; evaluate parsed command
(define (eval-apply opts)
'done)
(define (eval-subcommand subcmd opts)
(match subcmd
['cmd-apply (eval-apply opts)]
[other (print `(eval-error ,(format "invalid subcommand: ~A" other)))]))
(display (format "debug: eval-cmd: ~A ~%" (eval-subcommand cli-subcommand cli-opts)))
(print (run-apply 'benis))
|
