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 #: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 get-unix-time ()
 124   (universal-time-to-unix (get-universal-time)))
 125
 126 (defun as-timestamp (value)
 127   (etypecase value
 128     (string (local-time:parse-timestring value))
 129     (local-time:timestamp value)))
 130
 131 (define-compiler-macro as-timestamp (&whole whole &environment env value)
 132   (if (compiler-constantp value env)
 133       (let ((real-value (eval-in-environment value env)))
 134         (typecase real-value
 135           (string `(load-time-value (local-time:parse-timestring ,real-value)))
 136           (t whole)))
 137       whole))
 138
 139 (defun timerange (&rest args)
 140   (declare (dynamic-extent args))
 141   (and (every #'to-boolean args)
 142        (apply #'local-time:timestamp< (map 'list #'as-timestamp args))))
 143
 144 (define-compiler-macro timerange (&environment env &rest args)
 145   (iter (for arg in args)
 146         (cond ((compiler-constantp arg env)
 147                (collect `(as-timestamp ,arg) into compare-args))
 148               (t
 149                (let ((var (gensym)))
 150                  (collect `(,var ,arg) into let-args)
 151                  (collect var into test-args)
 152                  (collect `(as-timestamp ,var) into compare-args))))
 153         (finally
 154          (return
 155            `(let ,let-args
 156               (and ,@test-args (local-time:timestamp< ,@compare-args)))))))
 157
 158 (deftype array-dimension-type () `(integer 0 ,(- array-dimension-limit 1)))
 159
 160 (declaim (inline substring)
 161          (ftype (function (string array-dimension-type &optional array-dimension-type) (values (and string (not simple-string)) &optional)) substring))
 162 (defun substring (string start &optional (end (length string)))
 163   (values (make-array (- end start) :element-type (array-element-type string) :displaced-to string :displaced-index-offset start)))
 164
 165 (declaim (inline nonempty-string)
 166          (ftype (function (t) (values (or null string) &optional)) nonempty-string))
 167 (defun nonempty-string (obj)
 168   (when (and (stringp obj) (> (length obj) 0))
 169     obj))
 170
 171 (defun call-with-delimited-writer (begin between end fn)
 172   (let (begun)
 173     (flet ((delimit ()
 174              (if begun
 175                  (funcall between)
 176                  (funcall begin))
 177              (setf begun t)))
 178       (declare (dynamic-extent #'delimit))
 179       (funcall fn #'delimit)
 180       (when begun (funcall end)))))
 181
 182 (defmacro with-delimited-writer ((stream delimit &key begin between end) &body body)
 183   (once-only (stream)
 184     (flet ((as-writer-function (x)
 185              (typecase x
 186                (string `(lambda () (write-string ,x ,stream)))
 187                (t `(lambda () ,x)))))
 188       `(dynamic-let ((begin-fn ,(as-writer-function begin))
 189                      (between-fn ,(as-writer-function between))
 190                      (end-fn ,(as-writer-function end))
 191                      (fn (lambda (,delimit)
 192                            (flet ((,delimit () (funcall ,delimit)))
 193                              (declare (inline ,delimit))
 194                              ,@body))))
 195          (call-with-delimited-writer begin-fn between-fn end-fn fn)))))
 196
 197 (trivial-cltl2:define-declaration regex-groups-min (decl env) (declare (ignore env)) (values :declare (cons 'regex-groups-min (second decl))))
 198
 199 (defmacro with-regex-accessors (&body body)
 200   `(let ((reg-count (length reg-starts)))
 201      (labels ((dynamic-reg (n) (when (> reg-count n)
 202                                  (when-let ((start (aref reg-starts n)))
 203                                            (substring target-string start (aref reg-ends n)))))
 204               (match () (substring target-string match-start match-end)))
 205        (declare (dynamic-extent #'dynamic-reg #'match))
 206        (macrolet ((reg (n &environment env) (let ((static-reg-count (trivial-cltl2:declaration-information 'regex-groups-min env)))
 207                                               (if (and static-reg-count (< n static-reg-count))
 208                                                   `(substring target-string (aref reg-starts ,n) (aref reg-ends ,n))
 209                                                   `(dynamic-reg ,n)))))
 210          ,@body))))
 211
 212 (defmacro regex-replace-body ((regex target &rest args) &body body)
 213   `(ppcre:regex-replace-all
 214     ,regex ,target
 215     (lambda (target-string start end match-start match-end reg-starts reg-ends)
 216       (declare (ignore start end)
 217                (type string target-string)
 218                (type array-dimension-type match-start match-end)
 219                (type simple-vector reg-starts reg-ends))
 220       (with-regex-accessors ,@body))
 221     ,@args))
 222
 223 (defmacro regex-case (target &rest clauses)
 224   `(let ((target-string ,target)
 225          match-start match-end reg-starts reg-ends)
 226      (declare (type string target-string)
 227               (type (or null array-dimension-type) match-start match-end)
 228               (type (or null simple-vector) reg-starts reg-ends))
 229      (cond
 230        ,.(iter (for (regex . body) in clauses)
 231                (collect
 232                 (if (member regex '(t :otherwise))
 233                     `(t ,@body)
 234                     `((multiple-value-setq (match-start match-end reg-starts reg-ends)
 235                         (ppcre:scan ,regex target-string))
 236                       (with-regex-accessors ,@body))))))))
 237
 238 (declaim (inline to-boolean))
 239 (defun to-boolean (value)
 240   (and value t))
 241
 242 (declaim (inline nonzero-number-p))
 243 (defun nonzero-number-p (value)
 244   (and (typep value 'number)
 245        (/= 0 value)))
 246
 247 (defun truthy-string-p (string)
 248   (and (typep string 'string)
 249        (to-boolean (member string '("t" "true" "y" "yes" "1") :test #'string-equal))))
 250
 251 (defun firstn (list n)
 252   (iter (for i from 1 to n)
 253         (for x on list)
 254         (collect (car x) into out)
 255         (finally (return (values out (rest x))))))
 256
 257 (defun map-plist (fn plist)
 258   (loop for (key val . rest) = plist then rest
 259         while key
 260         nconc (funcall fn key val)))
 261
 262 (defun filter-plist (plist &rest args)
 263   (declare (dynamic-extent args))
 264   (map-plist (lambda (key val) (when (member key args) (list key val))) plist))
 265
 266 (defmacro alist-bind (bindings alist &body body)
 267   "Binds elements of ALIST so they can be used as if they were lexical variables.
 268
 269 Syntax: alist-bind (binding-entry*) alist forms*
 270 => result*
 271 binding-entry ::= (variable-name &optional type alist-key)
 272
 273 Each VARIABLE-NAME is bound to the corresponding datum in ALIST. Modifying these
 274 bindings with SETF will also update the ALIST.
 275 TYPE: type designator, not evaluated.
 276 ALIST-KEY: the alist key, as in the first argument to ASSOC. If it is not
 277 specified, the KEYWORD symbol with the same name as VARIABLE-NAME is used."
 278   (once-only (alist)
 279     (let ((inner-bindings (loop for x in bindings collect
 280                                 (destructuring-bind (bind &optional type key) (if (consp x) x (list x))
 281                                   (list (gensym (string bind)) (gensym (string bind)) (gensym (string bind)) bind (or type t) (or key (intern (string bind) '#:keyword)))))))
 282       (macrolet ((inner-loop (&body body)
 283                    `(loop for (fn-gensym cons-gensym value-gensym bind type key) in inner-bindings collect
 284                          (progn fn-gensym cons-gensym value-gensym bind type key ,@body))))
 285         `(let (,@(inner-loop cons-gensym))
 286            (declare (type list ,@(inner-loop cons-gensym)))
 287            (loop for elem in ,alist do
 288                 (case (car elem)
 289                   ,@(inner-loop `(,key (unless ,cons-gensym (setf ,cons-gensym elem))))))
 290            (let (,@(inner-loop `(,value-gensym (cdr ,cons-gensym))))
 291              (declare ,@(inner-loop `(type ,type ,value-gensym)))
 292              (flet (,@(inner-loop `(,fn-gensym () ,value-gensym))
 293                     ,@(inner-loop `((setf ,fn-gensym) (new) (setf ,value-gensym new ,cons-gensym (cons ,key new) ,alist (cons ,cons-gensym ,alist)))))
 294                (declare (inline ,@(inner-loop fn-gensym)))
 295                (symbol-macrolet ,(inner-loop `(,bind (,fn-gensym)))
 296                  ,@body))))))))
 297
 298 (defmacro list-cond* (&body clauses &environment env)
 299   (labels ((expand (clauses)
 300              (if (endp (rest clauses))
 301                  (first clauses)
 302                  (destructuring-bind (predicate-form data-form &optional (value-form nil value-form-p)) (first clauses)
 303                    (with-gensyms (predicate data rest)
 304                      (let* ((data-constant (and (compiler-constantp data-form env) (compiler-constantp value-form env)))
 305                             (data-pure (or data-constant (and (symbolp data-form) (symbolp value-form))))
 306                             (data-expansion
 307                              (if value-form-p
 308                                  (if data-constant
 309                                      `'(,data-form . ,value-form)
 310                                      `(cons ,data-form ,value-form))
 311                                  data-form)))
 312                        (if (compiler-constantp predicate-form env)
 313                            (if (eval-in-environment predicate-form env)
 314                                `(list* ,data-expansion ,(expand (rest clauses)))
 315                                (expand (rest clauses)))
 316                            `(let* ((,predicate (and ,predicate-form t))
 317                                    (,data ,(if data-pure
 318                                                data-expansion
 319                                                `(when ,predicate ,data-expansion)))
 320                                    (,rest ,(expand (rest clauses))))
 321                               (if ,predicate
 322                                   (cons ,data ,rest)
 323                                   ,rest)))))))))
 324     (expand clauses)))
 325
 326 (defmacro list-cond (&body clauses)
 327   `(list-cond* ,@clauses nil))
 328
 329 (defmacro hash-cond (hash &body clauses)
 330   (once-only (hash)
 331     `(progn
 332        ,@(iter (for (predicate-form key-form value-form) in clauses)
 333                (collect `(when ,predicate-form (setf (gethash ,key-form ,hash) ,value-form))))
 334        ,hash)))
 335
 336 (defmacro sethash (hash &rest pairs)
 337   (once-only (hash)
 338              `(progn
 339                 ,@(iter (for (key value) on pairs by #'cddr)
 340                         (collect `(setf (gethash ,key ,hash) ,value)))
 341                 ,hash)))
 342
 343 (defun safe-decode-json (source)
 344   (when (or (streamp source) (nonempty-string source))
 345     (let ((json:*identifier-name-to-key* #'json:safe-json-intern))
 346       (ignore-errors (json:decode-json-from-source source)))))
 347
 348 ;; GraphQL and LW2 are picky about false/null distinctions, so make them explicit
 349
 350 (defmethod json:encode-json ((object (eql :false)) &optional stream)
 351   (write-string "false" stream))
 352
 353 (defmethod json:encode-json ((object (eql :null)) &optional stream)
 354   (write-string "null" stream))
 355
 356 (defun js-true (value)
 357   (not (or (null value)
 358            (eql value :false)
 359            (eql value :null))))
 360
 361 (defun string-to-existing-keyword (string)
 362   (or (find-symbol (json:camel-case-to-lisp string) (find-package '#:keyword))
 363       string))
 364
 365 (defun call-with-safe-json (fn)
 366   (let ((json:*json-identifier-name-to-lisp* #'identity)
 367         (json:*identifier-name-to-key* #'string-to-existing-keyword))
 368     (funcall fn)))
 369
 370 (defun delete-easy-handler (name)
 371   (setf hunchentoot::*easy-handler-alist*
 372         (remove name hunchentoot::*easy-handler-alist* :key #'third)))
 373
 374 (defmacro abnormal-unwind-protect (protected-form &body body)
 375   (alexandria:with-gensyms (normal-return)
 376     `(let ((,normal-return nil))
 377        (unwind-protect
 378             (multiple-value-prog1
 379                 ,protected-form
 380               (setf ,normal-return t))
 381          (unless ,normal-return
 382            ,@body)))))
 383
 384 (defmacro ignorable-multiple-value-bind ((&rest bindings) value-form &body body)
 385   (let (new-bindings ignores)
 386     (dolist (binding (reverse bindings))
 387       (if (eq binding '*)
 388           (let ((gensym (gensym)))
 389             (push gensym new-bindings)
 390             (push gensym ignores))
 391           (push binding new-bindings)))
 392     `(multiple-value-bind ,new-bindings ,value-form
 393          (declare (ignore ,.ignores))
 394        ,@body)))
 395
 396 (defgeneric unwrap-stream (s)
 397   (:method ((s stream)) nil)
 398   (:method ((s flex:flexi-stream)) (flex:flexi-stream-stream s))
 399   (:method ((s chunga:chunked-stream)) (chunga:chunked-stream-stream s)))
 400
 401 (defun compare-streams (a b)
 402   (if (eq a b)
 403       t
 404       (or
 405        (if-let (u-a (unwrap-stream a))
 406                (compare-streams u-a b))
 407        (if-let (u-b (unwrap-stream b))
 408                (compare-streams a u-b)))))
 409
 410 (defun ensure-character-stream (stream)
 411   (etypecase stream
 412     ((or flex:flexi-stream flex:in-memory-stream)
 413      (setf (flex:flexi-stream-external-format stream) :utf-8)
 414      stream)
 415     (stream
 416      (if (subtypep (stream-element-type stream) 'character)
 417          stream
 418          (flex:make-flexi-stream stream :external-format :utf-8)))))
 419
 420 (defmacro with-output-to-designator ((stream designator) &body body)
 421   (with-gensyms (body-fn)
 422     (once-only (designator)
 423       `(flet ((,body-fn (,stream) ,@body))
 424          (if ,designator
 425              (progn (,body-fn ,designator) nil)
 426              (with-output-to-string (,stream)
 427                (,body-fn ,stream)))))))
 428
 429 (defun file-equal (file1 file2)
 430   (with-open-file (stream1 file1 :direction :input :element-type '(unsigned-byte 8))
 431     (with-open-file (stream2 file2 :direction :input :element-type '(unsigned-byte 8))
 432       (loop
 433          (let ((b1 (read-byte stream1 nil))
 434                (b2 (read-byte stream2 nil)))
 435            (unless (eq b1 b2) (return nil))
 436            (when (eq b1 nil) (return t)))))))
 437
 438 (defun call-with-atomic-file-replacement (fn filename open-fn)
 439   (let* ((normal-return nil)
 440          (temp-filename (make-pathname :name (concatenate 'string (pathname-name filename) ".new")
 441                                        :defaults filename))
 442          (stream (funcall open-fn temp-filename)))
 443     (unwind-protect
 444          (multiple-value-prog1 (funcall fn stream)
 445            (setf normal-return t))
 446       (close stream)
 447       (if (and normal-return
 448                (or (not (probe-file filename))
 449                    (not (file-equal filename temp-filename))))
 450           (uiop:rename-file-overwriting-target temp-filename filename)
 451           (uiop:delete-file-if-exists temp-filename)))))
 452
 453 (defmacro with-atomic-file-replacement ((stream filename &rest open-options) &body body)
 454   (with-gensyms (body-fn open-fn)
 455     `(dynamic-flet ((,open-fn (filename) (open filename :direction :output :if-exists :supersede ,@open-options))
 456                     (,body-fn (,stream) ,@body))
 457                    (call-with-atomic-file-replacement #',body-fn ,filename #',open-fn))))
 458
 459 (defun random-string (length)
 460   (let ((string (make-array length :element-type 'character :initial-element #\Space)))
 461     (iter (for i from 0 below length)
 462           (setf (aref string i) (code-char (+ (char-code #\a) (ironclad:strong-random 26)))))
 463     string))
 464
 465 (defmacro values* (&rest multiple-value-forms)
 466   `(multiple-value-call #'values ,@multiple-value-forms))
 467
 468 (declaim (ftype (function ((or string quri:uri) (or string quri:uri)) string) merge-uris))
 469
 470 (defun merge-uris (reference base)
 471   (quri:render-uri (quri:merge-uris (quri:uri reference) (quri:uri base))))