aboutsummaryrefslogtreecommitdiff
path: root/pseudo-meta-egg-info.scm
blob: 1e02f38c13de1595d0d3f4e92c15104c44e5b67e (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
;;
;; pseudo-meta-egg-info - a Spiffy module for dynamically serving up
;; autogenerated release-info and file-lists for eggs in Subversion repos.
;;
;; This code was written by Peter Bex and is hereby placed in the Public Domain
;;
(module pseudo-meta-egg-info
  (egg-repo release-info files-list)

(import chicken scheme)
(use extras data-structures spiffy intarweb uri-common svn-client)

(define egg-repo
  (make-parameter "http://anonymous:@code.call-cc.org/svn/chicken-eggs/release/4/"))

(define (release-info continue)
  (or (and-let* ((params (uri-query (request-uri (current-request))))
                 (port (response-port (current-response)))
                 (egg-name (alist-ref 'egg params))
                 (tag-dir (update-uri (uri-reference "")
                                      path: (list egg-name "tags")))
                 (repo-uri (uri-reference (egg-repo)))
                 (tags-uri (update-uri (uri-relative-to tag-dir repo-uri)
                                       username: #f password: #f)))
        (or (and-let* ((releases (svn-ls (uri->string tags-uri (constantly "")) '()
                                         (uri-username repo-uri)
                                         (uri-password repo-uri)))
                       (files-list-uri (conc (uri->string
                                              (uri-relative-to
                                               (uri-reference "files-list")
                                               (request-uri (current-request))))
                                             ;; template, so don't make this a query
                                             "?egg={egg-name};release={egg-release}")))
              (with-headers '((content-type "text/plain"))
                (lambda ()
                  (write-logged-response)
                  (write `(uri files-list ,files-list-uri) port)
                  (newline port)
                  (for-each (lambda (r)
                              (write `(release ,(car r)) port)
                              (newline port))
                            releases)
                  (close-output-port port))))
            (send-status 500 (sprintf "Egg \"~A\" doesn't exist" egg-name))))
      (send-status 500 "No egg name given")))

(define (files-list continue)
  (or (and-let* ((params (uri-query (request-uri (current-request))))
                 (port (response-port (current-response)))
                 (egg-name (alist-ref 'egg params))
                 (egg-release (alist-ref 'release params))
                 (files-dir (update-uri (uri-reference "")
                                        path: (list egg-name "tags" egg-release "")))
                 (repo-uri (uri-reference (egg-repo)))
                 (files-uri (update-uri (uri-relative-to files-dir repo-uri))))
        (or (and-let* ((files (svn-ls (uri->string files-uri (constantly "")) '() ;; Needs recursion!
                                      (uri-username repo-uri)
                                      (uri-password repo-uri))))
              (with-headers '((content-type "text/plain"))
                (lambda ()
                  (write-logged-response)
                  (display (uri->string files-uri
                                        (lambda (u p) (conc u ":" p))) port)
                  (newline port)
                  (for-each (lambda (f) (display (car f) port) (newline port)) files)
                  (close-output-port port))))
            (send-status 500
                         (sprintf "Release \"~A\" for egg \"~A\" doesn't exist"
                                  egg-release egg-name))))
      (send-status 500 "No egg name or release given")))
)