Add commits page and improve file listing

Julien LepillerSun Sep 27 22:51:22+0200 2020

e15b6a4

Add commits page and improve file listing

gitile/pages.scm

2121 
  #:use-module (git types)
2222 
  #:use-module (ice-9 match)
2323 
  #:use-module (rnrs bytevectors)
24+
  #:use-module (srfi srfi-1); fold
2425 
  #:use-module (srfi srfi-19); date/time
2526 
  #:use-module (system foreign)
2627 
  #:export (not-yet-page
2728 
            project-file-raw
2829 
            project-files
2930 
            project-index
30-
	    project-commits))
31+
            project-commits))
3132 
3233 
(define not-yet-page
3334 
  `((p "Not yet available, sorry :/")))
3435 
3536 
(define* (project-file-raw repo path #:key (ref "-"))
3637 
  (let* ((ref (if (equal? ref "-") #f ref))
37-
         (path (if (list? path)
38-
                   (string-join
39-
                     (filter (lambda (p) (not (string-null? p))) path)
40-
                     "/")
41-
                   path)))
38+
         (path (canonalize-path path)))
4239 
    (get-file-content repo path #:ref ref)))
4340 
41+
(define (canonalize-path path)
42+
  (if (list? path)
43+
     (string-join
44+
       (filter (lambda (p)
45+
                 (and (not (string-null? p))
46+
                      (not (equal? p "."))))
47+
               path)
48+
       "/")
49+
     path))
50+
4451 
(define* (project-files repository-name repo #:key (ref "-") (path '()))
4552 
  (let* ((ref (if (equal? ref "-") #f ref))
46-
         (path (if (list? path)
47-
                   (string-join
48-
                     (filter (lambda (p) (not (string-null? p))) path)
49-
                     "/")
50-
                   path))
53+
         (path-box (parent-paths-box repository-name ref path))
54+
         (path (canonalize-path path))
5155 
         (dir-path (if (string-null? path) path (string-append path "/")))
5256 
         (files (sort (get-files repo #:ref ref #:path dir-path)
5357 
                      (lambda (f1 f2)
5458 
                        (string<=? (file-name f1) (file-name f2))))))
55-
    (pk 'path dir-path)
56-
    (pk 'files files)
5759 
    (if (and (string-null? path) (null? files))
5860 
        `(p "Empty repository")
5961 
        (if (null? files)
60-
            `((p (@ (class "content")) "file content")
61-
              (pre ,(pk (utf8->string (get-file-content repo path #:ref ref)))))
62+
            `(,path-box
63+
	      (p (@ (class "content"))
64+
                 ,(basename path))
65+
              (pre ,(utf8->string (get-file-content repo path #:ref ref))))
6266 
            `(,(last-commit-infobox repository-name repo ref)
67+
              ,path-box
6368 
              (table
6469 
                (thead
6570 
                  (tr
…
7378 
                        (let ((name (if (= type 2) (string-append name "/") name)))
7479 
                          `(tr (td (a (@ (href "/" ,repository-name
7580 
                                               "/tree/" ,(or ref "-")
76-
                                               "/" ,path "/" ,name))
77-
                                      (img (@ (src "/images/file-type-" ,type ".png")))
78-
                                      ,name))
81+
                                               "/" ,path "/" ,name)
82+
                                         (class "icon-link"))
83+
                                      (img (@ (src "/images/file-type-" ,type ".svg")))
84+
                                      (span ,name)))
7985 
                               (td (a (@ (href "/" ,repository-name
8086 
                                               "/commit/" ,(oid->string
81-
							     (commit-id commit))))
87+
                                                             (commit-id commit))))
8288 
                                      ,(commit-message commit)))
8389 
                               (td ,(commit->date-string commit))))))
8490 
                     files))))))))
…
94100 
  `((h1 ,repository-name)
95101 
    (p ,(get-config-string (repository-config repo)
96102 
                           "gitweb.description"))
103+
    (p (@ (class "clone"))
104+
       (code "git clone https://git.lepiller.eu/git/" ,repository-name))
97105 
    ,(project-files repository-name repo)))
98106 
99107 
(define (author-image author)
…
114122 
     (p (img (@ (src ,(author-image (commit-author commit))))))
115123 
     (div (@ (class "commit"))
116124 
       (p (@ (class "message"))
117-
	  (a (@ (href "/" ,repository-name "/commit/"
118-
		      ,(oid->string (commit-id commit))))
119-
	     ,(commit-message commit)))
125+
          (a (@ (href "/" ,repository-name "/commit/"
126+
                      ,(oid->string (commit-id commit))))
127+
             ,(commit-message commit)))
120128 
       (p (span (@ (class "author"))
121129 
                ,(signature-name (commit-author commit)))
122130 
          (span (@ (class "date"))
…
130138 
131139 
(define (project-commits repository-name repo ref)
132140 
  (let* ((commits (get-commits repo ref))
133-
	 (next (cdr commits))
134-
	 (commits (car commits)))
135-
    (pk 'commits commits)
141+
         (next (cdr commits))
142+
         (commits (car commits)))
136143 
    `(,(map (lambda (commit)
137-
	      (commit-infobox repository-name commit))
138-
	    commits)
144+
              (commit-infobox repository-name commit))
145+
            commits)
139146 
      ,(if next
140-
	   `(p (a (@ (href "/" ,repository-name "/commits/"
141-
			   ,(oid->string (commit-id next))))))
142-
	   '()))))
147+
           `(p (a (@ (href "/" ,repository-name "/commits/"
148+
                           ,(oid->string (commit-id next))))))
149+
           '()))))
150+
151+
(define (parent-paths-box repository-name ref path)
152+
  `(div (@ (class "path-box"))
153+
    ,(if (null? (pk 'path path))
154+
	 `(a (@ (href "/" ,repository-name)) ,repository-name)
155+
         (fold
156+
           (lambda (p res)
157+
             (cons* p "/" res))
158+
           (list `(a ,(car (reverse path))))
159+
           (map
160+
             (lambda (p)
161+
	       (let ((p (if (string-null? p) p (substring p 1)))
162+
		     (base (if (string-null? (basename p))
163+
			       repository-name
164+
			       (basename p))))
165+
                 `(a (@ (href "/" ,repository-name "/tree/" ,(or ref "-") "/" ,p))
166+
                     ,base)))
167+
             (fold
168+
               (lambda (p res)
169+
                 (cons (string-append (car res) "/" p)
170+
                       res))
171+
               (list "")
172+
               (reverse (cdr (reverse path)))))))))
gitile/repo.scm
9595 
  (let* ((oid (ref->oid repo ref))
9696 
         (commit (commit-lookup repo oid))
9797 
         (tree (commit-tree commit))
98-
         (entry (pk 'tree-item (tree-entry-bypath tree (pk 'path path))))
98+
         (entry (tree-entry-bypath tree path))
9999 
         (entry-oid (tree-entry-id entry))
100100 
         (blob (blob-lookup repo entry-oid)))
101101 
    (blob-content blob)))