1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156

;;; -*- mode: lisp -*-

;; CL-EN
;;  Copyright 2008 Ben Hyde <bhyde@pobox.com>

(in-package "ECHONEST")

(defvar *key* (read-line (open "key.txt")))

(defvar *api-root* (puri:intern-uri "http://api.echonest.com/"))

(defvar *count* 1)

(defvar *latest-xml-response* nil)


;;;; 

(defvar *xml-things* (make-hash-table :test #'equal))

(defmacro xml-info (key) `(gethash ,key *xml-things*))

(defmacro define-tag (name spelling type)
  `(let ((info '(:name ,name :spelling ,spelling :type ,type :kind :tag)))
     (setf (xml-info ',spelling) info)
     (setf (xml-info ',name) info)))

(defmacro define-attribute-property (name spelling type)
  `(let ((info '(:name ,name :spelling ,spelling :type ,type :kind :property)))
     (setf (xml-info ',spelling) info)
     (setf (xml-info ',name) info)))

(defmacro define-element-property (name spelling type &optional parent-slot value-in-text)
  `(let ((info '(:name ,name :spelling ,spelling :type ,type 
                 :parent-slot ,parent-slot 
                 :kind :attribute-element
                 :value-in-text ,(if value-in-text name nil))))
     (setf (xml-info ',spelling) info)
     (setf (xml-info ',name) info)))

;;;; Sax Handler that assembles class instance from API responses.

(defclass sax-handler (sax:default-handler)
  ((current-element :initform nil)
   last-element
   (collect-text-p :initform nil)
   (stack :initform nil)
   (all :initform nil)))

(defvar *the-sax-handler* (make-instance 'sax-handler))

(defmethod initialize-instance :after ((h sax-handler) &rest other-args)
  (declare (ignorable other-args))
  (with-slots (current-element collect-text-p stack all) h
    (setf current-element nil
          collect-text-p nil
          stack ()
          all ()))
  (slot-makunbound h 'last-element))

(defmethod sax:start-element ((h sax-handler) (namespace t) (local-name t) (qname t) (attributes t))
  (with-slots (current-element collect-text-p stack all) h
    (let* ((name-info (xml-info local-name))
           (type (getf name-info :type))
           (name (getf name-info :name)))
      (push collect-text-p stack)
      (setf collect-text-p (getf name-info :value-in-text))
      (ecase type
        ((object objects)
         ; (when value-in-text (setf collect-text-p name))
         (push
          (setf current-element 
                (make-instance name :parent current-element)) all))
        ((array plist text)
         nil)))
    (loop 
       for attribute in attributes
       as local-name = (sax:attribute-local-name attribute)
       as name-info = (xml-info local-name)
       as name = (getf name-info :name)
       as type = (getf name-info :type)
       as kind = (getf name-info :kind)
       as text-value = (sax:attribute-value attribute)
       as lisp-value = (ecase type
                         (string text-value)
                         (float (read-from-string text-value))
                         (integer (parse-integer text-value))
                         (floats (mapcar #'read-from-string (cl-ppcre:split " " text-value))))
       do
       (ecase kind
         (:property
          (setf (slot-value current-element name) lisp-value))
         (:tag
          (with-slots (tags) current-element
            (push (cons name lisp-value) tags)))))))

(defmethod sax:end-element ((h sax-handler) (namespace t) (local-name t) (qname t))
  (with-slots (current-element last-element collect-text-p stack) h
    (setf last-element current-element)
    (with-slots (parent) current-element
      (when parent
        ;; store child into parent
        (let* ((info (xml-info local-name))
               (type (getf info :type))
               (slot (getf info :parent-slot)))
          (ecase type
            (object
             (setf (slot-value parent slot) current-element)
             (setf current-element parent))
            (objects
             (push current-element (slot-value parent slot))
             (setf current-element parent))
            ((array plist text)
             ;; all set
             nil)))))
    (setf collect-text-p (pop stack))))

(defmethod sax:characters ((h sax-handler) (data t))
  (with-slots (current-element collect-text-p) h
    (when collect-text-p
      (setf (slot-value current-element collect-text-p) 
            (ecase (getf (xml-info collect-text-p) :type)
              (text data)
              (array
               (map 'vector #'read-from-string
                    (cl-ppcre:all-matches-as-strings "[\\d.]+" data))))))))

;;;; Bottleneck for all API request/response traffic.

(defvar *rng-schema* (cxml-rng:parse-compact (probe-file "rng/analysis.rng")))

(defun do-request (op method parameters)
  (multiple-value-bind (body errcode)
      (drakma:http-request 
       (puri:merge-uris (concatenate 'string op "?api_key=" *key*) *api-root*)
       :method method
       :content-length t ;; [1]
       :parameters parameters)
    (incf *count*) ;; [2]
    (unless (= 200 errcode)
      (error "Request error code: ~D body: ~S" errcode body))
    (intern-response body)))

;; notes
;; [1] Echonest can't handle chunked?
;; [2] Possibly the incf should be before the request?

(defun intern-response (xml-text)
  (initialize-instance *the-sax-handler*)
    (cxml:parse xml-text
                (cxml-rng:make-validator
                 *rng-schema*
                 *the-sax-handler*))
    (slot-value *the-sax-handler* 'last-element))