Changeset 12938 in project


Ignore:
Timestamp:
01/05/09 13:50:06 (11 years ago)
Author:
felix winkelmann
Message:

added egg-list operation to henrietta

Location:
chicken/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/TODO

    r12937 r12938  
    7676*** test sudo
    7777
    78 ** henrietta
    79 *** test (regex changes)
    80 *** mode that responses with list of available eggs (ls + check for .meta files)
    81 *** mode that responses only with .meta information
    82 
    8378** library units
    8479*** read-mark list should be stored in read-table
  • chicken/trunk/henrietta.scm

    r12937 r12938  
    2424; POSSIBILITY OF SUCH DAMAGE.
    2525
     26; used environment variables:
     27;
     28; QUERY_STRING
     29; REMOTE_ADDR (optional)
     30
     31; URL arguments:
     32;
     33; version=<version>
     34; name=<name>
     35; tests
     36; list
     37
    2638
    2739(require-library setup-download regex extras utils ports srfi-1 posix)
     
    3143
    3244  (import scheme chicken regex extras utils ports srfi-1 posix)
    33   (import setup-download)
     45  (import setup-api setup-download)
    3446
    3547  (define *default-transport* 'svn)
     
    8698      (print "\n#!eof") ) )
    8799
     100  (define (listing)
     101    (let ((dir (handle-exceptions ex
     102                   (fail ((condition-property-accessor 'exn 'message) ex)
     103                         ((condition-property-accessor 'exn 'arguments) ex))
     104                 (list-extensions
     105                  *default-transport* *default-location*
     106                  quiet: #t
     107                  username: *username*
     108                  password: *password*))))
     109      (if dir
     110          (display dir)
     111          (fail "unable to retrieve extension-list"))))
     112
    88113  (define query-string-rx (regexp "[^?]+\\?(.+)"))
    89114  (define query-arg-rx (regexp "^&?(\\w+)=([^&]+)"))
     
    118143                   (set! *tests* #t)
    119144                   (loop rest))
     145                  ((string=? ms "list")
     146                   (listing))
    120147                  (else
    121148                   (warning "unrecognized query option" ms)
  • chicken/trunk/setup-download.scm

    r12937 r12938  
    3333                        locate-egg/svn
    3434                        locate-egg/http
     35                        list-extensions
    3536                        temporary-directory)
    3637
     
    5758          (temporary-directory dir)
    5859          dir)))
     60
     61  (define (list-eggs/local dir)
     62    (string-concatenate
     63     (map (cut string-append <> "\n")
     64          (directory dir))))
    5965
    6066  (define (locate-egg/local egg dir #!optional version destination)
     
    7884            (or (and hastrunk trunkdir)
    7985                eggdir)))))
     86
     87  (define (list-eggs/svn repo #!optional username password)
     88    (call/cc
     89     (lambda (k)
     90       (define (runcmd cmd)
     91         (unless (zero? (system cmd))
     92           (k #f)))
     93       (let* ((uarg (if username (string-append "--username='" username "'") ""))
     94              (parg (if password (string-append "--password='" password "'") ""))
     95              (cmd (sprintf "svn ls ~a ~a ~a" uarg parg (qs repo))))
     96         (d "listing extension directory ...~%  ~a~%" cmd)
     97         (string-concatenate
     98          (map (lambda (str) (string-append (string-chomp str "/") "\n"))
     99               (with-input-from-pipe cmd read-lines)))))))
    80100 
    81101  (define (locate-egg/svn egg repo #!optional version destination username
     
    88108       (let* ((uarg (if username (string-append "--username='" username "'") ""))
    89109              (parg (if password (string-append "--password='" password "'") ""))
    90               (cmd (sprintf "svn ls ~a ~a -R \"~a/~a\"" uarg parg repo egg)))
     110              (cmd (sprintf "svn ls ~a ~a -R ~a" uarg parg (qs (make-pathname repo egg)))))
    91111         (d "checking available versions ...~%  ~a~%" cmd)
    92112         (let* ((files (with-input-from-pipe cmd read-lines))
     
    119139           tmpdir)) )))
    120140
     141  (define (deconstruct-url url)
     142    (let ((m (string-match "(http://)?([^/:]+)(:([^:/]+))?(/.+)" url)))
     143      (values
     144       (if m (caddr m) url)
     145       (if (and m (cadddr m))
     146           (or (string->number (list-ref m 4))
     147               (error "not a valid port" (list-ref m 4)))
     148           80)
     149       (if m (list-ref m 5) "/"))))
     150
    121151  (define (locate-egg/http egg url #!optional version destination tests)
    122     (let* ((tmpdir (or destination (get-temporary-directory)))
    123            (m (string-match "(http://)?([^/:]+)(:([^:/]+))?(/.+)" url))
    124            (host (if m (caddr m) url))
    125            (port (if (and m (cadddr m))
    126                      (or (string->number (list-ref m 4))
    127                          (error "not a valid port" (list-ref m 4)))
    128                      80))
    129            (loc (string-append
    130                  (if m (list-ref m 5) "/")
    131                  "?name=" egg
    132                  (if version
    133                      (string-append "&version=" version)
    134                      "")
    135                  (if tests
    136                      "&tests=yes"
    137                      "")))
    138            (eggdir (make-pathname tmpdir egg)))
    139       (unless (file-exists? eggdir)
    140         (create-directory eggdir))
    141       (http-fetch host port loc eggdir)
    142       eggdir))
     152    (let ((tmpdir (or destination (get-temporary-directory))))
     153      (let-values (((host port loc) (deconstruct-url url)))
     154        (let ((loc (string-append
     155                    loc
     156                    "?name=" egg
     157                    (if version
     158                        (string-append "&version=" version)
     159                        "")
     160                    (if tests
     161                        "&tests=yes"
     162                        "")))
     163              (eggdir (make-pathname tmpdir egg)))
     164          (unless (file-exists? eggdir)
     165            (create-directory eggdir))
     166          (http-fetch host port loc eggdir)
     167          eggdir))))
    143168
    144169  (define (network-failure msg . args)
     
    225250        ((http)
    226251         (locate-egg/http name location version destination tests))
    227         (else (error "unsupported transport" transport)))) )
     252        (else (error "can not retrieve extension unsupported transport" transport)))) )
     253
     254  (define (list-extensions transport location #!key quiet username password)
     255    (fluid-let ((*quiet* quiet))
     256      (case transport
     257        ((local)
     258         (list-eggs/local location))
     259        ((svn)
     260         (list-eggs/svn location username password))
     261        (else (error "can not list extensions - unsupported transport" transport)))) )
    228262
    229263)
Note: See TracChangeset for help on using the changeset viewer.