1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216
(define-module (utils) #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) #:export (assoc-value safe-car safe-cdr find-compute bytevector-null? bytevector->hex-string bytevector-from-file file-extension string-substitute error-message? make-error-message error-message-text map-n-times do-n-times read-sexp string-match1 string->number-safe escape-host get-file-contents multi-value-or sxml->xml-bv read-file write-file pick-random vector-pick-random check-fail notice-id-num notice-id-str)) (define (error-message? x) (and (list? x) (equal? 'error-message (car x)))) (define (make-error-message message) (list 'error-message message)) (define error-message-text cadr) (define (bytevector-null? bv) (eqv? 0 (bytevector-length bv))) (define (bytevector->hex-string bv) (define port (open-bytevector-input-port bv)) (set-port-encoding! port "UTF-8") (call-with-output-string (lambda (out-port) (define (loop) (define byte (get-u8 port)) (if (eof-object? byte) 'end (begin (if (< byte 16) (format out-port "0~x" byte) (format out-port "~x" byte)) (loop)))) (loop)))) (define (bytevector-from-file file-path) (call-with-input-file file-path (lambda (port) (define bv (get-bytevector-all port)) (if (eof-object? bv) #f bv)))) (define (file-extension str) "for file.png it returns png for file.tar.gz it returns gz" (define match (string-match "\\.([^\\.]+)$" str)) (if match (match:substring match 1) #f)) (define* (assoc-value key alist #:optional (alternative #f)) (define result (assoc key alist)) (if result (cdr result) alternative)) (define (safe-car lst) (if (not (null? lst)) (car lst) #f)) (define (safe-cdr lst) (if (not (null? lst)) (cdr lst) '())) (define (find-compute test-proc lst) "Like find, but it returns the value from test-proc instead of the list item" (define (itr current rest) (define result (test-proc current)) (if result result (if (null? rest) #f (itr (car rest) (cdr rest))))) (if (null? lst) #f (itr (car lst) (cdr lst)))) (define* (string-substitute search substitute recursive? str #:optional (start-pos 0)) (define found (string-contains str search start-pos)) (define result (if found (cons #t (string-replace str substitute found (+ found (string-length search)))) (cons #f str))) ;; (warn "string-substitute" str result) (if (and (car result) recursive?) (string-substitute search substitute recursive? (cdr result) (+ found (string-length substitute))) (cdr result))) (define (do-n-times fn n) (do ((i 0 (+ 1 i))) ((> i n)) (fn i))) (define (map-n-times fn n) (define acc '()) (do ((i 0 (+ 1 i))) ((>= i n)) (set! acc (cons (fn i) acc))) acc) (define (read-sexp string) (call-with-input-string string (lambda (port) (read port)))) (define (get-file-contents file-path) ;; TODO use (ice-9 textual-ports) with guile2.2 (define (read-step) (let ((c (read-char))) (if (eof-object? c) (current-output-port) (begin (display c) (read-step))))) (with-input-from-file file-path (lambda () (with-output-to-string (lambda () (set-port-encoding! (current-output-port) "utf-8") (read-step)))))) (define (string-match1 regex string) (define match (string-match regex string)) (if match (match:substring match 1) #f)) (define (string->number-safe str) (and (string? str) str)) ;;; take a list of names for multiple values ;;; and n multiple value expressions ;;; and return the first one where none of the values is #f (define-syntax multi-value-or (syntax-rules () ((_ (value-names ...) expression) (call-with-values (lambda () expression) (lambda (value-names ...) (if (and value-names ...) (values value-names ...) #f)))) ((_ (value-names ...) expression rest ...) (call-with-values (lambda () expression) (lambda (value-names ...) (if (and value-names ...) (values value-names ...) (multi-value-or (value-names ...) rest ...))))))) (define (escape-host host-str) ;; TODO FIXME SECURITY "make sure that localhost or internal ips aren't called" host-str) (define (secure-external-url url) ;; TODO FIXME SECURITY "make sure that localhost or internal ips aren't called" url) (define* (sxml->xml-bv sxml sxml->xml #:optional (add-header #f)) (call-with-values (lambda () (open-bytevector-output-port)) (lambda (out-port finalize-output-bytevector) (set-port-encoding! out-port "UTF-8") (when add-header (display "<?xml version=\"1.0\" encoding=\"UTF-8\"?>" out-port)) (sxml->xml sxml out-port) (finalize-output-bytevector)))) (define (pick-random lst) (define len (length lst)) (list-ref lst (random len))) (define (vector-pick-random v) (define len (vector-length v)) (vector-ref v (random len))) (define (read-file file) (and (file-exists? file) (call-with-input-file file (lambda (port) (read port))))) (define (write-file file data) (call-with-output-file file (lambda (port) (write data port)))) (define (notice-id-str notice) (define id (assoc-ref notice 'id)) (if (number? id) (number->string id) id)) (define (notice-id-num notice) (define id (assoc-ref notice 'id)) (if (number? id) id (string->number id))) (define (check-fail message value) (if value #f message))