aboutsummaryrefslogtreecommitdiff
path: root/pseudo-meta-egg-info.scm
blob: 097c22e340c2737a144f91728ea4c6d37d3f1aa7 (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
72
73
74
75
76
77
78
79
;;
;; 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-client-list (uri->string tags-uri (constantly ""))
                                                  svn-opt-revision-head 2
                                                  (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)
                              (when (and (eq? (svn-file-kind r) 'directory)
                                         (not (string=? (svn-file-path r) "")))
                                (write `(release ,(svn-file-path 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-client-list (uri->string files-uri (constantly ""))
                                               svn-opt-revision-head #t
                                               (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)
                              (when (eq? (svn-file-kind f) 'file)
                                (display (svn-file-path 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")))
)