Changeset 14614 in project


Ignore:
Timestamp:
05/13/09 06:52:08 (11 years ago)
Author:
Ivan Raikov
Message:

added code to create an index page, and set version to 1.1

Location:
release/4/neuromorpho
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/neuromorpho/neuromorpho.scm

    r14595 r14614  
    4141    (flush-output port) ) )
    4242
    43 (define download-directory        (make-parameter #f))
    44 (define download-morphology-file  (make-parameter 'S))
    45 (define meta-filter               (make-parameter '("Note:" "")))
     43(define data-dir                  (make-parameter #f))
     44(define morphology-file           (make-parameter 'S))
     45(define meta-filter               (make-parameter '("Note" "")))
    4646(define print-meta?               (make-parameter #f))
    47 
    48 (define (get-download-directory)
    49   (or (download-directory)
     47(define make-index?               (make-parameter #f))
     48(define index-fields              (make-parameter '("Neuron Name" "Note")))
     49
     50(define (get-data-dir)
     51  (or (data-dir)
    5052      (let ([dir (create-temporary-directory)])
    51         (download-directory dir)
     53        (data-dir dir)
    5254        dir ) ) )
    5355
     
    9698
    9799(define (http-fetch uri dest)
    98   (d "fetching ~s ...~%" uri)
     100  (d "fetching ~s ...~%" (uri->string uri))
    99101  (match-let (((_ ((_ host port) ('/ . path) query) _) (uri->list uri)))
    100102    (let* ((port      (or port 80))
     
    222224
    223225(define (fetch-file url)
    224   (let ((ddir (get-download-directory))
     226  (let ((ddir (get-data-dir))
    225227        (uri  (uri-reference (cadr url))))
    226228    (if (not ddir) (error "cannot create download directory" ddir))
     
    230232          (d "unable to fetch ~s~%" (uri->string uri)))
    231233      filepath)))
     234
     235
     236(define (make-index-page info morphology-files)
     237  (let ((title (sprintf "NeuroMorpho search results")))
     238    (sxml->html
     239     `((literal "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n")
     240       (literal "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">")
     241       (html ,(header title)
     242        (body
     243         ,(titlebar title)
     244         ,(content (prelude title) `(table (tr ,(map (lambda (x) `(td ,x)) (index-fields) )
     245                                               (td "Details") (td "Morphology file"))
     246                                           ,(map record-info info morphology-files))))
     247         )))))
     248
     249(define (record-info info morphology-file)
     250  (let ((detail (alist-ref 'detail (cdr info))))
     251    (let ((index-vals (map (lambda (x) (alist-ref x detail string=?)) (index-fields))))
     252      `(tr ,@(map (lambda (v) `(td ,v)) index-vals)
     253           (td (a (@ (href ,(make-absolute-pathname (current-directory) (car info)))) "Details"))
     254           ,(or (and morphology-file
     255                     `(td (a (@ (href ,(string-append
     256                                        "file://" (make-absolute-pathname (current-directory)
     257                                                                          morphology-file))))
     258                             "Morphology file")))
     259                `(td "Morphology file not found"))))))
     260
     261(define (header title)
     262  `(head
     263;    (link (@ (rel "stylesheet")
     264;             (type "text/css")
     265;             (href "http://chicken.wiki.br/common-css")))
     266    (title ,title)))
     267
     268(define (titlebar title)
     269  `(div (@ (id "header"))
     270        (h1 (a (@ (href "http://neuromorpho.org/"))
     271               ,title))))
     272
     273(define (prelude title)   `())
     274
     275(define (content . body)
     276  `(div (@ (id "content-box"))
     277        (div (@ (class "content"))
     278             ,body)))
     279
     280 
     281(define (sxml->html doc)
     282  (SRV:send-reply
     283   (pre-post-order
     284    doc
     285    ;; LITERAL tag contents are used as raw HTML.
     286    `((literal *preorder* . ,(lambda (tag . body) (map ->string body)))
     287      ,@universal-conversion-rules))))
     288
     289 
    232290                 
    233291(define opts
     
    235293    ,(args:make-option (d)       (required: "DIR")   
    236294                       "set download directory (default is a randomly generated name in /tmp)"
    237                        (download-directory arg))
     295                       (data-dir arg))
    238296    ,(args:make-option (m)       (required: "O, S, or N")   
    239297                       "download morphology files (Original, Standard or None, default is standard)"
    240                        (download-morphology-file (string->symbol (string-upcase arg))))
     298                       (morphology-file (string->symbol (string-upcase arg))))
    241299    ,(args:make-option (fm)       (required: "NAME=VALUE")   
    242300                       "filter pages based on metadata"
     
    245303                       "print metadata"
    246304                       (print-meta? #t))
     305    ,(args:make-option (i)       #:none
     306                       "make index file"
     307                       (make-index? #t))
     308    ,(args:make-option (if)       #:none
     309                       (string-append "comma-separated list of index fields "
     310                                      "(default is " (string-intersperse (index-fields) ", ") ")")
     311                       (index-fields (string-split arg ",")))
    247312    ,(args:make-option (h help)  #:none               "Print help"
    248313                       (usage))))
     
    270335(let-values (((options operands)  (args:parse args opts)))
    271336   (if (null? operands) (usage))           
    272    (d "download directory is ~s~%" (get-download-directory))
     337   (d "download directory is ~s~%" (get-data-dir))
    273338   (if (meta-filter) (d "metadata filter is ~s~%" (meta-filter)))
    274339
     
    295360               data-list)))
    296361     (if (print-meta?) (for-each print meta-filtered-list))
    297      (case (download-morphology-file)
    298        ((O S ORIGINAL STANDARD)
    299         (let* ((rx (regexp (regexp-escape (case (download-morphology-file)
    300                                             ((O ORIGINAL) "Morphology File (Original)")
    301                                             ((S STANDARD) "Morphology File (Standardized)")
    302                                             (else "")))))
    303                (download-url? (lambda (x) (string-match rx (caddr x)))))
    304           (for-each (lambda (x)
    305                       (let* ((links (alist-ref 'links (cdr x)))
    306                              (morphology-url (find download-url? links)))
    307                         (fetch-file morphology-url)))
    308                     meta-filtered-list))))))
     362     (let ((morphology-files
     363            (case (morphology-file)
     364              ((O S ORIGINAL STANDARD)
     365               (let* ((rx (regexp (regexp-escape (case (morphology-file)
     366                                                   ((O ORIGINAL) "Morphology File (Original)")
     367                                                   ((S STANDARD) "Morphology File (Standardized)")
     368                                                   (else "")))))
     369                      (download-url? (lambda (x) (string-match rx (caddr x)))))
     370                 (map (lambda (x)
     371                        (let* ((links           (alist-ref 'links (cdr x)))
     372                               (morphology-url  (find download-url? links)))
     373                          (fetch-file morphology-url)))
     374                      meta-filtered-list)))
     375              (else (list)))))
     376       (if (and (make-index?) (not (null? morphology-files)))
     377           (let ((index-file (make-pathname (make-absolute-pathname (current-directory) (get-data-dir)) "index.html")))
     378           (d "creating index file ~s...~%" index-file)
     379           (with-output-to-file index-file
     380             (lambda () (make-index-page meta-filtered-list morphology-files))))))))
     381
  • release/4/neuromorpho/neuromorpho.setup

    r14594 r14614  
    1010
    1111  ; Assoc list with properties for the program:
    12   '((version 1.0)))
     12  '((version 1.1)))
    1313;    (documentation "neuromorpho.html")))
Note: See TracChangeset for help on using the changeset viewer.