Improve error handling

Julien LepillerSun Mar 07 12:55:01+0100 2021

dd8aa2b

Improve error handling

gitile/handler.scm

3333 
3434 
(define (not-found request)
3535 
  (format #t "Not found: ~a~%" (uri->string (request-uri request)))
36-
  (values (build-response #:code 404)
37-
          (string-append "Resource not found: "
38-
                         (uri->string (request-uri request)))))
36+
  (show (style `((p "Resource not found: "
37+
                    ,(uri->string (request-uri request))))
38+
               "" "")))
3939 
4040 
(define (style page project ref)
4141 
  `(html
…
5858 
            ,@page)
5959 
       (footer (p (a (@ (href "https://lepiller.eu")) "Who am I?"))))))
6060 
61-
(define (show page)
62-
  (values '((content-type . (text/html)))
61+
(define* (show page #:key (code 200))
62+
  (values (build-response #:code code #:headers '((content-type . (text/html))))
6363 
          (with-output-to-string (lambda _ (sxml->xml page)))))
6464 
6565 
(define (show-raw page)
…
6767 
          page))
6868 
6969 
(define (gitile-handler config)
70-
  (define (get-repo name)
71-
    (let ((repo (string-append (config-repositories config)
72-
                               "/" name ".git")))
73-
      (pk 'repo repo)
74-
      (pk 'exists (file-exists? (string-append repo "/git-daemon-export-ok")))
75-
      (if (file-exists? (string-append repo "/git-daemon-export-ok"))
76-
          (repository-open repo)
77-
          #f)))
78-
70+
  (define (call-with-repo project-name callback)
71+
    (define (repo-404 content project-name ref)
72+
      (show (style content project-name ref)
73+
            #:code 404))
74+
    (define (repo-500 content)
75+
      (show content #:code 500))
76+
    (define (get-repo name)
77+
      (let ((repo (string-append (config-repositories config)
78+
                                 "/" name ".git")))
79+
        (pk 'repo repo)
80+
        (pk 'exists (file-exists? (string-append repo "/git-daemon-export-ok")))
81+
        (if (file-exists? (string-append repo "/git-daemon-export-ok"))
82+
            (repository-open repo)
83+
            #f)))
84+
  
85+
    (let ((repo (get-repo project-name)))
86+
      (if repo
87+
          (catch #t
88+
            (lambda _
89+
              (callback repo))
90+
            (lambda* (key . args)
91+
              (match key
92+
                ('not-found
93+
                 (pk 'except key args)
94+
                 (repo-404 (assoc-ref args 'content)
95+
                           project-name
96+
                           (or (assoc-ref args 'ref) "-")))
97+
                (_
98+
                  (pk 'uncaught-exception key args)
99+
                  (repo-500 `((p "Internal error")))))))
100+
          (repo-404 `((p "Repository not found: " ,project-name)) project-name
101+
                    "-"))))
79102 
  (match config
80103 
    (($ <config> port host database repositories)
81104 
     (lambda (request body)
…
83106 
       (pk 'body (if body (utf8->string body) body))
84107 
       (match (request-path-components request)
85108 
         ((project-name)
86-
          (show (style (project-index project-name (get-repo project-name))
87-
                       project-name "-")))
109+
          (call-with-repo project-name
110+
            (lambda (repo)
111+
              (show (style (project-index project-name repo)
112+
                           project-name "-")))))
88113 
         ((project-name "tree" ref path ...)
89-
          (show (style (project-files project-name (get-repo project-name)
90-
				      #:ref ref #:path path)
91-
                       project-name ref)))
114+
          (call-with-repo project-name
115+
            (lambda (repo)
116+
              (show (style (project-files project-name repo #:ref ref #:path path)
117+
                           project-name ref)))))
92118 
         ((project-name "raw" ref path ...)
93-
          (show-raw (project-file-raw (get-repo project-name) path #:ref ref)))
119+
          (call-with-repo project-name
120+
            (lambda (repo)
121+
              (show-raw (project-file-raw repo path #:ref ref)))))
94122 
         ((project-name "commits")
95-
          (show (style (project-commits project-name (get-repo project-name) #f)
96-
		       project-name "-")))
123+
          (call-with-repo project-name
124+
            (lambda (repo)
125+
              (show (style (project-commits project-name repo #f)
126+
                    project-name "-")))))
97127 
         ((project-name "commits" ref)
98-
          (show (style (project-commits project-name (get-repo project-name) ref)
99-
		       project-name ref)))
128+
          (call-with-repo project-name
129+
            (lambda (repo)
130+
              (show (style (project-commits project-name repo ref)
131+
                    project-name ref)))))
100132 
         ((project-name "commit" ref)
101-
          (show (style (project-commit project-name (get-repo project-name) ref)
102-
                       project-name ref)))
133+
          (call-with-repo project-name
134+
            (lambda (repo)
135+
              (show (style (project-commit project-name repo ref)
136+
                           project-name ref)))))
103137 
         ((project-name "tags")
104-
          (show (style (project-tags project-name (get-repo project-name))
105-
		       project-name "-")))
106-
	 (_ (not-found request)))))))
138+
          (call-with-repo project-name
139+
            (lambda (repo)
140+
              (show (style (project-tags project-name repo)
141+
                    project-name "-")))))
142+
     (_ (not-found request)))))))
gitile/repo.scm
5858 
                  repo))
5959 
6060 
(define (ref->oid repo ref)
61-
  (let ((ref-name (or ref
62-
                      (false-if-exception (reference-name (repository-head repo))))))
63-
    (or (false-if-exception (string->oid ref-name))
64-
        (false-if-exception (reference-name->oid repo ref-name))
65-
        (reference-name->oid repo (search-reference repo ref-name)))))
61+
  (define (ref->oid* repo ref)
62+
    (let ((ref-name (or ref
63+
                        (false-if-exception (reference-name (repository-head repo))))))
64+
      (or (false-if-exception (string->oid ref-name))
65+
          (false-if-exception (reference-name->oid repo ref-name))
66+
          (false-if-exception (reference-name->oid repo (search-reference repo ref-name))))))
67+
  (or (ref->oid* repo ref)
68+
      (throw 'not-found
69+
             `(content ((p "Ref not found in repository: " ,ref)))
70+
             `(ref ,ref))))
6671 
6772 
(define-record-type <file>
6873 
  (make-file name type commit)
…
98103 
  (let* ((oid (ref->oid repo ref))
99104 
         (commit (commit-lookup repo oid))
100105 
         (tree (commit-tree commit))
101-
         (entry (tree-entry-bypath tree path))
102-
         (entry-oid (tree-entry-id entry))
103-
         (blob (blob-lookup repo entry-oid)))
104-
    (blob-content blob)))
106+
         (entry (false-if-exception (tree-entry-bypath tree path))))
107+
    (if entry
108+
        (let* ((entry-oid (tree-entry-id entry))
109+
               (blob (blob-lookup repo entry-oid)))
110+
          (blob-content blob))
111+
        (throw 'not-found
112+
               `(content ((p "path not found in repository for this commit: " ,path)))
113+
               `(ref ,ref)))))
105114 
106115 
(define (last-commit-for-file path commit)
107116 
  (let* ((initial-tree (commit-tree commit))
…
146155 
147156 
(define (get-commit repo hash)
148157 
  (let* ((oid (ref->oid repo hash))
149-
         (commit (commit-lookup repo oid)))
150-
    commit))
158+
         (commit (false-if-exception (commit-lookup repo oid))))
159+
    (or commit
160+
        (throw 'not-found
161+
               `(content ((p "Commit not found in this repository: " ,hash)))
162+
               `(ref ,hash)))))