source: project/release/4/yelp/trunk/yelp.scm @ 20268

Last change on this file since 20268 was 20268, checked in by ddp, 11 years ago

fix bounds exception for short response headers

File size: 12.8 KB
Line 
1;; Copyright (c) 2009 Derrell Piper.
2;;
3;; This program is free software: you can redistribute it and/or modify it
4;; under the terms of the GNU General Public License as published by the Free
5;; Software Foundation, either version 3 of the License, or (at your option)
6;; any later version.
7;;
8;; This program is distributed in the hope that it will be useful, but WITHOUT
9;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
10;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for
11;; more details.
12;;
13;; A full copy of the GPL license can be found at
14;; <http://www.gnu.org/licenses/>.
15
16(module yelp
17  (set-ywsid!
18   by-phone
19   hood-for-address
20   hood-for-geocode
21   near-address
22   near-geocode
23   near-geobox
24   valid?
25   display-info
26   decode
27   find)
28
29(import scheme chicken data-structures ports extras tcp json)
30(require-library tcp json)
31
32;;;; HTML request/response
33
34(define (yelp-do request)
35
36  (define yelp-server "api.yelp.com")
37  (define yelp-port 80)
38
39  (define crlf (string #\return #\linefeed))
40  (define content-length "Content-Length: ")
41
42  ;; HTTP/1.1 200 OK
43  (define (html-response-ok? response #!optional (port #t))
44    (let* ((r (substring response 9 12))
45           (code (string-ref r 0)))
46      (cond ((char=? code #\3)
47             (format port "Redirect: ~a~%" r))
48            ((char=? code #\4)
49             (format port "Client error: ~a~%" r))
50            ((char=? code #\5)
51             (format port "Server error: ~a~%" r)))
52      (string=? r "200")))
53
54  (call/cc
55   (lambda (return)
56     (let-values (((in out) (tcp-connect yelp-server yelp-port)))
57       (condition-case
58        (begin
59          (format out "GET /~a&ywsid=~a HTTP/1.0~a" request ywsid crlf)
60          (format out "User-Agent: Chicken/~a (~a)~a" (chicken-version) (software-version) crlf)
61          (format out "Accept: */*~a" crlf)
62          (format out "Host: api.yelp.com~a" crlf)
63          (format out "Connection: Keep-Alive~a" crlf)
64          (format out "~a" crlf)
65          (flush-output out)
66          (let ((response (read-line in))
67                (json #f)
68                (json-length 0))
69            (if (html-response-ok? response)
70                (let loop ()
71                  (let ((header (read-line in)))
72                    (if (= 0 (string-length header))
73                        (begin
74                          (let json-loop ((next 0))
75                            (when (< next json-length)
76                              (string-set! json next (read-char in))
77                              (json-loop (+ 1 next))))
78                          (close-input-port in)
79                          (close-output-port out)
80                          (return json)))
81                    (if (and (> (string-length header) (string-length content-length))
82                             (string=? content-length (substring header 0 (string-length content-length))))
83                        (begin
84                          (set! json-length (string->number (substring header (string-length content-length) (string-length header))))
85                          (set! json (make-string json-length))))
86                    (loop)))
87                (return #f))))
88        (e ()
89           (format #t "yelp-do: exception: ~a~%" e)
90           (close-input-port in)
91           (close-output-port out)
92           (return #f)))))))
93
94;; Make a Yelp request and check the Yelp response.
95
96(define (yelp-request request)
97
98  (define (yelp-error code)
99    (cond ((= code 0) 'error-not-error)
100          ((= code 1) 'server-error)
101          ((= code 2) 'invalid-ywsid)
102          ((= code 3) 'missing-ywsid)
103          ((= code 4) 'api-limit-reached)
104          ((= code 5) 'api-not-available)
105          ((= code 6) 'did-not-understand)
106          ((= code 100) 'bad-lat/lon)
107          ((= code 101) 'missing-lat/lon)
108          ((= code 102) 'bad-location)
109          ((= code 103) 'missing-location)
110          ((= code 200) 'unspecified-location)
111          ((= code 201) 'bad-term-parameter)
112          ((= code 202) 'bad-location-parameter)
113          ((= code 203) 'area-too-large)
114          ((= code 205) 'unknown-category)
115          ((= code 300) 'invalid-phone-number)
116          (else 'yelp-undocumented-response)))
117
118  (condition-case
119   (let ((response (with-input-from-string (yelp-do request) json-read)))
120     (let* ((code (find response "message.code"))
121            (text (find response "message.text")))
122       (if (and (= code 0)
123                (string=? text "OK"))
124           (values response 'yelp-success)
125           (values text (yelp-error code)))))
126   (e ()
127      (values (format #f "yelp-request: exception: ~a~%" e) 'yelp-unavailable))))
128
129;;;; JSON queries
130
131(define-syntax for-each-vector
132  (syntax-rules ()
133    ((for-each-vector proc vec ...)
134     (let ((len (min (vector-length vec) ...)))
135       (do ((index 0 (+ index 1)))
136           ((= index len))
137         (proc (vector-ref vec index) ...))))))
138
139;; Decode JSON to specified port.
140
141(define (json-decode object #!optional (port #t))
142
143  (define (find-every object pad level)
144    (cond ((list? object)
145           (let loop ((n 0))
146             (if (< n (length object))
147                 (let ((i (list-ref object n)))
148                   (find-every i pad (+ 1 level))
149                   (if (< n (- (length object) 1))
150                       (newline))
151                   (loop (+ 1 n))))))
152          ((vector? object)
153           (for-each-vector
154            (lambda (alist)
155              (let ((key (car alist)) (value (cdr alist)))
156                (cond ((vector? value)
157                       (format port "~a~a: (~a)~%" (pad level) key (vector-length value))
158                       (find-every value pad (+ 1 level)))
159                      ((list? value)
160                       (format port "~a~a: (~a)~%" (pad level) key (length value))
161                       (find-every value pad (+ 1 level)))
162                      (else
163                       (format port "~a~a: ~a~%" (pad level) key value)))))
164            object))))
165
166  (find-every object (lambda (n) (make-string (* 2 n) #\space)) 0))
167
168;; Locate a property, e.g., "businesses.neighborhood.name".
169
170(define (json-find table thing)
171
172  (define (find-object object thing root)
173    (call/cc
174     (lambda (return)
175       (cond ((list? object)
176              (for-each
177               (lambda (i)
178                 (let ((r (find-object i thing root)))
179                   (if r (return r))))
180               object))
181             ((vector? object)
182              (for-each-vector
183               (lambda (alist)
184                 (let ((key (car alist)) (value (cdr alist)))
185;;                   (format #t "find: thing: ~a vs. ~a~%" thing (string-append root "." key))
186                   (if (string=? thing (string-append root "." key))
187                       (if (or (not (string? value))
188                               (and (string? value) (not (string=? value ""))))
189                           (return value)))
190                   (cond ((vector? value)
191                          (let ((r (find-object value thing (string-append root "." key))))
192                            (if r (return r))))
193                         ((list? value)
194                          (if (> (length value) 0)
195                              (let loop ((i 0))
196                                (let ((r (find-object (list-ref value i) thing (string-append root "." key))))
197                                  (if r (return r)))
198                                (if (< i (- (length value) 1))
199                                    (loop (+ i 1)))))))))
200               object) #f)))))
201
202  (find-object table (string-append "." thing) ""))
203
204;;;; API Helper functions
205
206;; Return a string with whitespace quoted for HTML.
207
208(define (quoted s)
209  (let ((result (make-string 1024))
210        (next 0))
211    (let loop ((i 0))
212      (if (< i (string-length s))
213          (let ((c (string-ref s i)))
214            (cond ((char-whitespace? c)
215                   (let* ((n (char->integer c))
216                          (ns (number->string n 16)))
217                     (string-set! result next #\%)
218                     (set! next (+ 1 next))
219                     (let loop ((j 0))
220                       (if (< j (string-length ns))
221                           (begin
222                             (string-set! result next (string-ref ns j))
223                             (set! next (+ 1 next))
224                             (loop (+ 1 j)))))))
225                  (else
226                   (string-set! result next (string-ref s i))
227                   (set! next (+ 1 next))))
228            (loop (+ 1 i)))))
229    (substring result 0 next)))
230
231;; Non-hygienic macro; 'r' is the base URL request string.
232
233(define-syntax append-if
234  (lambda (form rename compare)
235    (let ((thing (cadr form))
236          (opt (caddr form)))
237      `(if ,thing (set! r (string-append r (format #f ,opt ,thing)))))))
238
239;;;; YWSID
240
241(define ywsid "must-be-set")
242
243(define (set-ywsid! id)
244  (set! ywsid id))
245
246;; Is this a valid Yelp response?
247
248(define (valid? table)
249  (and (or (vector? table) (list? table))
250       (= 0 (find table "message.code"))
251       (string=? "OK" (find table "message.text"))))
252
253;;;; Phone API
254
255(define (by-phone number)
256  (let ((n (string-translate number "()-.")))
257    (yelp-request (format #f "phone_search?phone=~a" n))))
258
259;;;; Neighborhood API
260
261(define (hood-for-address location #!key cc)
262  (let ((r (format #f "neighborhood_search?location=~a" (quoted location))))
263    (append-if cc "&cc=~a")
264    (yelp-request r)))
265
266(define (hood-for-geocode lat lon)
267  (yelp-request (format #f "neighborhood_search?lat=~a&long=~a" lat lon)))
268
269;;;; Review API
270
271(define (near-address term location #!key number cc category)
272  (let ((r (format #f "business_review_search?term=~a&location=~a" (quoted term) (quoted location))))
273    (append-if number "&num_biz_requested=~a")
274    (append-if cc "&cc=~a")
275    (append-if category "&category=~a")
276    (yelp-request r)))
277
278(define (near-geocode term lat lon #!key number radius category)
279  (let ((r (format #f "business_review_search?term=~a&lat=~a&long=~a" (quoted term) lat lon)))
280    (append-if number "&num_biz_requested=~a")
281    (append-if radius "&radius=~a")
282    (append-if category "&category=~a")
283    (yelp-request r)))
284
285(define (near-geobox term tl-lat tl-lon br-lat br-lon #!key number category)
286  (let ((r (format #f "business_review_search?term=~a&tl_lat=~a&tl_long=~a&br_lat=~a&br_long=~a" (quoted term) tl-lat tl-lon br-lat br-lon)))
287    (append-if number "&num_biz_requested=~a")
288    (append-if category "&category=~a")
289    (yelp-request r)))
290
291;;;; JSON queries
292
293(define-syntax display-if
294  (syntax-rules ()
295    ((display-if port thing)
296     (if thing (format port "~a~%" thing)))
297    ((display-if port thing fmt)
298     (if thing (format port fmt thing)))))
299
300;; Display basic information for a restaurant.
301
302(define (display-info object #!optional (port #t))
303
304  (define (pretty-phone p)
305    (if (= 10 (string-length p))
306        (format #f "(~a)~a-~a" (substring p 0 3) (substring p 3 6) (substring p 6 10))
307        p))
308
309  (if (valid? object)
310      (begin
311        (and-let* ((categories (find object "businesses.categories"))
312                   (len (length categories)))
313          (format port "Categories: ")
314          (let loop ((i 0))
315            (if (< i len)
316                (let ((c (list-ref categories i)))
317                  (format port "~a~a" (find c "name") (if (< i (- len 1)) ", " ""))
318                  (loop (+ 1 i)))))
319          (newline))
320        (display-if port (json-find object "businesses.neighborhoods.name") "Neighborhood: ~a~%")
321        (display-if port (json-find object "businesses.name"))
322        (display-if port (json-find object "businesses.address1"))
323        (display-if port (json-find object "businesses.address2"))
324        (display-if port (json-find object "businesses.address3"))
325        (format port "~a, ~a ~a~%"
326                (json-find object "businesses.city")
327                (json-find object "businesses.state")
328                (json-find object "businesses.zip"))
329        (display-if port (pretty-phone (json-find object "businesses.phone")))
330
331        (and-let* ((latitude (json-find object "businesses.latitude"))
332                   (lat (number->string latitude))
333                   (longitude (json-find object "businesses.longitude"))
334                   (lon (number->string longitude))
335                   (a (substring-index "." lat))
336                   (a-end (min (+ a 7) (string-length lat)))
337                   (l (substring-index "." lon))
338                   (l-end (min (+ l 7) (string-length lon))))
339          (format port "~a ~a~%" (substring lat 0 a-end) (substring lon 0 l-end))))
340      'yelp-invalid-response))
341
342;; Decode JSON response.  The JSON egg returns structures as vectors and arrays as lists.
343
344(define (decode object #!optional (port #t))
345  (json-decode object port))
346
347;; Primary query routine.  Stops on first match.  Returns vectors, lists, or values.
348
349(define (find object thing)
350  (json-find object thing))
351
352)                                     ; module
Note: See TracBrowser for help on using the repository browser.