blob: 855625af8fb35aff1c4f68a265ecb4e9c89a33cd (
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
|
(import scheme
(chicken base)
(chicken process-context)
(chicken format)
(chicken pretty-print)
matchable
test
utils
desmo-apply
desmo-status
desmo-logs
)
; 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")
'(parse-ok cmd-status ())]
[("logs")
'(parse-ok cmd-logs ())]
[("help")
'(parse-ok cmd-help ())]
[_ `(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))
; read in config
(define cfg-content
(read (open-input-file (cadr (assoc 'cfg-path cli-opts)))))
(print "debug: cfg-content")
(pretty-print cfg-content)
; evaluate parsed command
(define (eval-subcommand subcmd cfg)
(match subcmd
['cmd-apply (run-apply cfg)]
['cmd-status (run-status cfg)]
['cmd-logs (run-logs cfg)]
['cmd-help (print usage-string) 'done]
[other (print `(eval-error ,(format "invalid subcommand: ~A" other)))]))
(eval-subcommand cli-subcommand cfg-content)
|
