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