blob: 14cc2432b0885c975866efc66c513b760edcaf6d (
plain)
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
|
;;; tissue --- Text based issue tracker
;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of tissue.
;;;
;;; tissue is free software: you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; tissue is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with tissue. If not, see <https://www.gnu.org/licenses/>.
(define-module (tissue utils)
#:use-module (rnrs io ports)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (ice-9 filesystem)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
#:use-module (web uri)
#:export (string-blank?
string-contains?
string-remove-prefix
string-remove-suffix
human-date-string
call-with-current-directory
call-with-temporary-directory
call-with-output-pipe
get-line-dos-or-unix
memoize-thunk
query-parameters
query-string))
(define (string-blank? str)
"Return #t if STR contains only whitespace. Else, return #f."
(string-every char-set:whitespace str))
(define (string-contains? str1 str2)
"Return #t if STR1 contains STR2. Else, return #f. This is different
from string-contains in that it does not return the index in STR1
where STR2 occurs as a substring."
(and (string-contains str1 str2)
#t))
(define (string-remove-prefix prefix str)
"Remove PREFIX from STR."
(substring str (string-length prefix)))
(define (string-remove-suffix suffix str)
"Remove SUFFIX from STR."
(substring str 0 (- (string-length str)
(string-length suffix))))
(define (human-date-string date)
"Return a human readable rendering of DATE."
(let ((elapsed-time
(time-second
(time-difference (date->time-monotonic (current-date))
(date->time-monotonic date)))))
(cond
((< elapsed-time (* 2 60))
(format #f "~a seconds ago" elapsed-time))
((< elapsed-time (* 2 60 60))
(format #f "~a minutes ago" (round (/ elapsed-time 60))))
((< elapsed-time (* 2 24 60 60))
(format #f "~a hours ago" (round (/ elapsed-time 60 60))))
((< elapsed-time (* 2 7 24 60 60))
(format #f "~a days ago" (round (/ elapsed-time 60 60 24))))
((< elapsed-time (* 2 30 24 60 60))
(format #f "~a weeks ago" (round (/ elapsed-time 60 60 24 7))))
(else
(format #f "on ~a" (date->string date "~b ~d ~Y"))))))
(define (call-with-current-directory curdir thunk)
"Call THUNK with current directory set to CURDIR. Restore current
directory after THUNK returns."
(let ((original-current-directory (getcwd)))
(dynamic-wind (cut chdir curdir)
thunk
(cut chdir original-current-directory))))
(define* (call-with-temporary-directory proc #:optional (parent-directory (getcwd)))
"Call PROC with a new temporary directory in PARENT-DIRECTORY, and
delete it when PROC returns or exits non-locally."
(let ((temporary-directory (mkdtemp (string-append parent-directory "/XXXXXX"))))
(dynamic-wind (const #t)
(cut proc temporary-directory)
(lambda ()
(when (file-exists? temporary-directory)
(delete-file-recursively temporary-directory))))))
(define (call-with-output-pipe proc program . args)
"Execute PROGRAM ARGS ... in a subprocess with a pipe to it. Call PROC
with an output port to that pipe. Close the pipe once PROC exits, even
if it exits non-locally. Return the value returned by PROC."
(let ((port #f))
(dynamic-wind
(cut set! port (apply open-pipe* OPEN_WRITE program args))
(cut proc port)
(lambda ()
(let ((return-value (status:exit-val (close-pipe port))))
(unless (and return-value
(zero? return-value))
(error "Invocation of program failed" (cons program args))))))))
(define (get-line-dos-or-unix port)
"Read line from PORT. This differs from `get-line' in (rnrs io
ports) in that it also supports DOS line endings."
(let ((line (get-line port)))
(if (eof-object? line)
line
(string-trim-right line #\return))))
(define (memoize-thunk thunk)
"Return a function memoizing THUNK."
(let ((result #f))
(lambda ()
(unless result
(set! result (thunk)))
result)))
(define (query-parameters query)
"Return an association list of query parameters in web QUERY string."
(if query
(map (lambda (parameter)
(match (string-split parameter #\=)
((key value)
(cons (uri-decode key)
(uri-decode value)))))
(string-split query #\&))
'()))
(define (query-string parameters)
"Return a query string for association list of PARAMETERS."
(string-join
(map (match-lambda
((key . value)
(string-append (uri-encode key)
"="
(uri-encode value))))
parameters)
"&"))
|
