source: project/release/4/neuromorpho/trunk/neuromorpho.scm @ 26804

Last change on this file since 26804 was 26804, checked in by Ivan Raikov, 8 years ago

neuromorpho: properly close tcp port (fix for #833)

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