;;
;; 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 *default-chicken-release* "4")

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

;; This works on raw URI strings, not URI objects (for now?)
(define (replace-uri-patterns uri patterns)
  (string-translate* uri (map (lambda (pattern)
                                (cons (conc "{" (car pattern) "}")
                                      (uri-encode-string (->string (cdr pattern)))))
                              patterns)))

(define (release-info continue)
  (or (and-let* ((params (uri-query (request-uri (current-request))))
                 (port (response-port (current-response)))
                 (chicken-release (string->number
                                   (alist-ref 'release params eq?
                                              *default-chicken-release*)))
                 (egg-name (alist-ref 'egg params))
                 ((not (string=? egg-name "")))
                 (tag-dir (update-uri (uri-reference "")
                                      path: (list egg-name "tags")))
                 (uri-string (replace-uri-patterns
                              (egg-repo)
                              `((chicken-release . ,chicken-release))))
                 (repo-uri (uri-reference uri-string))
                 (tags-uri (update-uri (uri-relative-to tag-dir repo-uri)
                                       username: #f password: #f)))
        (or (and-let* ((egg-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};egg-release={egg-release};chicken-release={chicken-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)))
                            egg-releases)
                  (close-output-port port))))
            (send-status 404 (sprintf "Egg \"~A\" doesn't exist or has no tags dir" egg-name))))
      (send-status 400 "No egg name given")))

(define (files-list continue)
  (or (and-let* ((params (uri-query (request-uri (current-request))))
                 (port (response-port (current-response)))
                 (chicken-release (string->number
                                   (alist-ref 'chicken-release params eq?
                                              *default-chicken-release*)))
                 (egg-name (alist-ref 'egg params))
                 ((not (string=? egg-name "")))
                 (egg-release (alist-ref 'egg-release params))
                 ((not (string=? egg-release "")))
                 (files-dir (update-uri (uri-reference "")
                                        path: (list egg-name "tags" egg-release)))
                 (uri-string (replace-uri-patterns
                              (egg-repo)
                              `((chicken-release . ,chicken-release))))
                 (repo-uri (uri-reference uri-string))
                 (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 404
                         (sprintf "Release \"~A\" for egg \"~A\" (CHICKEN version ~A) doesn't exist"
                                  egg-release egg-name chicken-release))))
      (send-status 400 "No egg name or release given")))
)