Add description

Julien LepillerSat Oct 03 17:39:39+0200 2020

46e0d7d

Add description

gitile/git.scm unknown status 1

1+
(define-module (gitile git)
2+
  #:use-module (bytestructures guile)
3+
  #:use-module (git)
4+
  #:use-module (git types)
5+
  #:use-module (srfi srfi-9)
6+
  #:use-module ((system foreign) #:select (make-pointer
7+
                                           pointer->string
8+
                                           procedure->pointer
9+
                                           set-pointer-finalizer!
10+
                                           %null-pointer))
11+
  #:use-module ((system foreign) #:prefix foreign:)
12+
  #:export (config-entry-name config-entry-value config-entry-include-depth
13+
            config-entry-level
14+
            config-foreach))
15+
16+
(define pointer->bytestructure (@@ (git structs) pointer->bytestructure))
17+
(define bytestructure->pointer (@@ (git structs) bytestructure->pointer))
18+
19+
(define tree-entry-type
20+
  (let ((proc (libgit2->procedure int "git_tree_entry_type" '(*))))
21+
    (lambda (entry)
22+
      (proc (tree-entry->pointer entry)))))
23+
24+
(define %config-entry (bs:struct `((name ,(bs:pointer uint8)) ; char *
25+
                                   (value ,(bs:pointer uint8)) ; char *
26+
                                   (include-depth ,uint64)
27+
                                   (level ,int) ; git_config_level_t
28+
                                   (free ,(bs:pointer int))
29+
                                   (payload ,(bs:pointer int)))))
30+
(define-record-type <config-entry>
31+
  (%make-config-entry bytestructure)
32+
  config-entry?
33+
  (bytestructure config-entry-bytestructure))
34+
35+
(define (pointer->config-entry pointer)
36+
  (%make-config-entry (pointer->bytestructure pointer %config-entry)))
37+
38+
(define (config-entry->pointer entry)
39+
  (bytestructure->pointer (config-entry-bytestructure entry)))
40+
41+
(define (config-entry-name entry)
42+
  (pointer->string (make-pointer (bytestructure-ref (config-entry-bytestructure entry) 'name))))
43+
44+
(define (config-entry-value entry)
45+
  (pointer->string (make-pointer (bytestructure-ref (config-entry-bytestructure entry) 'value))))
46+
47+
(define (config-entry-include-depth entry)
48+
  (bytestructure-ref (config-entry-bytestructure entry) 'include-depth))
49+
50+
(define (config-entry-level entry)
51+
  (bytestructure-ref (config-entry-bytestructure entry) 'level))
52+
53+
(define %config-entry-free (libgit2->pointer "git_config_entry_free"))
54+
55+
(define (pointer->config-entry! pointer)
56+
    (set-pointer-finalizer! pointer %config-entry-free)
57+
      (pointer->config-entry pointer))
58+
59+
(define config-foreach
60+
  (let ((proc (libgit2->procedure* "git_config_foreach" '(* * *))))
61+
    (lambda (config callback)
62+
      (let ((callback* (procedure->pointer foreign:int
63+
                                           (lambda (entry _)
64+
                                             (callback (pointer->config-entry entry)))
65+
                                           (list '* '*))))
66+
        (proc (config->pointer config) callback* %null-pointer)))))
gitile/pages.scm
105105 
106106 
(define (project-index repository-name repo)
107107 
  `((h1 ,repository-name)
108-
    (p ,(get-config-string (repository-config repo)
109-
                           "gitweb.description"))
108+
    (p ,(get-description repo))
110109 
    (p (@ (class "clone"))
111110 
       (code "git clone https://git.lepiller.eu/git/" ,repository-name))
112111 
    ,(project-files repository-name repo)))
gitile/repo.scm
11 
;;;; Copyright (C) 2020 Julien Lepiller <julien@lepiller.eu>
2-
;;;; 
2+
;;;;
33 
;;;; This library is free software; you can redistribute it and/or
44 
;;;; modify it under the terms of the GNU Lesser General Public
55 
;;;; License as published by the Free Software Foundation; either
66 
;;;; version 3 of the License, or (at your option) any later version.
7-
;;;; 
7+
;;;;
88 
;;;; This library is distributed in the hope that it will be useful,
99 
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
1010 
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
1111 
;;;; Lesser General Public License for more details.
12-
;;;; 
12+
;;;;
1313 
;;;; You should have received a copy of the GNU Lesser General Public
1414 
;;;; License along with this library; if not, write to the Free Software
1515 
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
16-
;;;; 
16+
;;;;
1717 
1818 
(define-module (gitile repo)
1919 
  #:use-module (git)
2020 
  #:use-module (git types)
21+
  #:use-module (gitile git)
2122 
  #:use-module (srfi srfi-9)
2223 
  #:use-module (system foreign)
2324 
  #:export (get-branches
2425 
            get-tags
2526 
            get-files
2627 
            get-file-content
27-
	    get-commits
28+
            get-commits
29+
            get-description
2830 
            last-commit
2931 
3032 
            <file>
…
118120 
119121 
(define (get-commits repo ref)
120122 
  (let* ((oid (ref->oid repo ref))
121-
	 (commit (commit-lookup repo oid)))
123+
         (commit (commit-lookup repo oid)))
122124 
    (let loop ((result (list commit)) (commit commit))
123125 
      (let ((pcommit (false-if-exception (commit-parent commit))))
124-
	(if (and pcommit (< (length result) 20))
125-
	    (loop (cons pcommit result) pcommit)
126-
	    (cons (reverse result) pcommit))))))
126+
        (if (and pcommit (< (length result) 20))
127+
            (loop (cons pcommit result) pcommit)
128+
            (cons (reverse result) pcommit))))))
129+
130+
(define (get-options config)
131+
  (let ((out '()))
132+
    (config-foreach
133+
      config
134+
      (lambda (entry)
135+
        (set! out (cons (cons (config-entry-name entry)
136+
                              (config-entry-value entry))
137+
                        out))
138+
        0))
139+
    out))
140+
141+
(define (get-description repo)
142+
  (let* ((config (repository-config repo))
143+
         (options (get-options config)))
144+
    (assoc-ref options "gitweb.description")))