;; Copyright (c) 2009 Derrell Piper.
;;
;; This program is free software: you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by the Free
;; Software Foundation, either version 3 of the License, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for
;; more details.
;;
;; A full copy of the GPL license can be found at
;; <http://www.gnu.org/licenses/>.

(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)
(require-library tcp json)

;;;; HTML request/response

(define (yelp-do request)

  (define yelp-server "api.yelp.com")
  (define yelp-port 80)

  (define crlf (string #\return #\linefeed))
  (define content-length "Content-Length: ")

  ;; HTTP/1.1 200 OK
  (define (html-response-ok? response #!optional (port #t))
    (let* ((r (substring response 9 12))
           (code (string-ref r 0)))
      (cond ((char=? code #\3)
             (format port "Redirect: ~a~%" r))
            ((char=? code #\4)
             (format port "Client error: ~a~%" r))
            ((char=? code #\5)
             (format port "Server error: ~a~%" r)))
      (string=? r "200")))

  (call/cc
   (lambda (return)
     (let-values (((in out) (tcp-connect yelp-server yelp-port)))
       (condition-case
        (begin
          (format out "GET /~a&ywsid=~a HTTP/1.0~a" request ywsid crlf)
          (format out "User-Agent: Chicken/~a (~a)~a" (chicken-version) (software-version) crlf)
          (format out "Accept: */*~a" crlf)
          (format out "Host: api.yelp.com~a" crlf)
          (format out "Connection: Keep-Alive~a" crlf)
          (format out "~a" crlf)
          (flush-output out)
          (let ((response (read-line in))
                (json #f)
                (json-length 0))
            (if (html-response-ok? response)
                (let loop ()
                  (let ((header (read-line in)))
                    (if (= 0 (string-length header))
                        (begin
                          (let json-loop ((next 0))
                            (when (< next json-length)
                              (string-set! json next (read-char in))
                              (json-loop (+ 1 next))))
                          (close-input-port in)
                          (close-output-port out)
                          (return json)))
                    (if (and (> (string-length header) (string-length content-length))
                             (string=? content-length (substring header 0 (string-length content-length))))
                        (begin
                          (set! json-length (string->number (substring header (string-length content-length) (string-length header))))
                          (set! json (make-string json-length))))
                    (loop)))
                (return #f))))
        (e ()
           (format #t "yelp-do: exception: ~a~%" e)
           (close-input-port in)
           (close-output-port out)
           (return #f)))))))

;; 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)
      (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-invalid-response))

;; 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