Extend configuration and add home page support

Julien LepillerThu Aug 05 00:51:29+0200 2021

3d06cc6

Extend configuration and add home page support

assets/css/git.css unknown status 1

1+
:root {
2+
  --white: #faf7f3;
3+
  --darkwhite: #eae5e0;
4+
  --gray: #d9d5d4;
5+
  --border-dark: #aaa;
6+
  --black: #333;
7+
  --blue: #4C6F8A;
8+
  --orange: #f89b1f;
9+
  --green: #5ed67e;
10+
  --darkgreen: #2cae0e;
11+
  --darkergreen: #2c8e0e;
12+
  --darkdarkgreen: #1e6504;
13+
  --red: #ff5c47;
14+
}
15+
16+
html, body {
17+
  margin: 0;
18+
  padding: 0;
19+
  font-family: "Noto Sans", "Dejavu Sans", sans-serif, sans;
20+
  background: var(--gray);
21+
  color: var(--black);
22+
}
23+
24+
html {
25+
  height: 100%;
26+
}
27+
28+
body {
29+
  min-height: 100%;
30+
  display: flex;
31+
  flex-direction: column;
32+
}
33+
34+
h1 {
35+
  text-align: center;
36+
}
37+
38+
p {
39+
  line-height: 1.5em;
40+
}
41+
42+
header, footer {
43+
  background: var(--white);
44+
  padding: 1em;
45+
}
46+
47+
header p, footer p {
48+
  text-align: justify;
49+
  max-width: 1200px;
50+
  padding: 0.5em;
51+
  margin: auto;
52+
}
53+
54+
footer p {
55+
  text-align: center;
56+
}
57+
58+
.pseudo {
59+
  font-family: monospace, monospace;
60+
}
61+
62+
#content {
63+
  flex: 1;
64+
}
65+
66+
#project-list {
67+
  max-width: 1200px;
68+
  margin: auto;
69+
  padding: 1em;
70+
  display: flex;
71+
  flex-direction: horizontal;
72+
  flex-flow: row wrap;
73+
  justify-content: center;
74+
  text-align: justify;
75+
}
76+
77+
#project-list .project {
78+
  max-width: 350px;
79+
  background: var(--white);
80+
  box-shadow: 1px 1px 3px var(--border-dark);
81+
  border-top: 10px solid var(--darkdarkgreen);
82+
  margin: 0.5em;
83+
  padding: 0.5em;
84+
}
85+
86+
.project h1 {
87+
  margin: 0;
88+
  font-size: 1.5em;
89+
}
90+
91+
pre code {
92+
  border-left: 5px solid var(--orange);
93+
  background-color: var(--darkwhite);
94+
  display: block;
95+
  width: 100%;
96+
  padding: 3px;
97+
}
98+
99+
code {
100+
  padding: 3px;
101+
  background-color: var(--darkwhite);
102+
}
103+
104+
.project .instructions code {
105+
  display: block;
106+
  margin-left: 1em;
107+
  margin-right: 1em;
108+
}
109+
110+
.links a {
111+
  display: block;
112+
  text-align: center;
113+
  margin: 1em;
114+
}
115+
116+
a {
117+
  text-decoration: none;
118+
  color: var(--darkgreen);
119+
}
120+
121+
a:hover {
122+
  color: var(--green);
123+
}
124+
125+
#mire {
126+
  text-align: center;
127+
}
128+
129+
#mire span {
130+
  display: inline-block;
131+
  padding: 0.8em;
132+
  margin: 0;
133+
}
134+
135+
#mire .blue {
136+
  background: var(--blue);
137+
}
138+
#mire .green {
139+
  background: var(--darkergreen);
140+
}
141+
#mire .red {
142+
  background: var(--red);
143+
}
144+
#mire .orange {
145+
  background: var(--orange);
146+
}
gitile/config.scm
2020 
  #:use-module (srfi srfi-9)
2121 
  #:export (make-config
2222 
            config?
23-
	    <config>
23+
            <config>
2424 
            config-port
2525 
            config-host
2626 
            config-database
27-
            config-repositories))
27+
            config-repositories
28+
            config-base-git-url
29+
            config-index-title
30+
            config-intro
31+
            config-footer))
2832 
2933 
(define-record-type <config>
30-
  (make-config port host database repositories)
34+
  (make-config port host database repositories base-git-url index-title intro footer)
3135 
  config?
3236 
  (port         config-port)
3337 
  (host         config-host)
3438 
  (database     config-database)
35-
  (repositories config-repositories))
39+
  (repositories config-repositories)
40+
  (base-git-url config-base-git-url)
41+
  (index-title  config-index-title)
42+
  (intro        config-intro)
43+
  (footer       config-footer))
gitile/handler.scm
2121 
  #:use-module (git)
2222 
  #:use-module (gitile config)
2323 
  #:use-module (gitile pages)
24+
  #:use-module (gitile repo)
2425 
  #:use-module (ice-9 match)
2526 
  #:use-module (rnrs bytevectors)
27+
  #:use-module (srfi srfi-9)
2628 
  #:use-module (sxml simple)
2729 
  #:use-module (web request)
2830 
  #:use-module (web response)
…
3234 
(define (request-path-components request)
3335 
  (split-and-decode-uri-path (uri-path (request-uri request))))
3436 
35-
(define (not-found request)
37+
(define (not-found request footer)
3638 
  (format #t "Not found: ~a~%" (uri->string (request-uri request)))
3739 
  (show (style `((p "Resource not found: "
3840 
                    ,(uri->string (request-uri request))))
39-
               "" "")))
41+
               "" "" footer)))
4042 
41-
(define (style page project ref)
43+
(define (style page project ref footer)
4244 
  `(html
4345 
     (head
4446 
       (meta (@ (charset "UTF-8")))
…
5961 
             (li (a (@ (href "/" ,project "/tags")) "Tags")))))
6062 
       (div (@ (id "content"))
6163 
            ,@page)
62-
       (footer (p (a (@ (href "https://lepiller.eu")) "Who am I?"))))))
64+
       (footer ,@footer))))
65+
66+
(define-record-type <project>
67+
  (make-project slug name description)
68+
  project?
69+
  (slug project-slug)
70+
  (name project-name)
71+
  (description project-description))
72+
73+
(define (index-page projects base-git-url title intro footer)
74+
  (pk 'projects projects)
75+
  `(html
76+
     (head
77+
       (meta (@ (charset "UTF-8")))
78+
       (meta (@ (name "viewport") (content "width=device-width, initial-scale=1")))
79+
       (link (@ (rel "stylesheet") (href "/css/git.css")))
80+
       (link (@ (rel "icon") (href "/images/icon.png") (sizes "32x32")))
81+
       (title ,title))
82+
     (body (@ (lang "en"))
83+
       (header (@ (id "intro"))
84+
         ,@intro
85+
         (p (@ (id "mire"))
86+
            (span (@ (class "blue")) "")
87+
            (span (@ (class "red")) "")
88+
            (span (@ (class "green")) "")
89+
            (span (@ (class "orange")) "")))
90+
       (div (@ (id "content"))
91+
         (div (@ (id "project-list"))
92+
           ,@(map
93+
               (lambda (project)
94+
                 `(div (@ (class "project"))
95+
                    (h1 (a (@ (href ,(string-append "/" (project-slug project))))
96+
                           ,(project-name project)))
97+
                    ,@(match (xml->sxml (string-append "<d>" (project-description project) "</d>"))
98+
                        (('*TOP* ('d content ...))
99+
                         content))
100+
                    (div (@ (class "instructions"))
101+
                         (code "git clone https://" base-git-url "/"
102+
                               ,(project-slug project)))))
103+
               projects)))
104+
       (footer ,@footer))))
63105 
64106 
(define* (show page #:key (code 200))
65107 
  (values (build-response #:code code #:headers '((content-type . (text/html))))
…
72114 
(define (gitile-handler config)
73115 
  (define (call-with-repo project-name callback)
74116 
    (define (repo-404 content project-name ref)
75-
      (show (style content project-name ref)
117+
      (show (style content project-name ref (config-footer config))
76118 
            #:code 404))
77119 
    (define (repo-500 content)
78120 
      (show content #:code 500))
…
102144 
                  (repo-500 `((p "Internal error")))))))
103145 
          (repo-404 `((p "Repository not found: " ,project-name)) project-name
104146 
                    "-"))))
147+
148+
  (define (name->project project)
149+
    (make-project project (call-with-repo project get-name)
150+
                  (call-with-repo project get-description)))
151+
152+
  (define projects
153+
    (let ((dir (opendir (config-repositories config))))
154+
      (let loop ((res '()) (repo (readdir dir)))
155+
        (if (eof-object? repo)
156+
            res
157+
            (if (and
158+
                  (> (string-length repo) 4)
159+
                  (equal? (substring repo (- (string-length repo) 4)) ".git")
160+
                  (file-exists? (string-append (config-repositories config)
161+
                                               "/" repo "/git-daemon-export-ok")))
162+
                (loop
163+
                  (cons
164+
                    (name->project (substring repo 0 (- (string-length repo) 4)))
165+
                    res)
166+
                  (readdir dir))
167+
                (loop res (readdir dir)))))))
168+
105169 
  (match config
106-
    (($ <config> port host database repositories)
170+
    (($ <config> port host database repositories base-git-url index-title intro
171+
        footer)
107172 
     (lambda (request body)
108173 
       (pk 'request request)
109174 
       (pk 'body (if body (utf8->string body) body))
110175 
       (match (request-path-components request)
176+
         (()
177+
          (show (index-page projects base-git-url index-title intro footer)))
111178 
         ((project-name)
112179 
          (call-with-repo project-name
113180 
            (lambda (repo)
114181 
              (show (style (project-index project-name repo)
115-
                           project-name "-")))))
182+
                           project-name "-" footer)))))
116183 
         ((project-name "tree" ref path ...)
117184 
          (call-with-repo project-name
118185 
            (lambda (repo)
119186 
              (show (style (project-files project-name repo #:ref ref #:path path)
120-
                           project-name ref)))))
187+
                           project-name ref footer)))))
121188 
         ((project-name "raw" ref path ...)
122189 
          (call-with-repo project-name
123190 
            (lambda (repo)
…
126193 
          (call-with-repo project-name
127194 
            (lambda (repo)
128195 
              (show (style (project-commits project-name repo #f)
129-
                    project-name "-")))))
196+
                    project-name "-" footer)))))
130197 
         ((project-name "commits" ref)
131198 
          (call-with-repo project-name
132199 
            (lambda (repo)
133200 
              (show (style (project-commits project-name repo ref)
134-
                    project-name ref)))))
201+
                    project-name ref footer)))))
135202 
         ((project-name "commit" ref)
136203 
          (call-with-repo project-name
137204 
            (lambda (repo)
138205 
              (show (style (project-commit project-name repo ref)
139-
                           project-name ref)))))
206+
                           project-name ref footer)))))
140207 
         ((project-name "tags")
141208 
          (call-with-repo project-name
142209 
            (lambda (repo)
143210 
              (show (style (project-tags project-name repo)
144-
                    project-name "-")))))
145-
     (_ (not-found request)))))))
211+
                    project-name "-" footer)))))
212+
         (_ (not-found request footer)))))))
gitile/highlight/css.scm unknown status 1
1+
(define-module (gitile highlight css)
2+
  #:use-module (ice-9 match)
3+
  #:use-module (srfi srfi-1)
4+
  #:use-module (srfi srfi-11)
5+
  #:use-module (srfi srfi-26)
6+
  #:use-module (syntax-highlight lexers)
7+
  #:export (lex-css))
8+
9+
(define %css-units
10+
  '("cm" "mm" "in" "px" "pt" "pc" "em" "ex" "ch" "rem" "vw" "vh" "vmin" "vmax" "%"))
11+
12+
(define %css-functions
13+
  '("url" "attr" "calc" "cubic-bezier" "hsl" "hsla" "linear-gradient"
14+
    "radial-gradient" "repeating-linear-gradient" "repeating-radial-gradient"
15+
    "rgb" "rgba" "var"))
16+
17+
(define lex-css-whitespace
18+
  (lex-char-set char-set:whitespace))
19+
20+
(define lex-comment
21+
  (lex-tag 'comment (lex-delimited "/*" #:until "*/")))
22+
23+
(define lex-whitespace
24+
  (lex-any
25+
    lex-css-whitespace
26+
    lex-comment))
27+
28+
(define lex-number
29+
  (lex-all
30+
    (lex-char-set char-set:digit)
31+
    (lex-maybe
32+
      (lex-all
33+
        (lex-string ".")
34+
        (lex-char-set char-set:digit)))))
35+
36+
(define lex-css-string
37+
  (lex-any
38+
    (lex-tag 'string (lex-delimited "\""))
39+
    (lex-tag 'string (lex-delimited "'"))))
40+
41+
(define lex-selector
42+
  (lex-any
43+
    (lex-all (lex-string ".") (lex-tag 'class (lex-char-set char-set:letter+digit)))
44+
    (lex-all (lex-string "#") (lex-tag 'id (lex-char-set char-set:letter+digit)))
45+
    (lex-all (lex-string "[")
46+
             (lex-tag 'attr (lex-char-set char-set:letter))
47+
             (lex-any (map lex-string '("=" "~=" "|=" "^=" "$=" "*=")))
48+
             (lex-tag 'value (lex-any lex-css-string
49+
                                      (lex-char-set
50+
                                        (char-set-adjoin char-set:letter+digit #\_))))
51+
             (lex-string "]"))
52+
    (lex-all (lex-string "[")
53+
             (lex-tag 'attr (lex-char-set char-set:letter))
54+
             (lex-string "]"))
55+
    (lex-tag 'selector (lex-all (lex-string "::") (lex-char-set char-set:letter+digit)))
56+
    (lex-tag 'selector (lex-all (lex-string ":") (lex-char-set char-set:letter+digit)))))
57+
58+
(define lex-size
59+
  (lex-tag 'size (lex-all lex-number (lex-any (map lex-string %css-units)))))
60+
61+
(define lex-base-property-value
62+
  (lex-any
63+
    (lex-tag 'size (lex-all lex-number (lex-any (map lex-string %css-units))))
64+
    (lex-tag 'number lex-number)
65+
    (lex-tag 'keyword (lex-char-set (char-set-adjoin char-set:letter #\-)))
66+
    (lex-all (lex-string "#") (lex-tag 'color (lex-char-set (string->char-set "0123456789abcdefABCDEF"))))
67+
    lex-css-string))
68+
69+
(define lex-expression
70+
  (lex-all
71+
    lex-base-property-value
72+
    (lex-zero-or-more
73+
      (lex-all
74+
        lex-whitespace
75+
        (lex-any* (map lex-string '("+" "-" "*" "/")))
76+
        lex-whitespace
77+
        lex-base-property-value))))
78+
79+
(define lex-property-value
80+
  (lex-any
81+
    lex-base-property-value
82+
    (lex-all
83+
      (lex-tag 'function (map lex-string %css-functions))
84+
      (lex-string "(")
85+
      (lex-zero-or-more
86+
        (lex-any
87+
          lex-whitespace
88+
          (lex-string ",")
89+
          lex-expression))
90+
      (lex-string ")"))))
91+
92+
(define lex-property
93+
  (lex-all
94+
    (lex-tag 'property (lex-char-set (char-set-adjoin char-set:letter #\-)))
95+
    lex-whitespace
96+
    (lex-string ":")
97+
    lex-whitespace
98+
    (lex-zero-or-more
99+
      (lex-any
100+
        lex-property-value
101+
        lex-whitespace
102+
        (lex-string ",")
103+
        lex-whitespace))
104+
    (lex-maybe (lex-string ";"))))
105+
106+
(define lex-css
107+
  (lex-consume
108+
    (lex-any
109+
      lex-whitespace
110+
      lex-css-string
111+
      (lex-tag 'tag (lex-any (lex-char-set char-set:letter+digit) (lex-string "*")))
112+
      (lex-tag 'operator (lex-any (map lex-string '(">" "+" "~"))))
113+
      (lex-tag 'selector lex-selector)
114+
      (lex-all (lex-string "(")
115+
               (lex-any lex-selector (lex-char-set char-set:digit))
116+
               (lex-string ")"))
117+
      (lex-string ",")
118+
      (lex-all (lex-string "{")
119+
               (lex-zero-or-more
120+
                 (lex-any
121+
                   lex-whitespace
122+
                   lex-comment
123+
                   lex-property))
124+
               (lex-string "}")))))
gitile/pages.scm
163163 
164164 
(define (project-index repository-name repo)
165165 
  `((h1 ,repository-name)
166-
    (p ,(get-description repo))
166+
    (p ,(get-synopsis repo))
167167 
    (p (@ (class "clone"))
168168 
       (code "git clone https://git.lepiller.eu/git/" ,repository-name))
169169 
    ,(project-files repository-name repo)))
gitile/repo.scm
2727 
            get-file-content
2828 
            get-commits
2929 
            get-commit
30+
            get-name
31+
            get-synopsis
3032 
            get-description
3133 
            last-commit
3234 
…
194196 
        0))
195197 
    out))
196198 
199+
(define (get-name repo)
200+
  (let* ((config (repository-config repo))
201+
         (options (get-options config)))
202+
    (or (assoc-ref options "gitweb.name") "")))
203+
204+
(define (get-synopsis repo)
205+
  (let* ((config (repository-config repo))
206+
         (options (get-options config)))
207+
    (or (assoc-ref options "gitweb.synopsis") "")))
208+
197209 
(define (get-description repo)
198210 
  (let* ((config (repository-config repo))
199211 
         (options (get-options config)))
scripts/gitile.in
2727 
(define* (main #:optional (args (command-line)))
2828 
  (let ((config
2929 
         (match args
30-
      ((_) (make-config 8080 "localhost" "/var/lib/gitile/gitile-db.sql"
31-
                        "/var/lib/gitolite/repositories"))
32-
      ((_ "-c" file)
33-
       (let ((content (call-with-input-file file read)))
34-
         (match content
35-
           (('config ('port port) ('host host) ('database database)
36-
	             ('repositories repositories))
37-
            (make-config port host database repositories)))))
38-
      (_ (format #t "Usage: ~a [-c config-file]~%" (car args))))))
30+
           ((_) (make-config 8080 "localhost" "/var/lib/gitile/gitile-db.sql"
31+
                             "/var/lib/gitolite/repositories" "//" "Index" '() '()))
32+
           ((_ "-c" file)
33+
            (let ((content (call-with-input-file file read)))
34+
              (match content
35+
                (('config ('port port) ('host host) ('database database)
36+
                          ('repositories repositories) ('base-git-url git-base-url)
37+
                          ('index-title index-title) ('intro intro) ('footer footer))
38+
                 (make-config port host database repositories git-base-url index-title
39+
                              intro footer)))))
40+
           (_ (format #t "Usage: ~a [-c config-file]~%" (car args))))))
3941 
    (run-server (gitile-handler config)
4042 
                #:port (config-port config))))