Display tags.

Julien LepillerSun Mar 07 13:47:37+0100 2021

d1e346c

Display tags.

gitile/pages.scm

3232 
            project-index
3333 
            project-commits
3434 
            project-commit
35-
	    project-tags))
35+
            project-tags))
3636 
3737 
(define not-yet-page
3838 
  `((p "Not yet available, sorry :/")))
…
118118 
                     (string->utf8 (signature-email author))
119119 
                     (hash-algorithm sha1)))))
120120 
121-
(define (commit->date-string commit)
121+
(define (time->date-string time)
122122 
  (date->string
123123 
    (time-utc->date
124-
      (make-time time-utc 0 (commit-time commit)))))
124+
      (make-time time-utc 0 time))))
125125 
126126 
(define (last-commit-infobox repository-name repo ref)
127127 
  (let* ((ref (if (equal? ref "-") #f ref))
…
139139 
       (p (span (@ (class "author"))
140140 
                ,(signature-name (commit-author commit)))
141141 
          (span (@ (class "date"))
142-
            ,(commit->date-string commit))))
142+
            ,(time->date-string (commit-time commit)))))
143143 
     (div (@ (class "commit-id"))
144144 
          (p (@ (class "short-id"))
145145 
             ,(string-take (oid->string (commit-id commit)) 7))
…
150150 
               `(a (@ (href "/" ,repository-name "/tree/"
151151 
                            ,(oid->string (commit-id commit))))
152152 
                    (img (@ (src "/images/go.svg"))))
153-
	       '()))))
153+
           '()))))
154154 
155155 
(define (project-commits repository-name repo ref)
156156 
  (let* ((commits (get-commits repo ref))
…
189189 
190190 
(define (project-tags repository-name repo)
191191 
  (let ((tags (get-tags repo)))
192+
    (pk 'tags tags)
192193 
    (if (null? tags)
193-
	`((p "This project has no tags yet."))
194-
	`((p "There are tags, but we don't know how to show them yet.")))))
194+
        `((p "This project has no tags yet."))
195+
        (map (lambda (tag) (tag-box repository-name tag)) tags))))
196+
197+
(define (tag-box repository-name tag)
198+
  (pk tag)
199+
  (match tag
200+
    (($ <mytag> name message target time)
201+
     `(div (@ (class "tag-box"))
202+
           (div (@ (class "tag"))
203+
                (p (a (@ (href ,repository-name "/tree/" ,target)) ,name))
204+
                (p (span (@ (class "date"))
205+
                         ,(time->date-string time))))
206+
           (p ,message)))))
195207 
196208 
(define (project-commit repository-name repo ref)
197209 
  (let* ((commit (get-commit repo ref))
gitile/repo.scm
3434 
            make-file
3535 
            file?
3636 
            file-name
37-
            file-type))
37+
            file-type
38+
39+
            <mytag>
40+
            make-mytag
41+
            mytag-name
42+
            mytag-message
43+
            mytag-target))
3844 
3945 
(define tree-entry-type
4046 
  (let ((proc (libgit2->procedure int "git_tree_entry_type" '(*))))
4147 
    (lambda (entry)
4248 
      (proc (tree-entry->pointer entry)))))
4349 
50+
(define tag-foreach
51+
  (let ((proc (libgit2->procedure* "git_tag_foreach"
52+
                                   `(* * *))))
53+
    (lambda (repository callback)
54+
      (let ((callback* (procedure->pointer int
55+
                                           (lambda (name oid _)
56+
                                             (callback
57+
                                               (pointer->string name)
58+
                                               (pointer->oid oid)))
59+
                                           '(* * *))))
60+
        (proc (repository->pointer repository) callback* %null-pointer)))))
61+
4462 
(define (get-branches repo)
4563 
  (map (lambda (ref) (cons (reference-shorthand ref) (reference-name ref)))
4664 
       (filter reference-branch? (reference-fold cons '() repo))))
4765 
66+
(define-record-type <mytag>
67+
  (make-mytag name message target date)
68+
  mytag?
69+
  (name    mytag-name)
70+
  (message mytag-message)
71+
  (target  mytag-target)
72+
  (date    mytag-date))
73+
4874 
(define (get-tags repo)
49-
  (map (lambda (ref) (cons (reference-shorthand ref) (reference-name ref)))
50-
       (filter reference-tag? (reference-fold cons '() repo))))
75+
  (let ((tags '()))
76+
    (tag-foreach
77+
      repo
78+
      (lambda (name oid)
79+
        (let* ((tag (false-if-exception (tag-lookup repo oid)))
80+
               (oid (if tag (tag-target-id tag) oid))
81+
               (commit (commit-lookup repo oid))
82+
               (date (commit-time commit)))
83+
          (set! tags
84+
            (cons
85+
              (make-mytag
86+
                (cond
87+
                  (tag (tag-name tag))
88+
                  ((string-prefix? "refs/tags/" name)
89+
                   (substring name (string-length "refs/tags/")))
90+
                  (else name))
91+
                (if tag (tag-message tag) "")
92+
                (oid->string oid)
93+
                date)
94+
              tags)))
95+
        0))
96+
    (sort tags (lambda (t1 t2) (> (mytag-date t1) (mytag-date t2))))))
5197 
5298 
(define (search-reference repo name)
5399 
  (reference-fold (lambda (ref acc)