;; Copyright (c) 2009, Derrell Piper
;; All rights reserved.

;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met: 

;; 1. Redistributions of source code must retain the above copyright notice, this
;;    list of conditions and the following disclaimer. 
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;;    this list of conditions and the following disclaimer in the documentation
;;    and/or other materials provided with the distribution. 

;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
;; ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;; The views and conclusions contained in the software and documentation are those
;; of the authors and should not be interpreted as representing official policies, 
;; either expressed or implied, of the FreeBSD Project.

(module yelp
  (set-ywsid!
   by-phone
   hood-for-address
   hood-for-geocode
   near-address
   near-geocode
   near-geobox
   valid?
   display-info
   decode
   find)

(import scheme chicken data-structures ports extras tcp json http-client)
(require-library tcp json http-client)

;;;; HTTP request/response

(define (yelp-do request)
  (let-values (((result request-uri response)
                (with-input-from-request 
                 (with-output-to-string 
                   (lambda ()
                     (format #t "http://api.yelp.com/~a&ywsid=~a" request ywsid))) #f read-string)))
    result))

;; Make a Yelp request and check the Yelp response.

(define (yelp-request request)

  (define (yelp-error code)
    (cond ((= code 0) 'error-not-error)
          ((= code 1) 'server-error)
          ((= code 2) 'invalid-ywsid)
          ((= code 3) 'missing-ywsid)
          ((= code 4) 'api-limit-reached)
          ((= code 5) 'api-not-available)
          ((= code 6) 'did-not-understand)
          ((= code 100) 'bad-lat/lon)
          ((= code 101) 'missing-lat/lon)
          ((= code 102) 'bad-location)
          ((= code 103) 'missing-location)
          ((= code 200) 'unspecified-location)
          ((= code 201) 'bad-term-parameter)
          ((= code 202) 'bad-location-parameter)
          ((= code 203) 'area-too-large)
          ((= code 205) 'unknown-category)
          ((= code 300) 'invalid-phone-number)
          (else 'yelp-undocumented-response)))

  (condition-case
   (let ((response (with-input-from-string (yelp-do request) json-read)))
     (let* ((code (find response "message.code"))
            (text (find response "message.text")))
       (if (and (= code 0)
                (string=? text "OK"))
           (values response 'yelp-success)
           (values text (yelp-error code)))))
   (e ()
      (values (format #f "yelp-request: exception: ~a~%" e) 'yelp-unavailable))))

;;;; JSON queries

(define-syntax for-each-vector
  (syntax-rules ()
    ((for-each-vector proc vec ...)
     (let ((len (min (vector-length vec) ...)))
       (do ((index 0 (+ index 1)))
           ((= index len))
         (proc (vector-ref vec index) ...))))))

;; Decode JSON to specified port.

(define (json-decode object #!optional (port #t))

  (define (find-every object pad level)
    (cond ((list? object)
           (let loop ((n 0))
             (if (< n (length object))
                 (let ((i (list-ref object n)))
                   (find-every i pad (+ 1 level))
                   (if (< n (- (length object) 1))
                       (newline))
                   (loop (+ 1 n))))))
          ((vector? object)
           (for-each-vector
            (lambda (alist)
              (let ((key (car alist)) (value (cdr alist)))
                (cond ((vector? value)
                       (format port "~a~a: (~a)~%" (pad level) key (vector-length value))
                       (find-every value pad (+ 1 level)))
                      ((list? value)
                       (format port "~a~a: (~a)~%" (pad level) key (length value))
                       (find-every value pad (+ 1 level)))
                      (else
                       (format port "~a~a: ~a~%" (pad level) key value)))))
            object))))

  (find-every object (lambda (n) (make-string (* 2 n) #\space)) 0))

;; Locate a property, e.g., "businesses.neighborhood.name".

(define (json-find table thing)

  (define (find-object object thing root)
    (call/cc
     (lambda (return)
       (cond ((list? object)
              (for-each
               (lambda (i)
                 (let ((r (find-object i thing root)))
                   (if r (return r))))
               object))
             ((vector? object)
              (for-each-vector
               (lambda (alist)
                 (let ((key (car alist)) (value (cdr alist)))
;;                   (format #t "find: thing: ~a vs. ~a~%" thing (string-append root "." key))
                   (if (string=? thing (string-append root "." key))
                       (if (or (not (string? value))
                               (and (string? value) (not (string=? value ""))))
                           (return value)))
                   (cond ((vector? value)
                          (let ((r (find-object value thing (string-append root "." key))))
                            (if r (return r))))
                         ((list? value)
                          (if (> (length value) 0)
                              (let loop ((i 0))
                                (let ((r (find-object (list-ref value i) thing (string-append root "." key))))
                                  (if r (return r)))
                                (if (< i (- (length value) 1))
                                    (loop (+ i 1)))))))))
               object) #f)))))

  (find-object table (string-append "." thing) ""))

;;;; API Helper functions

;; Return a string with whitespace quoted for HTML.

(define (quoted s)
  (let ((result (make-string 1024))
        (next 0))
    (let loop ((i 0))
      (if (< i (string-length s))
          (let ((c (string-ref s i)))
            (cond ((char-whitespace? c)
                   (let* ((n (char->integer c))
                          (ns (number->string n 16)))
                     (string-set! result next #\%)
                     (set! next (+ 1 next))
                     (let loop ((j 0))
                       (if (< j (string-length ns))
                           (begin
                             (string-set! result next (string-ref ns j))
                             (set! next (+ 1 next))
                             (loop (+ 1 j)))))))
                  (else
                   (string-set! result next (string-ref s i))
                   (set! next (+ 1 next))))
            (loop (+ 1 i)))))
    (substring result 0 next)))

;; Non-hygienic macro; 'r' is the base URL request string.

(define-syntax append-if
  (lambda (form rename compare)
    (let ((thing (cadr form))
          (opt (caddr form)))
      `(if ,thing (set! r (string-append r (format #f ,opt ,thing)))))))

;;;; YWSID

(define ywsid "must-be-set")

(define (set-ywsid! id)
  (set! ywsid id))

;; Is this a valid Yelp response?

(define (valid? table)
  (and (or (vector? table) (list? table))
       (= 0 (find table "message.code"))
       (string=? "OK" (find table "message.text"))))

;;;; Phone API

(define (by-phone number)
  (let ((n (string-translate number "()-.")))
    (yelp-request (format #f "phone_search?phone=~a" n))))

;;;; Neighborhood API

(define (hood-for-address location #!key cc)
  (let ((r (format #f "neighborhood_search?location=~a" (quoted location))))
    (append-if cc "&cc=~a")
    (yelp-request r)))

(define (hood-for-geocode lat lon)
  (yelp-request (format #f "neighborhood_search?lat=~a&long=~a" lat lon)))

;;;; Review API

(define (near-address term location #!key number cc category)
  (let ((r (format #f "business_review_search?term=~a&location=~a" (quoted term) (quoted location))))
    (append-if number "&num_biz_requested=~a")
    (append-if cc "&cc=~a")
    (append-if category "&category=~a")
    (yelp-request r)))

(define (near-geocode term lat lon #!key number radius category)
  (let ((r (format #f "business_review_search?term=~a&lat=~a&long=~a" (quoted term) lat lon)))
    (append-if number "&num_biz_requested=~a")
    (append-if radius "&radius=~a")
    (append-if category "&category=~a")
    (yelp-request r)))

(define (near-geobox term tl-lat tl-lon br-lat br-lon #!key number category)
  (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)))
    (append-if number "&num_biz_requested=~a")
    (append-if category "&category=~a")
    (yelp-request r)))

;;;; JSON queries

(define-syntax display-if
  (syntax-rules ()
    ((display-if port thing)
     (if thing (format port "~a~%" thing)))
    ((display-if port thing fmt)
     (if thing (format port fmt thing)))))

;; Display basic information for a restaurant.

(define (display-info object #!optional (port #t))

  (define (pretty-phone p)
    (if (= 10 (string-length p))
        (format #f "(~a)~a-~a" (substring p 0 3) (substring p 3 6) (substring p 6 10))
        p))

  (if (valid? object)
      (if (not (find object "businesses.categories"))
          (format port "Business not found~%")
          (begin
            (and-let* ((categories (find object "businesses.categories"))
                       (len (length categories)))
              (format port "Categories: ")
              (let loop ((i 0))
                (if (< i len)
                    (let ((c (list-ref categories i)))
                      (format port "~a~a" (find c "name") (if (< i (- len 1)) ", " ""))
                      (loop (+ 1 i)))))
              (newline))
            (display-if port (json-find object "businesses.neighborhoods.name") "Neighborhood: ~a~%")
            (display-if port (json-find object "businesses.name"))
            (display-if port (json-find object "businesses.address1"))
            (display-if port (json-find object "businesses.address2"))
            (display-if port (json-find object "businesses.address3"))
            (format port "~a, ~a ~a~%"
                    (json-find object "businesses.city")
                    (json-find object "businesses.state")
                    (json-find object "businesses.zip"))
            (display-if port (pretty-phone (json-find object "businesses.phone")))

            (and-let* ((latitude (json-find object "businesses.latitude"))
                       (lat (number->string latitude))
                       (longitude (json-find object "businesses.longitude"))
                       (lon (number->string longitude))
                       (a (substring-index "." lat))
                       (a-end (min (+ a 7) (string-length lat)))
                       (l (substring-index "." lon))
                       (l-end (min (+ l 7) (string-length lon))))
              (format port "~a ~a~%" (substring lat 0 a-end) (substring lon 0 l-end)))))
      'yelp-request-invalid))

;; Decode JSON response.  The JSON egg returns structures as vectors and arrays as lists.

(define (decode object #!optional (port #t))
  (json-decode object port))

;; Primary query routine.  Stops on first match.  Returns vectors, lists, or values.

(define (find object thing)
  (json-find object thing))

)                                     ; module