source: project/release/4/neuromorpho/neuromorpho.scm @ 14615

Last change on this file since 14615 was 14615, checked in by Ivan Raikov, 11 years ago

uri-escape local file and directory names

File size: 14.0 KB
Line 
1
2;;
3;; Access the NeuroMorpho database and download morphology files.
4;;
5;; Copyright 2009 Ivan Raikov and the Okinawa Institute of Science and
6;; Technology.
7;;
8;; This program is free software: you can redistribute it and/or
9;; modify it under the terms of the GNU General Public License as
10;; published by the Free Software Foundation, either version 3 of the
11;; License, or (at your option) any later version.
12;;
13;; This program is distributed in the hope that it will be useful, but
14;; WITHOUT ANY WARRANTY; without even the implied warranty of
15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
16;; General Public License for more details.
17;;
18;; A full copy of the GPL license can be found at
19;; <http://www.gnu.org/licenses/>.
20;;
21
22(require-extension
23 extras regex posix utils extras files data-structures tcp srfi-1 srfi-13
24 matchable html-parser sxml-transforms sxpath uri-generic args)
25
26
27(define-constant +default-tcp-connect-timeout+ 10000) ; 10 seconds
28(define-constant +default-tcp-read/write-timeout+ 20000) ; 20 seconds
29
30(tcp-connect-timeout +default-tcp-connect-timeout+)
31(tcp-read-timeout +default-tcp-read/write-timeout+)
32(tcp-write-timeout +default-tcp-read/write-timeout+)
33
34(define *quiet* #f)
35
36(define *user-agent* "chicken-neuromorpho")
37
38(define (d fstr . args)
39  (let ([port (if *quiet* (current-error-port) (current-output-port))])
40    (apply fprintf port fstr args)
41    (flush-output port) ) )
42
43(define data-dir                  (make-parameter #f))
44(define morphology-file           (make-parameter 'S))
45(define meta-filter               (make-parameter '("Note" "")))
46(define print-meta?               (make-parameter #f))
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)
52      (let ([dir (create-temporary-directory)])
53        (data-dir dir)
54        dir ) ) )
55
56(define (create-temporary-directory)
57  (let ((dir (or (getenv "TMPDIR") (getenv "TEMP") (getenv "TMP") "/tmp")))
58    (let loop ()
59      (let* ((n (##sys#fudge 16))       ; current milliseconds
60             (pn (make-pathname dir (string-append "neuromorpho-" (number->string n 16)) "tmp")))
61        (cond ((file-exists? pn) (loop))
62              (else (create-directory pn) pn))))))
63
64(define (network-failure msg . args)
65  (signal
66   (make-composite-condition
67    (make-property-condition
68       'exn
69       'message "invalid response from server"
70       'arguments args)
71    (make-property-condition 'http-fetch))) )
72
73(define (make-HTTP-GET/1.1 location user-agent host
74                           #!key
75                           (port 80)
76                           (connection "close")
77                           (accept "*")
78                           (content-length 0))
79  (conc
80   "GET " location " HTTP/1.1" "\r\n"
81   "Connection: " connection "\r\n"
82   "User-Agent: " user-agent "\r\n"
83   "Accept: " accept "\r\n"
84   "Host: " host #\: port "\r\n"
85   "Content-length: " content-length "\r\n"
86   "\r\n") )
87
88(define (match-http-response rsp)
89  (and (string? rsp)
90       (string-match "HTTP/[0-9.]+\\s+([0-9]+)\\s+.*" rsp)) )
91
92(define (response-match-code? mrsp code)
93  (and mrsp (string=? (number->string code) (cadr mrsp))) )
94
95(define (match-chunked-transfer-encoding ln)
96  (string-match "[Tt]ransfer-[Ee]ncoding:\\s*chunked.*" ln) )
97
98
99(define (http-fetch uri dest)
100  (d "fetching ~s ...~%" (uri->string uri))
101  (match-let (((_ ((_ host port) ('/ . path) query) _) (uri->list uri)))
102    (let* ((port      (or port 80))
103           (locn      (uri->string (update-uri (update-uri uri scheme: #f) host: #f)))
104           (query     (and query (not (string-null? query)) query))
105           (filedir   (uri-decode-string (string-concatenate (intersperse (if query path (drop-right path 1)) "/"))))
106           (filename  (uri-decode-string (or (and query (cadr (string-split query "="))) (last path))))
107           (dest      (make-pathname dest filedir))
108           (filepath  (make-pathname dest filename)))
109      (if (file-exists? filepath) filepath
110          (begin
111          (d "connecting to host ~s, port ~a ...~%" host port)
112          (let-values ([(in out) (tcp-connect host port)])
113                      (d "requesting ~s ...~%" locn)
114                      (display
115                       (make-HTTP-GET/1.1 locn *user-agent* host port: port accept: "*/*")
116                       out)
117                      (flush-output out)
118                      (d "reading response ...~%")
119                      (let ([chunked #f] [ok-response #f])
120                        (let* ([h1 (read-line in)]
121                               [response-match (match-http-response h1)])
122                          (d "~a~%" h1)
123                          ;;*** handle redirects here
124                          (cond ((response-match-code? response-match 200)
125                                 (set! ok-response #t))
126                                ((response-match-code? response-match 404)
127                                 (d "file not found on server: ~s~%" locn))
128                                (else (network-failure "invalid response from server" h1) ))
129                        (and ok-response
130                            (begin
131                              (let loop ()
132                                (let ([ln (read-line in)])
133                                  (unless (string-null? ln)
134                                    (when (match-chunked-transfer-encoding ln) (set! chunked #t))
135                                    (d "~a~%" ln)
136                                    (loop) ) ) )
137                              (if chunked
138                                  (begin
139                                    (d "reading chunks ...~%")
140                                    (let ([data (read-chunks in)])
141                                      (close-input-port in)
142                                      (close-input-port out)
143                                      (if (not (file-exists? dest)) (create-directory dest #t))
144                                      (d "writing to ~s~%" filepath)
145                                      (with-output-to-file filepath (cut display data) )
146                                      filepath))
147                                 
148                                  (begin
149                                    (d "reading data ...~%")
150                                    (let ([data (read-string #f in)])
151                                      (close-input-port in)
152                                      (close-input-port out)
153                                      (if (not (file-exists? dest)) (create-directory dest #t))
154                                      (d "writing to ~s~%" filepath)
155                                      (with-output-to-file filepath (cut display data) binary:)
156                                      filepath)))))
157                        )
158                      )))))))
159
160  (define (read-chunks in)
161    (let get-chunks ([data '()])
162      (let ([size (string->number (read-line in) 16)])
163        (if (zero? size)
164            (string-concatenate-reverse data)
165            (let ([chunk (read-string size in)])
166              (read-line in)
167              (get-chunks (cons chunk data)) ) ) ) ) )
168
169(define (div-class class-name)
170  `(div (@ class *text* ,(lambda (x ns) (or (and (pair? x) (string=? (car x) class-name)) '())))))
171
172(define (parse-sxml fpath)
173  (cons '*TOP* (html->sxml (open-input-file fpath)))) 
174
175(define (anchor->url tree)
176  (post-order tree
177     `((a ((@ ((*default* . ,(lambda args args))) . ,(lambda args args)))
178        . ,(lambda (tag maybe-attrs . elems)
179               (let* ((attrs  (and (pair? maybe-attrs) (eq? '@ (car maybe-attrs))
180                                   (cdr maybe-attrs)))
181                      (href   (assoc 'href attrs)))
182                 (and href (pair? elems) `(url ,(cadr href) ,(car elems))))))
183       (*text* . ,(lambda (trigger str) str)))))
184
185(define (extract-info-links sxml)
186  (let* ((info-links ((sxpath `(// html body // ,(div-class "info") table // tr // (a (@ href)) ))
187                      sxml)))
188    (anchor->url info-links)))
189
190(define (table->alist tree)
191  (and (pair? tree)
192  (filter (lambda (x) (not (null? x))) 
193    (post-order (car tree)
194     `((tr ((td . ,(lambda (tag . elems) 
195                     (let ((elems (filter (lambda (x) (not (null? x))) elems)))
196                       (or (and (pair? elems) (car elems)) '())))))
197        . ,(lambda (tag . elems)
198             (let ((elems (filter (lambda (x) (and (not (and (string? x) (string-null? x))) (not (null? x)))) elems)))
199               (cond ((and (pair? elems) (pair? (cdr elems)))
200                      (let ((key   (car (string-split (car elems) ":")))
201                            (value (cadr elems)))
202                        `(,key . ,value)))
203                     ((pair? elems) 
204                      (let ((key (car (string-split (car elems) ":"))))
205                        (list key)))
206                     (else  '())))))
207       (table      . ,(lambda (tag . elems)  elems))
208       (*text*     . ,(lambda (trigger str) (string-trim-both str)))
209       (*default*  . ,(lambda args '())))))))
210 
211
212(define (extract-metadata sxml)
213  (let* ((meta-data ((sxpath `(// html body // ,(div-class "info") // center table))
214                      sxml))
215         (detail (table->alist ((sxpath `(// table // table)) (car meta-data))))
216         (articles (cadr meta-data))
217         (measurements (table->alist ((sxpath `(// table // table)) (caddr meta-data)))))
218    `((detail . ,detail) (measurements . ,measurements))))
219
220
221(define (extract-pages-from-search-results sxml)
222  (let* ((pages ((sxpath `(// html body // center table tbody tr td input // a )) sxml)))
223    (anchor->url pages)))
224
225(define (fetch-file url)
226  (let ((ddir (get-data-dir))
227        (uri  (uri-reference (cadr url))))
228    (if (not ddir) (error "cannot create download directory" ddir))
229    (if (not (uri? uri)) (error "URL to file must not be a relative reference" uri))
230    (let ((filepath (http-fetch uri ddir)))
231      (if filepath (d "fetched ~s~%" filepath)
232          (d "unable to fetch ~s~%" (uri->string uri)))
233      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 
290                 
291(define opts
292  `(
293    ,(args:make-option (d)       (required: "DIR")   
294                       "set download directory (default is a randomly generated name in /tmp)"
295                       (data-dir arg))
296    ,(args:make-option (m)       (required: "O, S, or N")   
297                       "download morphology files (Original, Standard or None, default is standard)"
298                       (morphology-file (string->symbol (string-upcase arg))))
299    ,(args:make-option (fm)       (required: "NAME=VALUE")   
300                       "filter pages based on metadata"
301                       (meta-filter (string-split arg "=")))
302    ,(args:make-option (pm)       #:none
303                       "print metadata"
304                       (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 ",")))
312    ,(args:make-option (h help)  #:none               "Print help"
313                       (usage))))
314
315
316;; Use args:usage to generate a formatted list of options (from OPTS),
317;; suitable for embedding into help text.
318(define (usage)
319  (print "Usage: " (car (argv)) " [options...] operands ")
320  (newline)
321  (print "Where operands are HTML files that contain search results from NeuroMorpho: ")
322  (print "e.g. " (car (argv)) " neuromorpho_searchresults.html")
323  (newline)
324  (print "The following options are recognized: ")
325  (newline)
326  (print (parameterize ((args:indent 5)) (args:usage opts)))
327  (exit 1))
328
329
330;; Process arguments and collate options and arguments into OPTIONS
331;; alist, and operands (filenames) into OPERANDS.  You can handle
332;; options as they are processed, or afterwards.
333(define args    (command-line-arguments))
334
335(let-values (((options operands)  (args:parse args opts)))
336   (if (null? operands) (usage))           
337   (d "download directory is ~s~%" (get-data-dir))
338   (if (meta-filter) (d "metadata filter is ~s~%" (meta-filter)))
339
340   (let* ((data-list
341           (concatenate
342            (map (lambda (p)
343                   (let* ((search-results  (parse-sxml p))
344                          (page-list       (extract-pages-from-search-results search-results))
345                          (file-list       (map fetch-file page-list))
346                          (sxml-list       (map parse-sxml file-list))
347                          (meta-list       (map extract-metadata sxml-list))
348                          (links-list      (map (lambda (sxml) `(links . ,(extract-info-links sxml))) sxml-list)))
349                     (map (lambda (f m l) `(,f ,@m ,l))  file-list meta-list links-list)))
350                 operands)))
351          (meta-filtered-list
352           (if (and (meta-filter) (pair? (meta-filter)))
353               (let ((k  (car (meta-filter)))
354                     (rx (regexp (or (and (pair? (cdr (meta-filter))) (cadr (meta-filter))) ""))))
355                 (filter (lambda (x) 
356                           (let* ((detail  (alist-ref 'detail (cdr x)))
357                                  (propval (alist-ref k detail string=?)))
358                             (string-match rx (or (and (string? propval) propval) ""))))
359                         data-list))
360               data-list)))
361     (if (print-meta?) (for-each print 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
Note: See TracBrowser for help on using the repository browser.