src/utils.lisp

   1 (uiop:define-package #:lw2.utils
   2   (:use #:cl #:alexandria #:iterate
   3         #:lw2.macro-utils)
   4   (:export #:nalist #:nalist* #:alist #:alist*
   5            #:alist-without-null #:alist-without-null*
   6            #:dynamic-let #:dynamic-let* #:dynamic-flet #:dynamic-labels
   7            #:with-semaphore
   8            #:universal-time-to-unix #:unix-to-universal-time #:get-unix-time #:as-timestamp #:timerange
   9            #:substring #:nonempty-string
  10            #:with-delimited-writer
  11            #:regex-groups-min
  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*
  16            #:hash-cond #:sethash
  17            #:safe-decode-json
  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
  24            #:random-string
  25            #:values*
  26            #:merge-uris)
  27   (:recycle #:lw2-viewer #:lw2.backend))
  28
  29 (in-package #:lw2.utils)
  30
  31 (defun nalist (&rest params) (plist-alist params))
  32
  33 (defun nalist* (&rest params)
  34   (nconc (plist-alist (butlast params))
  35          (car (last params))))
  36
  37 (defun inner-make-alist (params &optional (env nil env-p))
  38   (iter
  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))
  42                 `(cons ,key ,val)))))
  43
  44 (define-compiler-macro nalist (&rest params)
  45   `(list ,.(inner-make-alist params)))
  46
  47 (define-compiler-macro nalist* (&rest params)
  48   `(list*
  49     ,.(inner-make-alist (butlast params))
  50     ,(car (last params))))
  51
  52 (declaim (ftype function alist alist*))
  53 (setf (fdefinition 'alist) (fdefinition 'nalist)
  54       (fdefinition 'alist*) (fdefinition 'nalist*))
  55
  56 (define-compiler-macro alist* (&rest params &environment env)
  57   `(list*
  58     ,.(inner-make-alist (butlast params) env)
  59     ,(car (last params))))
  60
  61 (define-compiler-macro alist (&rest params &environment env)
  62   (let ((count (length params))
  63         (reverse (reverse params))
  64         (constant-list nil)
  65         (constant-count 0))
  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))
  70                 (t (finish))))
  71     (if (= (* constant-count 2) count)
  72         `(quote ,constant-list)
  73         `(alist* ,@(butlast params (* constant-count 2)) (quote ,constant-list)))))
  74
  75 (defun remove-alist-nulls (alist)
  76   (remove-if (lambda (x) (null (cdr x))) alist))
  77
  78 (defun alist-without-null (&rest params)
  79   (remove-alist-nulls (plist-alist params)))
  80
  81 (defun alist-without-null* (&rest params)
  82   (list* (remove-alist-nulls (plist-alist (butlast params))) (car (last params))))
  83
  84 (define-compiler-macro alist-without-null (&rest params)
  85   `(list-cond
  86     ,@(iter (for (key val) on params by #'cddr)
  87             (collect `(,val ,key ,val)))))
  88
  89 (define-compiler-macro alist-without-null* (&rest params)
  90   `(list-cond*
  91     ,@(iter (for (key val) on (butlast params) by #'cddr)
  92             (collect `(,val ,key ,val)))
  93     ,(car (last params))))
  94
  95 (defun dynamic-let-inner (initial functionp clauses body)
  96   `(,initial ,clauses
  97              (declare (dynamic-extent ,@(iter (for c in clauses)
  98                                               (collect (if functionp `(function ,(first c)) (first c))))))
  99      ,@body))
 100
 101 (defmacro dynamic-let ((&rest clauses) &body body)
 102   (dynamic-let-inner 'let nil clauses body))
 103
 104 (defmacro dynamic-let* ((&rest clauses) &body body)
 105   (dynamic-let-inner 'let* nil clauses body))
 106
 107 (defmacro dynamic-flet ((&rest clauses) &body body)
 108   (dynamic-let-inner 'flet t clauses body))
 109
 110 (defmacro dynamic-labels ((&rest clauses) &body body)
 111   (dynamic-let-inner 'labels t clauses body))
 112
 113 (defmacro with-semaphore ((sem &rest args) &body body)
 114   (once-only (sem)
 115              `(progn
 116                 (sb-thread:wait-on-semaphore ,sem ,@args)
 117                 (unwind-protect (progn ,@body)
 118                   (sb-thread:signal-semaphore ,sem)))))
 119
 120 (defun universal-time-to-unix (time)
 121   (- time #.(encode-universal-time 0 0 0 1 1 1970 0)))
 122
 123 (defun unix-to-universal-time (unix-time)
 124   (+ unix-time #.(encode-universal-time 0 0 0 1 1 1970 0)))
 125
 126 (defun get-unix-time ()
 127   (universal-time-to-unix (get-universal-time)))
 128
 129 (defun as-timestamp (value)
 130   (etypecase value
 131     (string (local-time:parse-timestring value))
 132     (local-time:timestamp value)))
 133
 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)))
 137         (typecase real-value
 138           (string `(load-time-value (local-time:parse-timestring ,real-value)))
 139           (t whole)))
 140       whole))
 141
 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))))
 146
 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))
 151               (t
 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))))
 156         (finally
 157          (return
 158            `(let ,let-args
 159               (and ,@test-args (local-time:timestamp< ,@compare-args)))))))
 160
 161 (deftype array-dimension-type () `(integer 0 ,(- array-dimension-limit 1)))
 162
 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)))
 167
 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))
 172     obj))
 173
 174 (defun call-with-delimited-writer (begin between end fn)
 175   (let (begun)
 176     (flet ((delimit ()
 177              (if begun
 178                  (funcall between)
 179                  (funcall begin))
 180              (setf begun t)))
 181       (declare (dynamic-extent #'delimit))
 182       (funcall fn #'delimit)
 183       (when begun (funcall end)))))
 184
 185 (defmacro with-delimited-writer ((stream delimit &key begin between end) &body body)
 186   (once-only (stream)
 187     (flet ((as-writer-function (x)
 188              (typecase 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))
 197                              ,@body))))
 198          (call-with-delimited-writer begin-fn between-fn end-fn fn)))))
 199
 200 (trivial-cltl2:define-declaration regex-groups-min (decl env) (declare (ignore env)) (values :declare (cons 'regex-groups-min (second decl))))
 201
 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)))))
 213          ,@body))))
 214
 215 (defmacro regex-replace-body ((regex target &rest args) &body body)
 216   `(ppcre:regex-replace-all
 217     ,regex ,target
 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))
 224     ,@args))
 225
 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))
 232      (cond
 233        ,.(iter (for (regex . body) in clauses)
 234                (collect
 235                 (if (member regex '(t :otherwise))
 236                     `(t ,@body)
 237                     `((multiple-value-setq (match-start match-end reg-starts reg-ends)
 238                         (ppcre:scan ,regex target-string))
 239                       (with-regex-accessors ,@body))))))))
 240
 241 (declaim (inline to-boolean))
 242 (defun to-boolean (value)
 243   (and value t))
 244
 245 (declaim (inline nonzero-number-p))
 246 (defun nonzero-number-p (value)
 247   (and (typep value 'number)
 248        (/= 0 value)))
 249
 250 (defun truthy-string-p (string)
 251   (and (typep string 'string)
 252        (to-boolean (member string '("t" "true" "y" "yes" "1") :test #'string-equal))))
 253
 254 (defun firstn (list n)
 255   (iter (for i from 1 to n)
 256         (for x on list)
 257         (collect (car x) into out)
 258         (finally (return (values out (rest x))))))
 259
 260 (defun map-plist (fn plist)
 261   (loop for (key val . rest) = plist then rest
 262         while key
 263         nconc (funcall fn key val)))
 264
 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))
 268
 269 (defmacro alist-bind (bindings alist &body body)
 270   "Binds elements of ALIST so they can be used as if they were lexical variables.
 271
 272 Syntax: alist-bind (binding-entry*) alist forms*
 273 => result*
 274 binding-entry ::= (variable-name &optional type alist-key)
 275
 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."
 281   (once-only (alist)
 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
 291                 (case (car elem)
 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)))
 299                  ,@body))))))))
 300
 301 (defmacro list-cond* (&body clauses &environment env)
 302   (labels ((expand (clauses)
 303              (if (endp (rest clauses))
 304                  (first 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))))
 309                             (data-expansion
 310                              (if value-form-p
 311                                  (if data-constant
 312                                      `'(,data-form . ,value-form)
 313                                      `(cons ,data-form ,value-form))
 314                                  data-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
 321                                                data-expansion
 322                                                `(when ,predicate ,data-expansion)))
 323                                    (,rest ,(expand (rest clauses))))
 324                               (if ,predicate
 325                                   (cons ,data ,rest)
 326                                   ,rest)))))))))
 327     (expand clauses)))
 328
 329 (defmacro list-cond (&body clauses)
 330   `(list-cond* ,@clauses nil))
 331
 332 (defmacro hash-cond (hash &body clauses)
 333   (once-only (hash)
 334     `(progn
 335        ,@(iter (for (predicate-form key-form value-form) in clauses)
 336                (collect `(when ,predicate-form (setf (gethash ,key-form ,hash) ,value-form))))
 337        ,hash)))
 338
 339 (defmacro sethash (hash &rest pairs)
 340   (once-only (hash)
 341              `(progn
 342                 ,@(iter (for (key value) on pairs by #'cddr)
 343                         (collect `(setf (gethash ,key ,hash) ,value)))
 344                 ,hash)))
 345
 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)))))
 350
 351 ;; GraphQL and LW2 are picky about false/null distinctions, so make them explicit
 352
 353 (defmethod json:encode-json ((object (eql :false)) &optional stream)
 354   (write-string "false" stream))
 355
 356 (defmethod json:encode-json ((object (eql :null)) &optional stream)
 357   (write-string "null" stream))
 358
 359 (defun js-true (value)
 360   (not (or (null value)
 361            (eql value :false)
 362            (eql value :null))))
 363
 364 (defun string-to-existing-keyword (string)
 365   (or (find-symbol (json:camel-case-to-lisp string) (find-package '#:keyword))
 366       string))
 367
 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))
 371     (funcall fn)))
 372
 373 (defun delete-easy-handler (name)
 374   (setf hunchentoot::*easy-handler-alist*
 375         (remove name hunchentoot::*easy-handler-alist* :key #'third)))
 376
 377 (defmacro abnormal-unwind-protect (protected-form &body body)
 378   (alexandria:with-gensyms (normal-return)
 379     `(let ((,normal-return nil))
 380        (unwind-protect
 381             (multiple-value-prog1
 382                 ,protected-form
 383               (setf ,normal-return t))
 384          (unless ,normal-return
 385            ,@body)))))
 386
 387 (defmacro ignorable-multiple-value-bind ((&rest bindings) value-form &body body)
 388   (let (new-bindings ignores)
 389     (dolist (binding (reverse bindings))
 390       (if (eq binding '*)
 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))
 397        ,@body)))
 398
 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)))
 403
 404 (defun compare-streams (a b)
 405   (if (eq a b)
 406       t
 407       (or
 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)))))
 412
 413 (defun ensure-character-stream (stream)
 414   (etypecase stream
 415     ((or flex:flexi-stream flex:in-memory-stream)
 416      (setf (flex:flexi-stream-external-format stream) :utf-8)
 417      stream)
 418     (stream
 419      (if (subtypep (stream-element-type stream) 'character)
 420          stream
 421          (flex:make-flexi-stream stream :external-format :utf-8)))))
 422
 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))
 427          (if ,designator
 428              (progn (,body-fn ,designator) nil)
 429              (with-output-to-string (,stream)
 430                (,body-fn ,stream)))))))
 431
 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))
 435       (loop
 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)))))))
 440
 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")
 444                                        :defaults filename))
 445          (stream (funcall open-fn temp-filename)))
 446     (unwind-protect
 447          (multiple-value-prog1 (funcall fn stream)
 448            (setf normal-return t))
 449       (close stream)
 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)))))
 455
 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))))
 461
 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)))))
 466     string))
 467
 468 (defmacro values* (&rest multiple-value-forms)
 469   `(multiple-value-call #'values ,@multiple-value-forms))
 470
 471 (declaim (ftype (function ((or string quri:uri) (or string quri:uri)) string) merge-uris))
 472
 473 (defun merge-uris (reference base)
 474   (quri:render-uri (quri:merge-uris (quri:uri reference) (quri:uri base))))