1 (uiop:define-package
#:lw2.utils
2 (:use
#:cl
#:alexandria
#:iterate
4 (:export
#:nalist
#:nalist
* #:alist
#:alist
*
5 #:alist-without-null
#:alist-without-null
*
6 #:dynamic-let
#:dynamic-let
* #:dynamic-flet
#:dynamic-labels
8 #:universal-time-to-unix
#:unix-to-universal-time
#:get-unix-time
#:as-timestamp
#:timerange
9 #:substring
#:nonempty-string
10 #:with-delimited-writer
12 #:regex-replace-body
#:regex-case
#:reg
#:match
13 #:to-boolean
#:nonzero-number-p
#:truthy-string-p
14 #:firstn
#:map-plist
#:filter-plist
#:alist-bind
15 #:list-cond
#:list-cond
*
18 #:string-to-existing-keyword
#:call-with-safe-json
#:js-true
19 #:delete-easy-handler
#:abnormal-unwind-protect
20 #:ignorable-multiple-value-bind
21 #:compare-streams
#:ensure-character-stream
22 #:with-output-to-designator
23 #:with-atomic-file-replacement
27 (:recycle
#:lw2-viewer
#:lw2.backend
))
29 (in-package #:lw2.utils
)
31 (defun nalist (&rest params
) (plist-alist params
))
33 (defun nalist* (&rest params
)
34 (nconc (plist-alist (butlast params
))
37 (defun inner-make-alist (params &optional
(env nil env-p
))
39 (for (key val
) on params by
#'cddr
)
40 (collect (if (and env-p
(compiler-constantp key env
) (compiler-constantp val env
))
41 `'(,(eval-in-environment key env
) .
,(eval-in-environment val env
))
44 (define-compiler-macro nalist
(&rest params
)
45 `(list ,.
(inner-make-alist params
)))
47 (define-compiler-macro nalist
* (&rest params
)
49 ,.
(inner-make-alist (butlast params
))
50 ,(car (last params
))))
52 (declaim (ftype function alist alist
*))
53 (setf (fdefinition 'alist
) (fdefinition 'nalist
)
54 (fdefinition 'alist
*) (fdefinition 'nalist
*))
56 (define-compiler-macro alist
* (&rest params
&environment env
)
58 ,.
(inner-make-alist (butlast params
) env
)
59 ,(car (last params
))))
61 (define-compiler-macro alist
(&rest params
&environment env
)
62 (let ((count (length params
))
63 (reverse (reverse params
))
66 (iter (for (val key
) on reverse by
#'cddr
)
67 (cond ((and (compiler-constantp key env
) (compiler-constantp val env
))
68 (push (cons (eval-in-environment key env
) (eval-in-environment val env
)) constant-list
)
69 (incf constant-count
))
71 (if (= (* constant-count
2) count
)
72 `(quote ,constant-list
)
73 `(alist* ,@(butlast params
(* constant-count
2)) (quote ,constant-list
)))))
75 (defun remove-alist-nulls (alist)
76 (remove-if (lambda (x) (null (cdr x
))) alist
))
78 (defun alist-without-null (&rest params
)
79 (remove-alist-nulls (plist-alist params
)))
81 (defun alist-without-null* (&rest params
)
82 (list* (remove-alist-nulls (plist-alist (butlast params
))) (car (last params
))))
84 (define-compiler-macro alist-without-null
(&rest params
)
86 ,@(iter (for (key val
) on params by
#'cddr
)
87 (collect `(,val
,key
,val
)))))
89 (define-compiler-macro alist-without-null
* (&rest params
)
91 ,@(iter (for (key val
) on
(butlast params
) by
#'cddr
)
92 (collect `(,val
,key
,val
)))
93 ,(car (last params
))))
95 (defun dynamic-let-inner (initial functionp clauses body
)
97 (declare (dynamic-extent ,@(iter (for c in clauses
)
98 (collect (if functionp
`(function ,(first c
)) (first c
))))))
101 (defmacro dynamic-let
((&rest clauses
) &body body
)
102 (dynamic-let-inner 'let nil clauses body
))
104 (defmacro dynamic-let
* ((&rest clauses
) &body body
)
105 (dynamic-let-inner 'let
* nil clauses body
))
107 (defmacro dynamic-flet
((&rest clauses
) &body body
)
108 (dynamic-let-inner 'flet t clauses body
))
110 (defmacro dynamic-labels
((&rest clauses
) &body body
)
111 (dynamic-let-inner 'labels t clauses body
))
113 (defmacro with-semaphore
((sem &rest args
) &body body
)
116 (sb-thread:wait-on-semaphore
,sem
,@args
)
117 (unwind-protect (progn ,@body
)
118 (sb-thread:signal-semaphore
,sem
)))))
120 (defun universal-time-to-unix (time)
121 (- time
#.
(encode-universal-time 0 0 0 1 1 1970 0)))
123 (defun unix-to-universal-time (unix-time)
124 (+ unix-time
#.
(encode-universal-time 0 0 0 1 1 1970 0)))
126 (defun get-unix-time ()
127 (universal-time-to-unix (get-universal-time)))
129 (defun as-timestamp (value)
131 (string (local-time:parse-timestring value
))
132 (local-time:timestamp value
)))
134 (define-compiler-macro as-timestamp
(&whole whole
&environment env value
)
135 (if (compiler-constantp value env
)
136 (let ((real-value (eval-in-environment value env
)))
138 (string `(load-time-value (local-time:parse-timestring
,real-value
)))
142 (defun timerange (&rest args
)
143 (declare (dynamic-extent args
))
144 (and (every #'to-boolean args
)
145 (apply #'local-time
:timestamp
< (map 'list
#'as-timestamp args
))))
147 (define-compiler-macro timerange
(&environment env
&rest args
)
148 (iter (for arg in args
)
149 (cond ((compiler-constantp arg env
)
150 (collect `(as-timestamp ,arg
) into compare-args
))
152 (let ((var (gensym)))
153 (collect `(,var
,arg
) into let-args
)
154 (collect var into test-args
)
155 (collect `(as-timestamp ,var
) into compare-args
))))
159 (and ,@test-args
(local-time:timestamp
< ,@compare-args
)))))))
161 (deftype array-dimension-type
() `(integer 0 ,(- array-dimension-limit
1)))
163 (declaim (inline substring
)
164 (ftype (function (string array-dimension-type
&optional array-dimension-type
) (values (and string
(not simple-string
)) &optional
)) substring
))
165 (defun substring (string start
&optional
(end (length string
)))
166 (values (make-array (- end start
) :element-type
(array-element-type string
) :displaced-to string
:displaced-index-offset start
)))
168 (declaim (inline nonempty-string
)
169 (ftype (function (t) (values (or null string
) &optional
)) nonempty-string
))
170 (defun nonempty-string (obj)
171 (when (and (stringp obj
) (> (length obj
) 0))
174 (defun call-with-delimited-writer (begin between end fn
)
181 (declare (dynamic-extent #'delimit
))
182 (funcall fn
#'delimit
)
183 (when begun
(funcall end
)))))
185 (defmacro with-delimited-writer
((stream delimit
&key begin between end
) &body body
)
187 (flet ((as-writer-function (x)
189 (string `(lambda () (write-string ,x
,stream
)))
190 (t `(lambda () ,x
)))))
191 `(dynamic-let ((begin-fn ,(as-writer-function begin
))
192 (between-fn ,(as-writer-function between
))
193 (end-fn ,(as-writer-function end
))
194 (fn (lambda (,delimit
)
195 (flet ((,delimit
() (funcall ,delimit
)))
196 (declare (inline ,delimit
))
198 (call-with-delimited-writer begin-fn between-fn end-fn fn
)))))
200 (trivial-cltl2:define-declaration regex-groups-min
(decl env
) (declare (ignore env
)) (values :declare
(cons 'regex-groups-min
(second decl
))))
202 (defmacro with-regex-accessors
(&body body
)
203 `(let ((reg-count (length reg-starts
)))
204 (labels ((dynamic-reg (n) (when (> reg-count n
)
205 (when-let ((start (aref reg-starts n
)))
206 (substring target-string start
(aref reg-ends n
)))))
207 (match () (substring target-string match-start match-end
)))
208 (declare (dynamic-extent #'dynamic-reg
#'match
))
209 (macrolet ((reg (n &environment env
) (let ((static-reg-count (trivial-cltl2:declaration-information
'regex-groups-min env
)))
210 (if (and static-reg-count
(< n static-reg-count
))
211 `(substring target-string
(aref reg-starts
,n
) (aref reg-ends
,n
))
212 `(dynamic-reg ,n
)))))
215 (defmacro regex-replace-body
((regex target
&rest args
) &body body
)
216 `(ppcre:regex-replace-all
218 (lambda (target-string start end match-start match-end reg-starts reg-ends
)
219 (declare (ignore start end
)
220 (type string target-string
)
221 (type array-dimension-type match-start match-end
)
222 (type simple-vector reg-starts reg-ends
))
223 (with-regex-accessors ,@body
))
226 (defmacro regex-case
(target &rest clauses
)
227 `(let ((target-string ,target
)
228 match-start match-end reg-starts reg-ends
)
229 (declare (type string target-string
)
230 (type (or null array-dimension-type
) match-start match-end
)
231 (type (or null simple-vector
) reg-starts reg-ends
))
233 ,.
(iter (for (regex . body
) in clauses
)
235 (if (member regex
'(t :otherwise
))
237 `((multiple-value-setq (match-start match-end reg-starts reg-ends
)
238 (ppcre:scan
,regex target-string
))
239 (with-regex-accessors ,@body
))))))))
241 (declaim (inline to-boolean
))
242 (defun to-boolean (value)
245 (declaim (inline nonzero-number-p
))
246 (defun nonzero-number-p (value)
247 (and (typep value
'number
)
250 (defun truthy-string-p (string)
251 (and (typep string
'string
)
252 (to-boolean (member string
'("t" "true" "y" "yes" "1") :test
#'string-equal
))))
254 (defun firstn (list n
)
255 (iter (for i from
1 to n
)
257 (collect (car x
) into out
)
258 (finally (return (values out
(rest x
))))))
260 (defun map-plist (fn plist
)
261 (loop for
(key val . rest
) = plist then rest
263 nconc
(funcall fn key val
)))
265 (defun filter-plist (plist &rest args
)
266 (declare (dynamic-extent args
))
267 (map-plist (lambda (key val
) (when (member key args
) (list key val
))) plist
))
269 (defmacro alist-bind
(bindings alist
&body body
)
270 "Binds elements of ALIST so they can be used as if they were lexical variables.
272 Syntax: alist-bind (binding-entry*) alist forms*
274 binding-entry ::= (variable-name &optional type alist-key)
276 Each VARIABLE-NAME is bound to the corresponding datum in ALIST. Modifying these
277 bindings with SETF will also update the ALIST.
278 TYPE: type designator, not evaluated.
279 ALIST-KEY: the alist key, as in the first argument to ASSOC. If it is not
280 specified, the KEYWORD symbol with the same name as VARIABLE-NAME is used."
282 (let ((inner-bindings (loop for x in bindings collect
283 (destructuring-bind (bind &optional type key
) (if (consp x
) x
(list x
))
284 (list (gensym (string bind
)) (gensym (string bind
)) (gensym (string bind
)) bind
(or type t
) (or key
(intern (string bind
) '#:keyword
)))))))
285 (macrolet ((inner-loop (&body body
)
286 `(loop for
(fn-gensym cons-gensym value-gensym bind type key
) in inner-bindings collect
287 (progn fn-gensym cons-gensym value-gensym bind type key
,@body
))))
288 `(let (,@(inner-loop cons-gensym
))
289 (declare (type list
,@(inner-loop cons-gensym
)))
290 (loop for elem in
,alist do
292 ,@(inner-loop `(,key
(unless ,cons-gensym
(setf ,cons-gensym elem
))))))
293 (let (,@(inner-loop `(,value-gensym
(cdr ,cons-gensym
))))
294 (declare ,@(inner-loop `(type ,type
,value-gensym
)))
295 (flet (,@(inner-loop `(,fn-gensym
() ,value-gensym
))
296 ,@(inner-loop `((setf ,fn-gensym
) (new) (setf ,value-gensym new
,cons-gensym
(cons ,key new
) ,alist
(cons ,cons-gensym
,alist
)))))
297 (declare (inline ,@(inner-loop fn-gensym
)))
298 (symbol-macrolet ,(inner-loop `(,bind
(,fn-gensym
)))
301 (defmacro list-cond
* (&body clauses
&environment env
)
302 (labels ((expand (clauses)
303 (if (endp (rest clauses
))
305 (destructuring-bind (predicate-form data-form
&optional
(value-form nil value-form-p
)) (first clauses
)
306 (with-gensyms (predicate data rest
)
307 (let* ((data-constant (and (compiler-constantp data-form env
) (compiler-constantp value-form env
)))
308 (data-pure (or data-constant
(and (symbolp data-form
) (symbolp value-form
))))
312 `'(,data-form .
,value-form
)
313 `(cons ,data-form
,value-form
))
315 (if (compiler-constantp predicate-form env
)
316 (if (eval-in-environment predicate-form env
)
317 `(list* ,data-expansion
,(expand (rest clauses
)))
318 (expand (rest clauses
)))
319 `(let* ((,predicate
(and ,predicate-form t
))
320 (,data
,(if data-pure
322 `(when ,predicate
,data-expansion
)))
323 (,rest
,(expand (rest clauses
))))
329 (defmacro list-cond
(&body clauses
)
330 `(list-cond* ,@clauses nil
))
332 (defmacro hash-cond
(hash &body clauses
)
335 ,@(iter (for (predicate-form key-form value-form
) in clauses
)
336 (collect `(when ,predicate-form
(setf (gethash ,key-form
,hash
) ,value-form
))))
339 (defmacro sethash
(hash &rest pairs
)
342 ,@(iter (for (key value
) on pairs by
#'cddr
)
343 (collect `(setf (gethash ,key
,hash
) ,value
)))
346 (defun safe-decode-json (source)
347 (when (or (streamp source
) (nonempty-string source
))
348 (let ((json:*identifier-name-to-key
* #'json
:safe-json-intern
))
349 (ignore-errors (json:decode-json-from-source source
)))))
351 ;; GraphQL and LW2 are picky about false/null distinctions, so make them explicit
353 (defmethod json:encode-json
((object (eql :false
)) &optional stream
)
354 (write-string "false" stream
))
356 (defmethod json:encode-json
((object (eql :null
)) &optional stream
)
357 (write-string "null" stream
))
359 (defun js-true (value)
360 (not (or (null value
)
364 (defun string-to-existing-keyword (string)
365 (or (find-symbol (json:camel-case-to-lisp string
) (find-package '#:keyword
))
368 (defun call-with-safe-json (fn)
369 (let ((json:*json-identifier-name-to-lisp
* #'identity
)
370 (json:*identifier-name-to-key
* #'string-to-existing-keyword
))
373 (defun delete-easy-handler (name)
374 (setf hunchentoot
::*easy-handler-alist
*
375 (remove name hunchentoot
::*easy-handler-alist
* :key
#'third
)))
377 (defmacro abnormal-unwind-protect
(protected-form &body body
)
378 (alexandria:with-gensyms
(normal-return)
379 `(let ((,normal-return nil
))
381 (multiple-value-prog1
383 (setf ,normal-return t
))
384 (unless ,normal-return
387 (defmacro ignorable-multiple-value-bind
((&rest bindings
) value-form
&body body
)
388 (let (new-bindings ignores
)
389 (dolist (binding (reverse bindings
))
391 (let ((gensym (gensym)))
392 (push gensym new-bindings
)
393 (push gensym ignores
))
394 (push binding new-bindings
)))
395 `(multiple-value-bind ,new-bindings
,value-form
396 (declare (ignore ,.ignores
))
399 (defgeneric unwrap-stream
(s)
400 (:method
((s stream
)) nil
)
401 (:method
((s flex
:flexi-stream
)) (flex:flexi-stream-stream s
))
402 (:method
((s chunga
:chunked-stream
)) (chunga:chunked-stream-stream s
)))
404 (defun compare-streams (a b
)
408 (if-let (u-a (unwrap-stream a
))
409 (compare-streams u-a b
))
410 (if-let (u-b (unwrap-stream b
))
411 (compare-streams a u-b
)))))
413 (defun ensure-character-stream (stream)
415 ((or flex
:flexi-stream flex
:in-memory-stream
)
416 (setf (flex:flexi-stream-external-format stream
) :utf-8
)
419 (if (subtypep (stream-element-type stream
) 'character
)
421 (flex:make-flexi-stream stream
:external-format
:utf-8
)))))
423 (defmacro with-output-to-designator
((stream designator
) &body body
)
424 (with-gensyms (body-fn)
425 (once-only (designator)
426 `(flet ((,body-fn
(,stream
) ,@body
))
428 (progn (,body-fn
,designator
) nil
)
429 (with-output-to-string (,stream
)
430 (,body-fn
,stream
)))))))
432 (defun file-equal (file1 file2
)
433 (with-open-file (stream1 file1
:direction
:input
:element-type
'(unsigned-byte 8))
434 (with-open-file (stream2 file2
:direction
:input
:element-type
'(unsigned-byte 8))
436 (let ((b1 (read-byte stream1 nil
))
437 (b2 (read-byte stream2 nil
)))
438 (unless (eq b1 b2
) (return nil
))
439 (when (eq b1 nil
) (return t
)))))))
441 (defun call-with-atomic-file-replacement (fn filename open-fn
)
442 (let* ((normal-return nil
)
443 (temp-filename (make-pathname :name
(concatenate 'string
(pathname-name filename
) ".new")
445 (stream (funcall open-fn temp-filename
)))
447 (multiple-value-prog1 (funcall fn stream
)
448 (setf normal-return t
))
450 (if (and normal-return
451 (or (not (probe-file filename
))
452 (not (file-equal filename temp-filename
))))
453 (uiop:rename-file-overwriting-target temp-filename filename
)
454 (uiop:delete-file-if-exists temp-filename
)))))
456 (defmacro with-atomic-file-replacement
((stream filename
&rest open-options
) &body body
)
457 (with-gensyms (body-fn open-fn
)
458 `(dynamic-flet ((,open-fn
(filename) (open filename
:direction
:output
:if-exists
:supersede
,@open-options
))
459 (,body-fn
(,stream
) ,@body
))
460 (call-with-atomic-file-replacement #',body-fn
,filename
#',open-fn
))))
462 (defun random-string (length)
463 (let ((string (make-array length
:element-type
'character
:initial-element
#\Space
)))
464 (iter (for i from
0 below length
)
465 (setf (aref string i
) (code-char (+ (char-code #\a) (ironclad:strong-random
26)))))
468 (defmacro values
* (&rest multiple-value-forms
)
469 `(multiple-value-call #'values
,@multiple-value-forms
))
471 (declaim (ftype (function ((or string quri
:uri
) (or string quri
:uri
)) string
) merge-uris
))
473 (defun merge-uris (reference base
)
474 (quri:render-uri
(quri:merge-uris
(quri:uri reference
) (quri:uri base
))))