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

Last change on this file since 15732 was 15732, checked in by Ivan Raikov, 10 years ago

fixes to neuromorpho meta filter

File size: 14.9 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 (quotewrapped? str)
28  (and (string? str) (string-prefix? "\"" str) (string-suffix? "\"" str) ))
29
30(define (quotewrap str)
31  (cond ((quotewrapped? str) str)
32        ((string-any char-whitespace? str)
33         (string-append "\"" str "\""))
34        (else str)))
35
36(define (create-directory dir . rest)
37  (system* "mkdir -p ~a" (quotewrap dir)))
38
39(define-constant +default-tcp-connect-timeout+ 10000) ; 10 seconds
40(define-constant +default-tcp-read/write-timeout+ 20000) ; 20 seconds
41
42(tcp-connect-timeout +default-tcp-connect-timeout+)
43(tcp-read-timeout +default-tcp-read/write-timeout+)
44(tcp-write-timeout +default-tcp-read/write-timeout+)
45
46(define *quiet* #f)
47
48(define *user-agent* "chicken-neuromorpho")
49
50(define (d fstr . args)
51  (let ([port (if *quiet* (current-error-port) (current-output-port))])
52    (apply fprintf port fstr args)
53    (flush-output port) ) )
54
55(define data-dir                  (make-parameter #f))
56(define morphology-file           (make-parameter 'S))
57(define meta-filter               (make-parameter '(("Note" ""))))
58(define print-meta?               (make-parameter #f))
59(define make-index?               (make-parameter #f))
60(define index-fields              (make-parameter '("Neuron Name" "Note")))
61
62(define (get-data-dir)
63  (or (data-dir)
64      (let ([dir (create-temporary-directory)])
65        (data-dir dir)
66        dir ) ) )
67
68(define (create-temporary-directory)
69  (let ((dir (or (getenv "TMPDIR") (getenv "TEMP") (getenv "TMP") "/tmp")))
70    (let loop ()
71      (let* ((n (##sys#fudge 16))       ; current milliseconds
72             (pn (make-pathname dir (string-append "neuromorpho-" (number->string n 16)) "tmp")))
73        (cond ((file-exists? pn) (loop))
74              (else (create-directory pn) pn))))))
75
76(define (network-failure msg . args)
77  (signal
78   (make-composite-condition
79    (make-property-condition
80       'exn
81       'message "invalid response from server"
82       'arguments args)
83    (make-property-condition 'http-fetch))) )
84
85
86
87(define (make-HTTP-GET/1.1 location user-agent host
88                           #!key
89                           (port 80)
90                           (connection "close")
91                           (accept "*")
92                           (content-length 0))
93  (conc
94   "GET " location " HTTP/1.1" "\r\n"
95   "Connection: " connection "\r\n"
96   "User-Agent: " user-agent "\r\n"
97   "Accept: " accept "\r\n"
98   "Host: " host #\: port "\r\n"
99   "Content-length: " content-length "\r\n"
100   "\r\n") )
101
102(define (match-http-response rsp)
103  (and (string? rsp)
104       (string-match "HTTP/[0-9.]+\\s+([0-9]+)\\s+.*" rsp)) )
105
106(define (response-match-code? mrsp code)
107  (and mrsp (string=? (number->string code) (cadr mrsp))) )
108
109(define (match-chunked-transfer-encoding ln)
110  (string-match "[Tt]ransfer-[Ee]ncoding:\\s*chunked.*" ln) )
111
112
113(define (http-fetch uri dest)
114  (d "fetching ~s ...~%" (uri->string uri))
115  (match-let (((_ ((_ host port) ('/ . path) query) _) (uri->list uri)))
116    (let* ((port      (or port 80))
117           (locn      (uri->string (update-uri (update-uri uri scheme: #f) host: #f)))
118           (query     (and query (not (string-null? query)) query))
119           (filedir   (uri-decode-string (string-concatenate (intersperse (if query path (drop-right path 1)) "/"))))
120           (filename  (uri-decode-string (or (and query (cadr (string-split query "="))) (last path))))
121           (dest      (make-pathname dest filedir))
122           (filepath  (make-pathname dest filename)))
123      (if (file-exists? filepath) filepath
124          (begin
125          (d "connecting to host ~s, port ~a ...~%" host port)
126          (let-values ([(in out) (tcp-connect host port)])
127                      (d "requesting ~s ...~%" locn)
128                      (display
129                       (make-HTTP-GET/1.1 locn *user-agent* host port: port accept: "*/*")
130                       out)
131                      (flush-output out)
132                      (d "reading response ...~%")
133                      (let ([chunked #f] [ok-response #f])
134                        (let* ([h1 (read-line in)]
135                               [response-match (match-http-response h1)])
136                          (d "~a~%" h1)
137                          ;;*** handle redirects here
138                          (cond ((response-match-code? response-match 200)
139                                 (set! ok-response #t))
140                                ((response-match-code? response-match 404)
141                                 (d "file not found on server: ~s~%" locn))
142                                (else (network-failure "invalid response from server" h1) ))
143                        (and ok-response
144                            (begin
145                              (let loop ()
146                                (let ([ln (read-line in)])
147                                  (unless (string-null? ln)
148                                    (when (match-chunked-transfer-encoding ln) (set! chunked #t))
149                                    (d "~a~%" ln)
150                                    (loop) ) ) )
151                              (if chunked
152                                  (begin
153                                    (d "reading chunks ...~%")
154                                    (let ([data (read-chunks in)])
155                                      (close-input-port in)
156                                      (close-input-port out)
157                                      (if (not (file-exists? dest)) (create-directory dest #t))
158                                      (d "writing to ~s~%" filepath)
159                                      (with-output-to-file filepath (cut display data) )
160                                      filepath))
161                                 
162                                  (begin
163                                    (d "reading data ...~%")
164                                    (let ([data (read-string #f in)])
165                                      (close-input-port in)
166                                      (close-input-port out)
167                                      (if (not (file-exists? dest)) (create-directory dest #t))
168                                      (d "writing to ~s~%" filepath)
169                                      (with-output-to-file filepath (cut display data) binary:)
170                                      filepath)))))
171                        )
172                      )))))))
173
174  (define (read-chunks in)
175    (let get-chunks ([data '()])
176      (let ([size (string->number (read-line in) 16)])
177        (if (zero? size)
178            (string-concatenate-reverse data)
179            (let ([chunk (read-string size in)])
180              (read-line in)
181              (get-chunks (cons chunk data)) ) ) ) ) )
182
183(define (div-class class-name)
184  `(div (@ class *text* ,(lambda (x ns) (or (and (pair? x) (string=? (car x) class-name)) '())))))
185
186(define (parse-sxml fpath)
187  (with-input-from-file fpath
188    (lambda () (cons '*TOP* (html->sxml (current-input-port))))))
189
190(define (anchor->url tree)
191  (post-order tree
192     `((a ((@ ((*default* . ,(lambda args args))) . ,(lambda args args)))
193        . ,(lambda (tag maybe-attrs . elems)
194               (let* ((attrs  (and (pair? maybe-attrs) (eq? '@ (car maybe-attrs))
195                                   (cdr maybe-attrs)))
196                      (href   (assoc 'href attrs)))
197                 (and href (pair? elems) `(url ,(cadr href) ,(car elems))))))
198       (*text* . ,(lambda (trigger str) str)))))
199
200(define (extract-info-links sxml)
201  (let* ((info-links ((sxpath `(// html body // ,(div-class "info") table // tr // (a (@ href)) ))
202                      sxml)))
203    (anchor->url info-links)))
204
205(define (table->alist tree)
206  (and (pair? tree)
207  (filter (lambda (x) (not (null? x))) 
208    (post-order (car tree)
209     `((tr ((td . ,(lambda (tag . elems) 
210                     (let ((elems (filter (lambda (x) (not (null? x))) elems)))
211                       (or (and (pair? elems) (car elems)) '())))))
212        . ,(lambda (tag . elems)
213             (let ((elems (filter (lambda (x) (and (not (and (string? x) (string-null? x))) (not (null? x)))) elems)))
214               (cond ((and (pair? elems) (pair? (cdr elems)))
215                      (let ((key   (car (string-split (car elems) ":")))
216                            (value (cadr elems)))
217                        `(,key . ,value)))
218                     ((pair? elems) 
219                      (let ((key (car (string-split (car elems) ":"))))
220                        (list key)))
221                     (else  '())))))
222       (table      . ,(lambda (tag . elems)  elems))
223       (*text*     . ,(lambda (trigger str) (string-trim-both str)))
224       (*default*  . ,(lambda args '())))))))
225 
226
227(define (extract-metadata sxml)
228  (let* ((meta-data ((sxpath `(// html body // ,(div-class "info") // center table))
229                      sxml))
230         (detail (table->alist ((sxpath `(// table // table)) (car meta-data))))
231         (articles (cadr meta-data))
232         (measurements (table->alist ((sxpath `(// table // table)) (caddr meta-data)))))
233    `((detail . ,detail) (measurements . ,measurements))))
234
235
236(define (extract-pages-from-search-results sxml)
237  (let* ((pages ((sxpath `(// html body // center table tbody tr td input // a )) sxml)))
238    (anchor->url pages)))
239
240(define (fetch-file url)
241  (let ((ddir (get-data-dir))
242        (uri  (uri-reference (cadr url))))
243    (if (not ddir) (error "cannot create download directory" ddir))
244    (if (not (uri? uri)) (error "URL to file must not be a relative reference" uri))
245    (let ((filepath (http-fetch uri ddir)))
246      (if filepath (d "fetched ~s~%" filepath)
247          (d "unable to fetch ~s~%" (uri->string uri)))
248      filepath)))
249
250
251(define (make-index-page info morphology-files)
252  (let ((title (sprintf "NeuroMorpho search results")))
253    (sxml->html
254     `((literal "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n")
255       (literal "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">")
256       (html ,(header title)
257        (body
258         ,(titlebar title)
259         ,(content (prelude title) `(table (tr ,(map (lambda (x) `(td ,x)) (index-fields) )
260                                               (td "Details") (td "Morphology file"))
261                                           ,(map record-info info morphology-files))))
262         )))))
263
264(define (record-info info morphology-file)
265  (let ((detail (alist-ref 'detail (cdr info))))
266    (let ((index-vals (map (lambda (x) (alist-ref x detail string-ci=?)) (index-fields))))
267      `(tr ,@(map (lambda (v) `(td ,v)) index-vals) 
268           (td (a (@ (href ,(make-absolute-pathname (current-directory) (car info)))) "Details"))
269           ,(or (and morphology-file 
270                     `(td (a (@ (href ,(string-append
271                                        "file://" (make-absolute-pathname (current-directory) 
272                                                                          morphology-file)))) 
273                             "Morphology file")))
274                `(td "Morphology file not found"))))))
275
276(define (header title)
277  `(head
278;    (link (@ (rel "stylesheet")
279;             (type "text/css")
280;             (href "http://chicken.wiki.br/common-css")))
281    (title ,title)))
282
283(define (titlebar title)
284  `(div (@ (id "header"))
285        (h1 (a (@ (href "http://neuromorpho.org/"))
286               ,title))))
287
288(define (prelude title)   `())
289
290(define (content . body)
291  `(div (@ (id "content-box"))
292        (div (@ (class "content"))
293             ,body)))
294
295 
296(define (sxml->html doc)
297  (SRV:send-reply
298   (pre-post-order
299    doc
300    ;; LITERAL tag contents are used as raw HTML.
301    `((literal *preorder* . ,(lambda (tag . body) (map ->string body)))
302      ,@universal-conversion-rules))))
303
304 
305                 
306(define opts
307  `(
308    ,(args:make-option (d)       (required: "DIR")   
309                       "set download directory (default is a randomly generated name in /tmp)"
310                       (data-dir arg))
311    ,(args:make-option (m)       (required: "O, S, or N")   
312                       "download morphology files (Original, Standard or None, default is standard)"
313                       (morphology-file (string->symbol (string-upcase arg))))
314    ,(args:make-option (fm)       (required: "NAME1=REGEXP1[,NAME2!=REGEXP2 ...]")   
315                       "filter pages based on metadata"
316                       (meta-filter
317                        (map
318                         (lambda (x) 
319                           (match (string-split x "!=")
320                                  ((n v) `(!= . ,(map string-trim-both (list n v))))
321                                  (else
322                                   (match (string-split x "=")
323                                    ((n v ) `(= . ,(map string-trim-both (list n v))))
324                                    (else   `(= ,(string-trim-both x) ""))))))
325                         (string-split arg ","))))
326    ,(args:make-option (pm)       #:none
327                       "print metadata"
328                       (print-meta? #t))
329    ,(args:make-option (i)       #:none
330                       "make index file"
331                       (make-index? #t))
332    ,(args:make-option (if)       (required: "FIELD1,...")
333                       (string-append "comma-separated list of index fields "
334                                      "(default is " (string-intersperse (index-fields) ", ") ")")
335                       (index-fields (map string-trim-both (string-split (or arg "") ","))))
336    ,(args:make-option (h help)  #:none               "Print help"
337                       (usage))))
338
339
340;; Use args:usage to generate a formatted list of options (from OPTS),
341;; suitable for embedding into help text.
342(define (usage)
343  (print "Usage: " (car (argv)) " [options...] operands ")
344  (newline)
345  (print "Where operands are HTML files that contain search results from NeuroMorpho: ")
346  (print "e.g. " (car (argv)) " neuromorpho_searchresults.html")
347  (newline)
348  (print "The following options are recognized: ")
349  (newline)
350  (print (parameterize ((args:indent 5)) (args:usage opts)))
351  (exit 1))
352
353
354;; Process arguments and collate options and arguments into OPTIONS
355;; alist, and operands (filenames) into OPERANDS.  You can handle
356;; options as they are processed, or afterwards.
357(define args    (command-line-arguments))
358
359(let-values (((options operands)  (args:parse args opts)))
360   (if (null? operands) (usage))           
361   (d "download directory is ~s~%" (get-data-dir))
362   (if (meta-filter) (d "metadata filter is ~s~%" (meta-filter)))
363   (let* ((data-list
364           (concatenate
365            (map (lambda (p)
366                   (let* ((search-results  (parse-sxml p))
367                          (page-list       (extract-pages-from-search-results search-results))
368                          (file-list       (map fetch-file page-list))
369                          (sxml-list       (map parse-sxml file-list))
370                          (meta-list       (map extract-metadata sxml-list))
371                          (links-list      (map (lambda (sxml) `(links . ,(extract-info-links sxml))) sxml-list)))
372                     (map (lambda (f m l) `(,f ,@m ,l))  file-list meta-list links-list)))
373                 operands)))
374          (meta-filtered-list
375           (begin
376             (if (and (meta-filter) (pair? (meta-filter)))
377               (let ((ops (map first (meta-filter)))
378                     (ks  (map second (meta-filter)))
379                     (rxs (map (lambda (x) (regexp (third x) #t))
380                               (meta-filter))))
381                 (filter (lambda (x) 
382                           (let ((detail  (alist-ref 'detail (cdr x))))
383                             (every (lambda (op k rx)
384                                      (let* ((propval (alist-ref k detail string-ci=?))
385                                             (propval (or (and (string? propval) propval) ""))
386                                             (m       (string-match rx propval)))
387                                        (case op
388                                          ((=)   m)
389                                          ((!=)  (not m))
390                                          (else  m))))
391                                    ops ks rxs)))
392                         data-list))
393               data-list)))
394          )
395     (if (print-meta?) (for-each print meta-filtered-list))
396     (let ((morphology-files
397            (case (morphology-file)
398              ((O S ORIGINAL STANDARD)
399               (let* ((rx (regexp (regexp-escape (case (morphology-file)
400                                                   ((O ORIGINAL) "Morphology File (Original)")
401                                                   ((S STANDARD) "Morphology File (Standardized)")
402                                                   (else "")))))
403                      (download-url? (lambda (x) (string-match rx (caddr x)))))
404                 (map (lambda (x) 
405                        (let* ((links           (alist-ref 'links (cdr x)))
406                               (morphology-url  (find download-url? links)))
407                          (fetch-file morphology-url)))
408                      meta-filtered-list)))
409              (else (list)))))
410       (if (and (make-index?) (not (null? morphology-files)))
411           (let ((index-file (make-pathname (make-absolute-pathname (current-directory) (get-data-dir)) "index.html")))
412           (d "creating index file ~s...~%" index-file)
413           (with-output-to-file index-file
414             (lambda () (make-index-page meta-filtered-list morphology-files))))))))
415
Note: See TracBrowser for help on using the repository browser.