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

Last change on this file since 27411 was 27411, checked in by ddp, 9 years ago

switch to http-client

File size: 11.8 KB
Line 
1;; Copyright (c) 2009, Derrell Piper
2;; All rights reserved.
3
4;; Redistribution and use in source and binary forms, with or without
5;; modification, are permitted provided that the following conditions are met:
6
7;; 1. Redistributions of source code must retain the above copyright notice, this
8;;    list of conditions and the following disclaimer.
9;; 2. Redistributions in binary form must reproduce the above copyright notice,
10;;    this list of conditions and the following disclaimer in the documentation
11;;    and/or other materials provided with the distribution.
12
13;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
14;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
15;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
16;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
17;; ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
18;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
19;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
20;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
21;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
22;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
23
24;; The views and conclusions contained in the software and documentation are those
25;; of the authors and should not be interpreted as representing official policies,
26;; either expressed or implied, of the FreeBSD Project.
27
28(module yelp
29  (set-ywsid!
30   by-phone
31   hood-for-address
32   hood-for-geocode
33   near-address
34   near-geocode
35   near-geobox
36   valid?
37   display-info
38   decode
39   find)
40
41(import scheme chicken data-structures ports extras tcp json http-client)
42(require-library tcp json http-client)
43
44;;;; HTTP request/response
45
46(define (yelp-do request)
47  (let-values (((result request-uri response)
48                (with-input-from-request 
49                 (with-output-to-string 
50                   (lambda ()
51                     (format #t "http://api.yelp.com/~a&ywsid=~a" request ywsid))) #f read-string)))
52    result))
53
54;; Make a Yelp request and check the Yelp response.
55
56(define (yelp-request request)
57
58  (define (yelp-error code)
59    (cond ((= code 0) 'error-not-error)
60          ((= code 1) 'server-error)
61          ((= code 2) 'invalid-ywsid)
62          ((= code 3) 'missing-ywsid)
63          ((= code 4) 'api-limit-reached)
64          ((= code 5) 'api-not-available)
65          ((= code 6) 'did-not-understand)
66          ((= code 100) 'bad-lat/lon)
67          ((= code 101) 'missing-lat/lon)
68          ((= code 102) 'bad-location)
69          ((= code 103) 'missing-location)
70          ((= code 200) 'unspecified-location)
71          ((= code 201) 'bad-term-parameter)
72          ((= code 202) 'bad-location-parameter)
73          ((= code 203) 'area-too-large)
74          ((= code 205) 'unknown-category)
75          ((= code 300) 'invalid-phone-number)
76          (else 'yelp-undocumented-response)))
77
78  (condition-case
79   (let ((response (with-input-from-string (yelp-do request) json-read)))
80     (let* ((code (find response "message.code"))
81            (text (find response "message.text")))
82       (if (and (= code 0)
83                (string=? text "OK"))
84           (values response 'yelp-success)
85           (values text (yelp-error code)))))
86   (e ()
87      (values (format #f "yelp-request: exception: ~a~%" e) 'yelp-unavailable))))
88
89;;;; JSON queries
90
91(define-syntax for-each-vector
92  (syntax-rules ()
93    ((for-each-vector proc vec ...)
94     (let ((len (min (vector-length vec) ...)))
95       (do ((index 0 (+ index 1)))
96           ((= index len))
97         (proc (vector-ref vec index) ...))))))
98
99;; Decode JSON to specified port.
100
101(define (json-decode object #!optional (port #t))
102
103  (define (find-every object pad level)
104    (cond ((list? object)
105           (let loop ((n 0))
106             (if (< n (length object))
107                 (let ((i (list-ref object n)))
108                   (find-every i pad (+ 1 level))
109                   (if (< n (- (length object) 1))
110                       (newline))
111                   (loop (+ 1 n))))))
112          ((vector? object)
113           (for-each-vector
114            (lambda (alist)
115              (let ((key (car alist)) (value (cdr alist)))
116                (cond ((vector? value)
117                       (format port "~a~a: (~a)~%" (pad level) key (vector-length value))
118                       (find-every value pad (+ 1 level)))
119                      ((list? value)
120                       (format port "~a~a: (~a)~%" (pad level) key (length value))
121                       (find-every value pad (+ 1 level)))
122                      (else
123                       (format port "~a~a: ~a~%" (pad level) key value)))))
124            object))))
125
126  (find-every object (lambda (n) (make-string (* 2 n) #\space)) 0))
127
128;; Locate a property, e.g., "businesses.neighborhood.name".
129
130(define (json-find table thing)
131
132  (define (find-object object thing root)
133    (call/cc
134     (lambda (return)
135       (cond ((list? object)
136              (for-each
137               (lambda (i)
138                 (let ((r (find-object i thing root)))
139                   (if r (return r))))
140               object))
141             ((vector? object)
142              (for-each-vector
143               (lambda (alist)
144                 (let ((key (car alist)) (value (cdr alist)))
145;;                   (format #t "find: thing: ~a vs. ~a~%" thing (string-append root "." key))
146                   (if (string=? thing (string-append root "." key))
147                       (if (or (not (string? value))
148                               (and (string? value) (not (string=? value ""))))
149                           (return value)))
150                   (cond ((vector? value)
151                          (let ((r (find-object value thing (string-append root "." key))))
152                            (if r (return r))))
153                         ((list? value)
154                          (if (> (length value) 0)
155                              (let loop ((i 0))
156                                (let ((r (find-object (list-ref value i) thing (string-append root "." key))))
157                                  (if r (return r)))
158                                (if (< i (- (length value) 1))
159                                    (loop (+ i 1)))))))))
160               object) #f)))))
161
162  (find-object table (string-append "." thing) ""))
163
164;;;; API Helper functions
165
166;; Return a string with whitespace quoted for HTML.
167
168(define (quoted s)
169  (let ((result (make-string 1024))
170        (next 0))
171    (let loop ((i 0))
172      (if (< i (string-length s))
173          (let ((c (string-ref s i)))
174            (cond ((char-whitespace? c)
175                   (let* ((n (char->integer c))
176                          (ns (number->string n 16)))
177                     (string-set! result next #\%)
178                     (set! next (+ 1 next))
179                     (let loop ((j 0))
180                       (if (< j (string-length ns))
181                           (begin
182                             (string-set! result next (string-ref ns j))
183                             (set! next (+ 1 next))
184                             (loop (+ 1 j)))))))
185                  (else
186                   (string-set! result next (string-ref s i))
187                   (set! next (+ 1 next))))
188            (loop (+ 1 i)))))
189    (substring result 0 next)))
190
191;; Non-hygienic macro; 'r' is the base URL request string.
192
193(define-syntax append-if
194  (lambda (form rename compare)
195    (let ((thing (cadr form))
196          (opt (caddr form)))
197      `(if ,thing (set! r (string-append r (format #f ,opt ,thing)))))))
198
199;;;; YWSID
200
201(define ywsid "must-be-set")
202
203(define (set-ywsid! id)
204  (set! ywsid id))
205
206;; Is this a valid Yelp response?
207
208(define (valid? table)
209  (and (or (vector? table) (list? table))
210       (= 0 (find table "message.code"))
211       (string=? "OK" (find table "message.text"))))
212
213;;;; Phone API
214
215(define (by-phone number)
216  (let ((n (string-translate number "()-.")))
217    (yelp-request (format #f "phone_search?phone=~a" n))))
218
219;;;; Neighborhood API
220
221(define (hood-for-address location #!key cc)
222  (let ((r (format #f "neighborhood_search?location=~a" (quoted location))))
223    (append-if cc "&cc=~a")
224    (yelp-request r)))
225
226(define (hood-for-geocode lat lon)
227  (yelp-request (format #f "neighborhood_search?lat=~a&long=~a" lat lon)))
228
229;;;; Review API
230
231(define (near-address term location #!key number cc category)
232  (let ((r (format #f "business_review_search?term=~a&location=~a" (quoted term) (quoted location))))
233    (append-if number "&num_biz_requested=~a")
234    (append-if cc "&cc=~a")
235    (append-if category "&category=~a")
236    (yelp-request r)))
237
238(define (near-geocode term lat lon #!key number radius category)
239  (let ((r (format #f "business_review_search?term=~a&lat=~a&long=~a" (quoted term) lat lon)))
240    (append-if number "&num_biz_requested=~a")
241    (append-if radius "&radius=~a")
242    (append-if category "&category=~a")
243    (yelp-request r)))
244
245(define (near-geobox term tl-lat tl-lon br-lat br-lon #!key number category)
246  (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)))
247    (append-if number "&num_biz_requested=~a")
248    (append-if category "&category=~a")
249    (yelp-request r)))
250
251;;;; JSON queries
252
253(define-syntax display-if
254  (syntax-rules ()
255    ((display-if port thing)
256     (if thing (format port "~a~%" thing)))
257    ((display-if port thing fmt)
258     (if thing (format port fmt thing)))))
259
260;; Display basic information for a restaurant.
261
262(define (display-info object #!optional (port #t))
263
264  (define (pretty-phone p)
265    (if (= 10 (string-length p))
266        (format #f "(~a)~a-~a" (substring p 0 3) (substring p 3 6) (substring p 6 10))
267        p))
268
269  (if (valid? object)
270      (if (not (find object "businesses.categories"))
271          (format port "Business not found~%")
272          (begin
273            (and-let* ((categories (find object "businesses.categories"))
274                       (len (length categories)))
275              (format port "Categories: ")
276              (let loop ((i 0))
277                (if (< i len)
278                    (let ((c (list-ref categories i)))
279                      (format port "~a~a" (find c "name") (if (< i (- len 1)) ", " ""))
280                      (loop (+ 1 i)))))
281              (newline))
282            (display-if port (json-find object "businesses.neighborhoods.name") "Neighborhood: ~a~%")
283            (display-if port (json-find object "businesses.name"))
284            (display-if port (json-find object "businesses.address1"))
285            (display-if port (json-find object "businesses.address2"))
286            (display-if port (json-find object "businesses.address3"))
287            (format port "~a, ~a ~a~%"
288                    (json-find object "businesses.city")
289                    (json-find object "businesses.state")
290                    (json-find object "businesses.zip"))
291            (display-if port (pretty-phone (json-find object "businesses.phone")))
292
293            (and-let* ((latitude (json-find object "businesses.latitude"))
294                       (lat (number->string latitude))
295                       (longitude (json-find object "businesses.longitude"))
296                       (lon (number->string longitude))
297                       (a (substring-index "." lat))
298                       (a-end (min (+ a 7) (string-length lat)))
299                       (l (substring-index "." lon))
300                       (l-end (min (+ l 7) (string-length lon))))
301              (format port "~a ~a~%" (substring lat 0 a-end) (substring lon 0 l-end)))))
302      'yelp-request-invalid))
303
304;; Decode JSON response.  The JSON egg returns structures as vectors and arrays as lists.
305
306(define (decode object #!optional (port #t))
307  (json-decode object port))
308
309;; Primary query routine.  Stops on first match.  Returns vectors, lists, or values.
310
311(define (find object thing)
312  (json-find object thing))
313
314)                                     ; module
Note: See TracBrowser for help on using the repository browser.