forked from GrammaTech/sel
-
Notifications
You must be signed in to change notification settings - Fork 0
/
command-line-rest.lisp
182 lines (171 loc) · 8.34 KB
/
command-line-rest.lisp
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
(defpackage :software-evolution-library/command-line-rest
(:nicknames :sel/command-line-rest)
(:use
:gt/full
:software-evolution-library
:software-evolution-library/command-line
:software-evolution-library/rest/define-command-endpoint
:software-evolution-library/rest/async-jobs
:software-evolution-library/rest)
(:import-from :software-evolution-library/rest/async-jobs
:lookup-session-job-status)
(:import-from :clack :clackup :stop)
(:import-from :snooze :make-clack-app :defroute
:payload-as-string :http-condition)
(:import-from :cl-json :decode-json-from-string :encode-json-to-string)
(:export :define-command-async-rest
:define-command-rest
:clackup :stop :make-clack-app :defroute
:*port*
:*address*
:payload-as-string :http-condition
:decode-json-from-string :encode-json-to-string))
(in-package :software-evolution-library/command-line-rest)
(in-readtable :curry-compose-reader-macros)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *port* 5000 "Port on which to run the clack server.")
(defvar *address* "127.0.0.1" "Address on which to bind the clack server.")
(defparameter +clackup-command-line-options+
`((("port") :type integer :optional t :initial-value ,*port*
:documentation "Port to use when starting the clack server.")
(("address") :type string :optional t :initial-value "127.0.0.1"
:documentation "Address to which the clack server with bind, ~
\"0.0.0.0\" allows remote connections")
(("debug") :type boolean :optional t :initial-value nil
:documentation "Run the clack server in debug mode.")
(("silent") :type boolean :optional t :initial-value nil
:documentation "Run the clack server in silent mode.")))
(defparameter +server-command-line-options+
(append +common-command-line-options+ +clackup-command-line-options+)))
(defmacro define-command-rest (name args pre-help post-help &rest body)
`(progn (define-command ,name ,args ,pre-help ,post-help ,@body)
(define-command-rest-server ,name)))
(defmacro define-command-rest-server (name)
"Call `define-command' with all args, then define a serve-NAME REST server."
(nest
(let ((package (package-name *package*))))
(flet ((in-pkg (symbol) (intern (string symbol) package))))
(let ((spec-symbol (in-pkg '&spec))
(aux-symbol (in-pkg '&aux))
(server-name (intern (concatenate 'string "SERVE-" (string name))
package))
(help-name (intern (concatenate 'string
"SHOW-HELP-FOR-SERVE-" (string name))
package))))
`(define-command ,server-name
(,spec-symbol +server-command-line-options+ ,aux-symbol server)
,(format nil "Serve ~A as a rest end point." name) ""
(declare (ignorable ,@(mapcar #'in-pkg '(eval load language))))
(when ,(in-pkg 'quiet) (setf ,(in-pkg 'silent) t))
(when ,(in-pkg 'help)
(,help-name)
(exit-command ,server-name 0))
(setf *address* ,(in-pkg 'address))
(setf *port* ,(in-pkg 'port))
;; Install exit handler for User C-c.
(flet ((shutdown
(&optional (message "Stopping server . . .") (errno 0))
(format t "~a" message)
(stop server)
(exit-command ,server-name errno)))
;; From https://github.com/LispCookbook/cl-cookbook/blob/master/scripting.md
(handler-case
;; Run server, and wait for keyboard input to terminate.
;; Borrowed from `sel/rest.lisp`.
(progn
(setf server
(clackup (make-clack-app)
:port *port* :address *address*
:debug ,(in-pkg 'debug) :silent ,(in-pkg 'silent)))
(unless *lisp-interaction*
(loop :for char := (read-char *standard-input* nil #\p) :do
(if (member char '(#\q #\Q))
(shutdown)
(sleep 1)))))
;; Catch a user's C-c.
(#.interrupt-signal ()
(shutdown "Shutting down server." 130))
(error (e)
(shutdown (format nil "unexpected error ~S" e) 1)))
(exit-command ,server-name 0 server)))))
(declaim (special *fitness-predicate*
*max-evals* *max-time* *orig* *population*
*target-fitness-p* *test-suite* *threads*))
(defmacro define-command-async-rest
((name &key (environment '(*fitness-predicate*
*max-evals* *max-time* *orig* *population*
*target-fitness-p* *test-suite* *threads*))
(status 'lookup-session-job-status))
args pre-help post-help &body body)
"Define a function, executable, and a REST server function and executable.
Invokes `define-command' on NAME ARGS PRE-HELP POST-HELP and BODY to
define the NAME function and the RUN-NAME command-line executable
entry point. See the definition of `define-command' for more
information on these arguments.
Use the above arguments and the additional ENVIRONMENT and STATUS
keywords to define an asynchronous REST entry point which runs the
function NAME asynchronously returning a job ID and another entry
point which may be used to retrieve the status of the async job. A
new RUN-SERVE-NAME command-line executable entry point is defined.
ENVIRONMENT
: List of variables which should be let-bound around the execution
of the REST end-point.
STATUS
: A function which will be invoked in the dynamic environment of the
running job to return the status of the job or, when finished, to
return the result."
;; Split the args to pull out types and pass names to `define-command'.
;; There isn't much we can do here about rest args, due to types. We leave
;; the binding unused for now.
;; Based on the parsing code for `define-command` in `fare/parse.lisp`.
(let* ((package (package-name *package*))
;; I would prefer not to need route-name, but would need to change to
;; a rest library that does not use CLOS generics to represent routes
;; (to prevent the name collision between defining the entry function
;; and the endpoint).
(route-name (intern (concatenate 'string "REST-"
(string-upcase (string name)))
package))
(spec-symbol (intern "&SPEC" package))
(rest-symbol (intern "&REST" package))
(command-line-specification (second (member spec-symbol args)))
(typed-positional-args (take-until
«and [#'not #'listp]
[{equal #\&} {aref _ 0} #'symbol-name]»
(take-until {eql rest-symbol} args)))
(positional-args (mapcar #'car typed-positional-args)))
;; NOTE: Results just status or "finished/path."
`(progn
;; 1. Define the command.
(define-command ,name (,@positional-args
,spec-symbol ,command-line-specification)
,pre-help ,post-help ,@body)
;; 2. Define the rest endpoint.
(define-endpoint-route ,route-name #',name
,typed-positional-args
,command-line-specification
,environment ,status)
;; 3. Define the rest server command.
(define-command-rest-server ,name))))
#+comment
(define-command-rest (four-types-2)
((a integer) (b string) (c float) (d boolean)
&spec +common-command-line-options+)
"Test that the four supported types can be passed via REST."
nil
(format nil "~A: ~D, ~A: ~S, ~A: ~F, ~A: ~A"
(type-of a) a
(type-of b) b
(type-of c) c
(type-of d) d))
#+comment
(macroexpand-1 '(define-command-rest (fact-entry)
((n integer) &spec +common-command-line-options+)
"Test that canonical REST endpoints work. Computes factorial."
#.(format nil
"~%Built from SEL ~a, and ~a ~a.~%"
+software-evolution-library-version+
(lisp-implementation-type) (lisp-implementation-version))
(declare (ignorable quiet verbose))
(when help (show-help-for-fact-entry))
(factorial n)))