cl-scopes/util.lisp

;;;; cl-scopes/util - common utilities for the scopes project

(defpackage :scopes/util
  (:use :common-lisp)
  (:local-nicknames (:b64 :qbase64))
  #+sbcl (:import-from :sb-ext #:add-package-local-nickname)
  (:export #:make-vars-format #:lg #:lgd #:lgi
           #:from-unix-time #:to-unix-time
           #:create-secret #:digest #:sign
           #:rfill #:rtrim #:loop-plist #:filter-plist #:plist-pairs #:plist-equal
           #:flatten-str #:to-keyword #:keyword-to-string #:to-integer #:to-string
           #:from-bytes #:to-bytes #:from-b64 #:to-b64
           #:absolute-dir #:check-dir #:ensure-dir #:home-path #:path-from-string
           #:relative-path #:runtime-path #:system-path
           #:add-package-local-nickname))

(in-package :scopes/util)

;;;; formatting and logging shortcuts

(defun make-vars-format (vars)
  (format nil "~{~(~a~): ~~S ~}" vars))

(defmacro lg (level &rest vars)
  (let ((lm (find-symbol (string level) :log))
        (fm (make-vars-format vars)))
    `(,lm ,fm ,@vars)))

(defmacro lgd (&rest vars) `(lg :debug ,@vars))
(defmacro lgi (&rest vars) `(lg :info ,@vars))

;;;; date and time manipulations

(defconstant *unix-time-base* (encode-universal-time 0 0 0 1 1 1970 0))

(defun from-unix-time (time)
  (when time (+ time *unix-time-base*)))

(defun to-unix-time (time)
  (when time (- time *unix-time-base*)))

;;;; secrets, digests, and other crypto stuff

(defun create-secret (&key (bytes 16) (scheme :uri))
  (b64-encode (ironclad:random-data bytes) :scheme scheme))

(defun digest (tx &key (scheme :original) (alg :sha256))
  (b64:encode-bytes (ironclad:digest-sequence alg (to-bytes tx)) :scheme scheme))

(defun sign (tx key)
  (let* ((binp (to-bytes tx))
         (bkey (to-bytes key))
         ;(bkey (make-array 16 :element-type '(unsigned-byte 8)
         ;                 :initial-contents (b64:decode-string key)))
         (mac (ironclad:make-mac :hmac bkey :sha256)))
    (ironclad:update-mac mac binp)
    (b64-encode (ironclad:produce-mac mac) :scheme :uri)))

;;;; lists and loops

(defun rfill (ll ls)
  (mapcar #'(lambda (x) (pop ls)) ll))

(defun rtrim (lst)
  (nreverse (member-if #'identity (reverse lst))))

(defmacro loop-plist (plist kvar vvar &body body)
  `(loop for (,kvar ,vvar . nil) on ,plist by #'cddr ,@body))

(defun filter-plist (pl keys)
  (loop-plist pl k v when (find k keys) append (list k v)))

(defun plist-pairs (pl)
  (loop-plist pl k v collect (list k v)))

(defun plist-equal (l1 l2)
  (unless (= (length l1) (length l2))
    (return-from plist-equal nil))
  (loop-plist l1 k v do
    (unless (equal (getf l2 k) v)
      (return-from plist-equal nil)))
  t)
;;;; strings, symbols, keywords, ...

(defun flatten-str (s &key (sep " "))
  (str:join sep 
    (mapcar (lambda (x) (str:trim x)) 
            (str:lines s))))

(defun keyword-to-string (k)
  (if k (string-downcase k) ""))

(defun to-string (k &key (sep " ") lower-case)
  (let ((pattern (if lower-case "~(~a~)" "~a")))
    (if (atom k)
      (format nil pattern k)
      (str:join sep (mapcar #'(lambda (s) (format nil pattern s)) k)))))

(defun to-integer (k)
  (parse-integer (string k)))

(defun to-keyword (s)
  (if (string= s "")
    nil
    (intern (string-upcase s) :keyword)))

(defun from-bytes (b)
  (flexi-streams:octets-to-string b :external-format :utf8))

(defun to-bytes (s)
  (flexi-streams:string-to-octets s :external-format :utf8))

(defun b64-decode (s &key (scheme :uri))
  (let ((padding
          (case (mod (length s) 4)
            (3 "=")
            (2 "==")
            (t ""))))
    (b64:decode-string (str:concat s padding) :scheme scheme)))

(defun b64-encode (b &key (scheme :uri))
  (str:trim-right (b64:encode-bytes b :scheme scheme) :char-bag "="))

(defun from-b64 (s &key (scheme :uri))
  (from-bytes (b64-decode s :scheme scheme)))

(defun to-b64 (s &key (scheme :uri))
  (b64-encode (to-bytes s) :scheme scheme))

;;;; directory and pathname utilities

(defun split-filename (name)
  (let* ((parts (str:rsplit "." name :limit 2)) 
         (n (car parts))
         (type (cadr parts)))
    (when (string= n "") ; leading dot, e.g. ".env"
      (setf n name)
      (setf type nil))
    (values n type)))

(defun absolute-dir (path)
  (make-pathname :directory (list :absolute path)))

(defun relative-path (name &rest dirs)
  (multiple-value-bind (n type) (split-filename name)
    (make-pathname :name n :type type :directory (cons :relative dirs))))

(defun runtime-path (name &rest dirs)
  (merge-pathnames (apply #'relative-path name dirs)))

(defun home-path (name &rest dirs)
  (merge-pathnames (apply #'relative-path name dirs) (user-homedir-pathname)))

(defun system-path (sys name &rest dirs)
  (asdf:system-relative-pathname sys (apply #'relative-path name dirs)))

(defun path-from-string (s)
  (uiop:parse-native-namestring (uiop:native-namestring s)))

(defun check-dir (p)
  (probe-file (directory-namestring p)))

(defun ensure-dir (p)
  (ensure-directories-exist (directory-namestring p)))