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
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
|
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020, 2021 Magali Lemes <magalilemes00@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix scripts git log)
#:use-module (git)
#:use-module (guix channels)
#:use-module (guix git)
#:use-module (guix scripts)
#:use-module (guix scripts pull)
#:use-module (guix sets)
#:use-module (guix ui)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-37)
#:export (guix-git-log))
(define %formats
'("oneline" "medium" "full"))
(define %options
;; Specifications of the command-line options.
(list (option '(#\h "help") #f #f
(lambda args
(show-help)
(exit 0)))
(option '(#\V "version") #f #f
(lambda args
(show-version-and-exit "guix git log")))
(option '("channel-cache-path") #f #t
(lambda (opt name arg result)
(if arg
(alist-cons 'channel-cache-path
(string->symbol arg) result)
(list-channels))))
(option '("format") #t #f
(lambda (opt name arg result)
(unless (member arg %formats)
(leave (G_ "~a: invalid format~%") arg))
(alist-cons 'format (string->symbol arg) result)))
(option '("grep") #t #f
(lambda (opt name arg result)
(alist-cons 'grep arg result)))
(option '("oneline") #f #f
(lambda (opt name arg result)
(alist-cons 'oneline? #t result)))
(option '("pretty") #t #f
(lambda (opt name arg result)
(alist-cons 'pretty arg result)))))
(define %default-options
'())
(define (list-channels)
"List channels and their checkout path"
(define channels (channel-list '()))
(for-each (lambda (channel)
(format #t "~a~% ~a~%"
(channel-name channel)
(url-cache-directory (channel-url channel))))
channels))
(define (show-help)
(display (G_ "Usage: guix git log [OPTIONS...]
Show Guix commit logs.\n"))
(display (G_ "
--channel-cache-path[=CHANNEL]
show checkout path from CHANNEL"))
(display (G_ "
--format=FORMAT show log according to FORMAT"))
(display (G_ "
--grep=REGEXP show commits whose message matches REGEXP"))
(display (G_ "
--oneline show short hash and summary of commits"))
(display (G_ "
--pretty=<string> show log according to string"))
(newline)
(display (G_ "
-h, --help display this help and exit"))
(display (G_ "
-V, --version display version information and exit"))
(newline)
(show-bug-report-information))
(define commit-short-id
(compose (cut string-take <> 7) oid->string commit-id))
(define placeholders-regex "%([Hhsb]|(an)|(cn))")
(define information-placeholders
;; Alist of placeholders and their corresponding procedure.
`(("%b" . ,commit-body)
("%H" . ,(compose oid->string commit-id))
("%h" . ,commit-short-id)
("%s" . ,commit-summary)
("%an" . ,(compose signature-name commit-author))))
(define (replace-regex string)
"Return a string replacing all information placeholders with ~a"
(regexp-substitute/global #f placeholders-regex string 'pre "~a" 'post))
(define (procedure-list string)
"Return a list of procedures according to the placeholders contained in
string, in the order they appear"
(let* ((placeholders-in-the-string
(map match:substring (list-matches placeholders-regex string))))
(map (lambda (commit)
(assoc-ref information-placeholders commit))
placeholders-in-the-string)))
(define (pretty-show-commit string commit)
"Display commit according to string"
(format #t "~?~%" (replace-regex string) (map
(lambda (f) (f commit))
(procedure-list string))))
(define (show-channel-cache-path channel)
"Display channel checkout path."
(define channels (channel-list '()))
(let ((found-channel (find (lambda (element)
(equal? channel (channel-name element)))
channels)))
(if found-channel
(format #t "~a~%" (url-cache-directory (channel-url found-channel)))
(leave (G_ "~a: channel not found~%") (symbol->string channel)))))
(define (show-commit commit fmt abbrev-commit)
"Display commit according to fmt. If abbrev-commit is #t, then show short hash
id instead of the 40-character one."
(match fmt
('oneline
(format #t "~a ~a~%"
(if abbrev-commit
(commit-short-id commit)
(oid->string (commit-id commit)))
(commit-summary commit)))
('medium
(let ((author (commit-author commit))
(merge-commit (if (> (commit-parentcount commit) 1) #t #f)))
(format #t "commit ~a~[~%Merge:~]~{ ~a~}~%Author: ~a <~a>~%Date: ~a~%~%~a~%"
(if abbrev-commit
(commit-short-id commit)
(oid->string (commit-id commit)))
(if merge-commit 0 1) ;; show "Merge:"
(if merge-commit (map commit-short-id (commit-parents commit)) '())
(signature-name author)
(signature-email author)
(date->string
(time-utc->date
(make-time time-utc 0
(time-time (signature-when author)))
(* 60 (time-offset (signature-when author))))
"~a ~b ~e ~H:~M:~S ~Y ~z")
(commit-message commit))))
('full
(let ((merge-commit (if (> (commit-parentcount commit) 1) #t #f))
(author (commit-author commit))
(committer (commit-committer commit)))
(format #t "commit ~a~[~%Merge:~]~{ ~a~}~%Author: ~a <~a>~%Commit: ~a <~a>~%~%~a~%"
(if abbrev-commit
(commit-short-id commit)
(oid->string (commit-id commit)))
(if merge-commit 0 1) ;; show "Merge:"
(if merge-commit (map commit-short-id (commit-parents commit)) '())
(signature-name author)
(signature-email author)
(signature-name committer)
(signature-email committer)
(commit-message commit))))))
(define %channels-repositories
(make-hash-table))
(define (get-commits)
"Return a list with commits from all channels."
(define channels (channel-list '()))
(fold (lambda (channel commit-list)
(let* ((channel-path (url-cache-directory (channel-url channel)))
(repository (repository-open channel-path))
(latest-commit
(commit-lookup repository
(object-id
(revparse-single
repository "origin/master")))))
(begin
(hashq-set! %channels-repositories channel-path repository)
(append (set->list (commit-closure latest-commit))
commit-list)))) '() channels))
(define (guix-git-log . args)
(define options
(parse-command-line args %options (list %default-options)))
(let ((channel-cache (assoc-ref options 'channel-cache-path))
(oneline? (assoc-ref options 'oneline?))
(format-type (assoc-ref options 'format))
(pretty-string (assoc-ref options 'pretty))
(regexp (assoc-ref options 'grep)))
(with-error-handling
(cond
(channel-cache
(show-channel-cache-path channel-cache))
(oneline?
(leave-on-EPIPE
(for-each (lambda (commit)
(when (or (not regexp)
(string-match regexp (commit-message commit)))
(show-commit commit 'oneline #t)))
(get-commits))))
(format-type
(leave-on-EPIPE
(for-each (lambda (commit)
(when (or (not regexp)
(string-match regexp (commit-message commit)))
(show-commit commit format-type #f)))
(get-commits))))
(pretty-string
(let ((pretty-show (cut pretty-show-commit pretty-string <>)))
(leave-on-EPIPE
(for-each (lambda (commit)
(when (or (not regexp)
(string-match regexp (commit-message commit)))
(pretty-show commit)))
(get-commits)))))))))
|
