source: project/release/4/9ML-toolkit/trunk/ulp.scm @ 23766

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

9ML-toolkit: a preliminary user layer processor

File size: 6.9 KB
Line 
1;
2;;  NineML user layer processor.
3;;
4;;
5;; Copyright 2010-2011 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
23(require-extension
24 extras regex posix utils files data-structures tcp srfi-1 srfi-13
25 tree-rewrite sxml-transforms sxpath uri-generic getopt-long)
26
27
28(define opt-defaults
29  `(
30    ))
31
32
33(define (defopt x)
34  (lookup-def x opt-defaults))
35
36(define opt-grammar
37  `(
38
39    (help  "Print help"
40            (single-char #\h))
41 
42  ))
43
44
45;; Use args:usage to generate a formatted list of options (from OPTS),
46;; suitable for embedding into help text.
47(define (ulp:usage)
48  (print "Usage: " (car (argv)) " [options...] operands ")
49  (newline)
50  (print "Where operands are NineML user layer files")
51  (newline)
52  (print "The following options are recognized: ")
53  (newline)
54  (width 35)
55  (print (parameterize ((indent 5)) (usage opt-grammar)))
56  (exit 1))
57
58
59;; Process arguments and collate options and arguments into OPTIONS
60;; alist, and operands (filenames) into OPERANDS.  You can handle
61;; options as they are processed, or afterwards.
62
63(define opts    (getopt-long (command-line-arguments) opt-grammar))
64(define opt     (make-option-dispatch opts opt-grammar))
65
66
67(define data-dir (make-parameter #f))
68
69(define (get-data-dir)
70  (or (opt 'data-dir)
71      (or (data-dir)
72          (let ([dir (create-temporary-directory)])
73            (data-dir dir)
74            dir ) ) ))
75
76
77(define (create-temporary-directory)
78  (let ((dir (or (get-environment-variable "TMPDIR") 
79                 (get-environment-variable "TEMP") 
80                 (get-environment-variable "TMP") 
81                 "/tmp")))
82    (let loop ()
83      (let* ((n (current-milliseconds))
84             (pn (make-pathname dir (string-append "9ML-ulp-" (number->string n 16)) "tmp")))
85        (cond ((file-exists? pn) (loop))
86              (else (mkdir pn) pn))))))
87
88
89(define (network-failure msg . args)
90  (signal
91   (make-composite-condition
92    (make-property-condition
93       'exn
94       'message "invalid response from server"
95       'arguments args)
96    (make-property-condition 'http-fetch))) )
97
98
99
100(define (make-HTTP-GET/1.1 location user-agent host
101                           #!key
102                           (port 80)
103                           (connection "close")
104                           (accept "*")
105                           (content-length 0))
106  (conc
107   "GET " location " HTTP/1.1" "\r\n"
108   "Connection: " connection "\r\n"
109   "User-Agent: " user-agent "\r\n"
110   "Accept: " accept "\r\n"
111   "Host: " host #\: port "\r\n"
112   "Content-length: " content-length "\r\n"
113   "\r\n") )
114
115(define (match-http-response rsp)
116  (and (string? rsp)
117       (string-match "HTTP/[0-9.]+\\s+([0-9]+)\\s+.*" rsp)) )
118
119(define (response-match-code? mrsp code)
120  (and mrsp (string=? (number->string code) (cadr mrsp))) )
121
122(define (match-chunked-transfer-encoding ln)
123  (string-match "[Tt]ransfer-[Ee]ncoding:\\s*chunked.*" ln) )
124
125
126(define (http-fetch uri dest)
127  (d "fetching ~s ...~%" (uri->string uri))
128  (match-let (((_ ((_ host port) ('/ . path) query) _) (uri->list uri)))
129    (let* ((port      (or port 80))
130           (locn      (uri->string (update-uri (update-uri uri scheme: #f) host: #f)))
131           (query     (and query (not (string-null? query)) query))
132           (filedir   (uri-decode-string (string-concatenate (intersperse (if query path (drop-right path 1)) "/"))))
133           (filename  (uri-decode-string (or (and query (cadr (string-split query "="))) (last path))))
134           (dest      (make-pathname dest filedir))
135           (filepath  (make-pathname dest filename)))
136      (if (file-exists? filepath) filepath
137          (begin
138          (d "connecting to host ~s, port ~a ...~%" host port)
139          (let-values ([(in out) (tcp-connect host port)])
140                      (d "requesting ~s ...~%" locn)
141                      (display
142                       (make-HTTP-GET/1.1 locn *user-agent* host port: port accept: "*/*")
143                       out)
144                      (flush-output out)
145                      (d "reading response ...~%")
146                      (let ([chunked #f] [ok-response #f])
147                        (let* ([h1 (read-line in)]
148                               [response-match (match-http-response h1)])
149                          (d "~a~%" h1)
150                          ;;*** handle redirects here
151                          (cond ((response-match-code? response-match 200)
152                                 (set! ok-response #t))
153                                ((response-match-code? response-match 404)
154                                 (d "file not found on server: ~s~%" locn))
155                                (else (network-failure "invalid response from server" h1) ))
156                        (and ok-response
157                            (begin
158                              (let loop ()
159                                (let ([ln (read-line in)])
160                                  (unless (string-null? ln)
161                                    (when (match-chunked-transfer-encoding ln) (set! chunked #t))
162                                    (d "~a~%" ln)
163                                    (loop) ) ) )
164                              (if chunked
165                                  (begin
166                                    (d "reading chunks ...~%")
167                                    (let ([data (read-chunks in)])
168                                      (close-input-port in)
169                                      (close-input-port out)
170                                      (if (not (file-exists? dest)) (mkdir dest))
171                                      (d "writing to ~s~%" filepath)
172                                      (with-output-to-file filepath (cut display data) )
173                                      filepath))
174                                 
175                                  (begin
176                                    (d "reading data ...~%")
177                                    (let ([data (read-string #f in)])
178                                      (close-input-port in)
179                                      (close-input-port out)
180                                      (if (not (file-exists? dest)) (mkdir dest))
181                                      (d "writing to ~s~%" filepath)
182                                      (with-output-to-file filepath (cut display data) binary:)
183                                      filepath)))))
184                        )
185                      )))))))
186
187  (define (read-chunks in)
188    (let get-chunks ([data '()])
189      (let ([size (string->number (read-line in) 16)])
190        (if (zero? size)
191            (string-concatenate-reverse data)
192            (let ([chunk (read-string size in)])
193              (read-line in)
194              (get-chunks (cons chunk data)) ) ) ) ) )
195
196
197
198(define (parse-sxml fpath)
199  (with-input-from-file fpath
200    (lambda () (cons '*TOP* (ssax:xml->sxml (current-input-port) `())))
201    ))
202
203
204(define rule-user-layer
205  `( 
206
207     ( (M component (definition $url) $properties) =>
208       (M component (eval-env (M eval-definition $url)) $properties) )
209
210     ( (M component (eval-env $eval-env) $properties) =>
211       (M component (main-module (eval-env-last-entry $eval-env)) $properties) )
212
213     ( (M component (eval-env $eval-env) $properties) =>
214       (M component (main-module (eval-env-last-entry $eval-env)) $properties) )
215
216     ( (M component (main-module $main-module) $properties) =>
217       (eval-term (M apply-terms (Longid (Pdot (entry-name $main-module) "main")) $properties)) )
218
219     ( (M eval-definition $url ) =>
220       (eval-source (fetch (uri-reference $url)) interpreter current-scope current-type-env current-eval-env ) )
221
222     ( (M apply-terms $operator (seq $term $rest)) =>
223       (M apply-terms (Apply $operator $term) $rest) )
224       
225     ( (M apply-terms $operator (seq-empty)) => $operator )
226     
227     
228     
229       
230     ))
231
232
233)
234       
235
236
237
Note: See TracBrowser for help on using the repository browser.