Support projects in subdirectories.

Julien LepillerMon Feb 21 14:32:42+0100 2022

acd5353

Support projects in subdirectories.

gitile/handler.scm

2525 
  #:use-module (ice-9 match)
2626 
  #:use-module (rnrs bytevectors)
2727 
  #:use-module (srfi srfi-9)
28+
  #:use-module (srfi srfi-11)
2829 
  #:use-module (sxml simple)
2930 
  #:use-module (web request)
3031 
  #:use-module (web response)

…

114115 
          page))
115116 
116117 
(define (gitile-handler config)
118+
  (define (repo-404 content project-name ref)
119+
    (show (style content project-name ref (config-footer config))
120+
          #:code 404))
121+
122+
  (define (repo-500 content)
123+
    (show content #:code 500))
124+
117125 
  (define (call-with-repo project-name callback)
118-
    (define (repo-404 content project-name ref)
119-
      (show (style content project-name ref (config-footer config))
120-
            #:code 404))
121-
    (define (repo-500 content)
122-
      (show content #:code 500))
123126 
    (define (get-repo name)
124127 
      (let ((repo (string-append (config-repositories config)
125128 
                                 "/" name ".git"))
…
151154 
                    "-"))))
152155 
153156 
  (define (name->project project)
157+
    (pk 'name->project project)
154158 
    (make-project project (call-with-repo project get-name)
155159 
                  (call-with-repo project get-description)))
156160 
157161 
  (define (projects)
158-
    (let ((dir (opendir (config-repositories config))))
159-
      (let loop ((res '()) (repo (readdir dir)))
160-
        (if (eof-object? repo)
161-
            res
162-
            (if (and
163-
                  (> (string-length repo) 4)
164-
                  (file-exists? (string-append (config-repositories config)
165-
                                               "/" repo "/git-daemon-export-ok")))
166-
                (loop
167-
                  (cons
168-
                    (name->project
169-
                      (if (equal? (substring repo (- (string-length repo) 4)) ".git")
170-
                          (substring repo 0 (- (string-length repo) 4))
171-
                          repo))
172-
                    res)
173-
                  (readdir dir))
174-
                (loop res (readdir dir)))))))
162+
    (define (projects-aux dir)
163+
      (pk 'opening 'projects 'in dir)
164+
      (let ((opened-dir (opendir dir)))
165+
        (let loop ((res '()) (repo (readdir opened-dir)))
166+
          (cond
167+
            ((eof-object? repo)
168+
             (closedir opened-dir)
169+
             res)
170+
            ((file-exists? (string-append dir "/" repo "/git-daemon-export-ok"))
171+
             (pk 'found dir '/ repo)
172+
             (loop
173+
               (cons
174+
                 (name->project
175+
                   (substring
176+
                     (string-append
177+
                       dir "/"
178+
                       (if (string-suffix? ".git" repo)
179+
                           (substring repo 0 (- (string-length repo) 4))
180+
                           repo))
181+
                     (+ (string-length (config-repositories config)) 1)))
182+
                 res)
183+
               (readdir opened-dir)))
184+
            ((file-exists? (string-append dir "/" repo "/.git"))
185+
             (loop res (readdir opened-dir)))
186+
            ((and (stat (string-append dir "/" repo) #f)
187+
                  (equal? (stat:type (stat (string-append dir "/" repo) #f)) 'directory)
188+
                  (not (equal? repo ".git"))
189+
                  (not (equal? repo "."))
190+
                  (not (equal? repo "..")))
191+
             (loop (append (projects-aux (string-append dir "/" repo)) res)
192+
                   (readdir opened-dir)))
193+
            (else (loop res (readdir opened-dir)))))))
194+
    (projects-aux (config-repositories config)))
195+
196+
  (define (find-project-component request)
197+
    (let ((request (string-join
198+
                     (split-and-decode-uri-path (uri-path (request-uri request)))
199+
                     "/")))
200+
      (let loop ((projects (projects)))
201+
        (match projects
202+
          (() (values "" (split-and-decode-uri-path request)))
203+
          ((project projects ...)
204+
           (let ((slug (project-slug project)))
205+
           (if (or (string-prefix? (string-append slug "/") request)
206+
                   (equal? slug request))
207+
               (values (project-slug project)
208+
                       (split-and-decode-uri-path
209+
                         (substring request (string-length slug))))
210+
               (loop projects))))))))
175211 
176212 
  (match config
177213 
    (($ <config> port host database repositories base-git-url index-title intro
…
179215 
     (lambda (request body)
180216 
       (pk 'request request)
181217 
       (pk 'body (if body (utf8->string body) body))
182-
       (match (request-path-components request)
183-
         (()
184-
          (show (index-page (projects) base-git-url index-title intro footer)))
185-
         ((project-name)
186-
          (call-with-repo project-name
187-
            (lambda (repo)
188-
              (show (style (project-index base-git-url project-name repo)
189-
                           project-name "-" footer)))))
190-
         ((project-name "tree" ref path ...)
191-
          (call-with-repo project-name
192-
            (lambda (repo)
193-
              (show (style (project-files project-name repo #:ref ref #:path path)
194-
                           project-name ref footer)))))
195-
         ((project-name "raw" ref path ...)
196-
          (call-with-repo project-name
197-
            (lambda (repo)
198-
              (show-raw (project-file-raw repo path #:ref ref)))))
199-
         ((project-name "commits")
200-
          (call-with-repo project-name
201-
            (lambda (repo)
202-
              (show (style (project-commits project-name repo #f)
203-
                    project-name "-" footer)))))
204-
         ((project-name "commits" ref)
205-
          (call-with-repo project-name
206-
            (lambda (repo)
207-
              (show (style (project-commits project-name repo ref)
208-
                    project-name ref footer)))))
209-
         ((project-name "commit" ref)
210-
          (call-with-repo project-name
211-
            (lambda (repo)
212-
              (show (style (project-commit project-name repo ref)
213-
                           project-name ref footer)))))
214-
         ((project-name "tags")
215-
          (call-with-repo project-name
216-
            (lambda (repo)
217-
              (show (style (project-tags project-name repo)
218-
                    project-name "-" footer)))))
219-
         (_ (not-found request footer)))))))
218+
       (let-values (((project-name path) (find-project-component request)))
219+
         (match (cons project-name path)
220+
           (("" . ())
221+
            (pk 'index)
222+
            (show (index-page (projects) base-git-url index-title intro footer)))
223+
           (("" . args)
224+
            (pk '404 args)
225+
            (repo-404 "Project not found" ""
226+
                      "-"))
227+
           ((project-name)
228+
            (call-with-repo project-name
229+
              (lambda (repo)
230+
                (show (style (project-index base-git-url project-name repo)
231+
                             project-name "-" footer)))))
232+
           ((project-name "tree" ref path ...)
233+
            (call-with-repo project-name
234+
              (lambda (repo)
235+
                (show (style (project-files project-name repo #:ref ref #:path path)
236+
                             project-name ref footer)))))
237+
           ((project-name "raw" ref path ...)
238+
            (call-with-repo project-name
239+
              (lambda (repo)
240+
                (show-raw (project-file-raw repo path #:ref ref)))))
241+
           ((project-name "commits")
242+
            (call-with-repo project-name
243+
              (lambda (repo)
244+
                (show (style (project-commits project-name repo #f)
245+
                      project-name "-" footer)))))
246+
           ((project-name "commits" ref)
247+
            (call-with-repo project-name
248+
              (lambda (repo)
249+
                (show (style (project-commits project-name repo ref)
250+
                      project-name ref footer)))))
251+
           ((project-name "commit" ref)
252+
            (call-with-repo project-name
253+
              (lambda (repo)
254+
                (show (style (project-commit project-name repo ref)
255+
                             project-name ref footer)))))
256+
           ((project-name "tags")
257+
            (call-with-repo project-name
258+
              (lambda (repo)
259+
                (show (style (project-tags project-name repo)
260+
                      project-name "-" footer)))))
261+
           (_ (not-found request footer))))))))