From 09cbaef2bb8ad31c9b381c61825623aae71ffc03 Mon Sep 17 00:00:00 2001
From: Peter Bex <peter@more-magic.net>
Date: Thu, 26 May 2011 22:13:39 +0200
Subject: Add initial (crappy and broken) version of pseudo-meta-egg-info egg

---
 pseudo-meta-egg-info.scm | 63 ++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 63 insertions(+)
 create mode 100644 pseudo-meta-egg-info.scm

(limited to 'pseudo-meta-egg-info.scm')

diff --git a/pseudo-meta-egg-info.scm b/pseudo-meta-egg-info.scm
new file mode 100644
index 0000000..f104e47
--- /dev/null
+++ b/pseudo-meta-egg-info.scm
@@ -0,0 +1,63 @@
+(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)
+                                        username: #f password: #f)))
+        (or (and-let* ((files (svn-ls (uri->string files-uri) '() ;; Needs recursion!
+                                      (uri-username repo-uri)
+                                      (uri-password repo-uri))))
+              (with-headers '((content-type "text/plain"))
+                (lambda ()
+                  (write-logged-response)
+                  (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")))
+)
\ No newline at end of file
-- 
cgit v1.2.3