-
Notifications
You must be signed in to change notification settings - Fork 1
/
cl-elastic.lisp
189 lines (169 loc) · 6.77 KB
/
cl-elastic.lisp
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
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
#|
This file is a part of cl-elastic.
(c) 2019 Finn Völkel
Author: Finn Völkel ([email protected])
|#
(defpackage cl-elastic
(:use :cl)
(:nicknames :elastic)
(:import-from :drakma
:http-request
:*text-content-types*)
(:import-from :named-readtables
:defreadtable)
(:import-from :yason
:encode
:parse
:with-output-to-string)
(:export :<client>
:endpoint
:user
:password
:send-request
:*enable-keywords*
:enable-hashtable-syntax
:disable-hashtable-syntax
:hashtable-syntax))
(in-package :cl-elastic)
(defvar *enable-keywords* nil
"If set to a true value, keywords will be transformed to strings in JSON
objects and read back as keywords.")
(defclass <client> ()
((endpoint :initarg :endpoint
:initform "http://localhost:9200"
:reader endpoint)
(user :initarg :user
:initform nil
:reader user)
(password :initarg :password
:initform nil
:reader password)))
(defun parse-uri (uri)
"Parses a URI in form of a string, keyword or list."
(typecase uri
(string (format nil "/~A" uri))
(keyword (format nil "/~A" (keyword-downcase uri)))
(list (reduce (lambda (res uri)
(format nil "~A~A" res (parse-uri uri)))
uri :initial-value ""))
(t (format nil "/~A" uri))))
(defun create-uri (client uri)
(format nil "~A~A" (endpoint client) (parse-uri uri)))
(defun concat-with-newlines (strings)
"Concats STRINGS with newlines. Ends in a newline."
(format nil "~A~%"
(reduce (lambda (res x) (format nil "~A~%~A" res x)) strings)))
(defun encode-json (data)
"Transforms a lisp object into a JSON object in string form. A list is
transformed into the newline seperated concatenation of JSON objects."
(typecase data
(null nil)
(list (concat-with-newlines (mapcar #'encode-json data)))
(T (with-output-to-string (s)
(yason:encode (if *enable-keywords* (keywords-to-strings data) data) s)))))
(defun send-request (client uri &key (method :get) data parameters)
"Sends a request to an Elasticsearch client."
(assert (eq (type-of client) '<client>))
(let ((*text-content-types*
'(("application" . "json")))
(uri (create-uri client uri))
(yason:*parse-object-key-fn* (if *enable-keywords* #'make-keyword #'identity))
(data (encode-json data))
(parameters (if *enable-keywords*
(mapcar (lambda (p) (cons (keywords-to-strings (car p)) (cdr p)))
parameters)
parameters)))
(multiple-value-bind (body status headers uri stream closep reason)
(http-request uri
:method method
:content data
:content-type "application/json"
:external-format-in :utf-8
:external-format-out :utf-8
:parameters parameters
:want-stream T)
(declare (ignore headers uri stream reason))
(unwind-protect
(if (= status 400)
(let ((error-message
(gethash (if *enable-keywords* :error "error") (parse body))))
(error (cond
((equal (type-of error-message) 'hash-table)
(format nil "~A" error-message))
(T error-message))))
;; (error (gethash (if *enable-keywords* :error "error") (yason:parse body)))
(values (yason:parse body) status))
(when closep
(close body))))))
;; utility functions
(defun make-keyword (name)
"Creates a keyword symbol for a given string NAME."
(values (intern (string-upcase name) "KEYWORD")))
(defun keyword-downcase (keyword)
(string-downcase (string keyword)))
(defun keywords-to-strings (x)
(typecase x
(hash-table (progn
(maphash (lambda (k v)
(let ((newv (keywords-to-strings v)))
(if (eq (type-of k) 'keyword)
(progn
(remhash k x)
(setf (gethash (keyword-downcase k) x) newv))
(setf (gethash k x) newv))))
x)
x))
(list (mapcar #'keywords-to-strings x))
;; o/w strings get transformed into vectors
(string x)
(vector (map 'vector #'keywords-to-strings x))
(keyword (keyword-downcase x))
(t x)))
;; new hashtable syntax
(define-condition odd-number-of-forms (error) ()
(:report (lambda (condition stream)
(declare (ignore condition))
(format stream "Hashmap literal must contain an even number of forms."))))
(defun |#{-reader-}| (stream char arg)
(declare (ignore char) (ignore arg))
(let ((*readtable* (copy-readtable *readtable* nil)))
(set-macro-character #\} (get-macro-character #\)))
(let ((contents (read-delimited-list #\} stream t)))
(when (oddp (length contents)) (error 'odd-number-of-forms))
(let ((pairs (if contents
(loop for pairs = contents then (cddr pairs)
collect (list (car pairs) (cadr pairs))
while (cddr pairs))
'()))
(res (gensym)))
`(let ((,res (make-hash-table :test #'equal)))
,@(mapcar
(lambda (pair)
`(setf (gethash ,(car pair) ,res) ,(cadr pair)))
pairs)
,res)))))
(defvar *previous-readtables* nil)
(defmacro enable-hashtable-syntax ()
'(eval-when (:compile-toplevel :load-toplevel :execute)
(push *readtable* *previous-readtables*)
(setq *readtable* (copy-readtable))
(set-dispatch-macro-character #\# #\{ #'|#{-reader-}|)
(values)))
(defmacro disable-hashtable-syntax ()
'(eval-when (:compile-toplevel :load-toplevel :execute)
(setq *readtable* (pop *previous-readtables*))
(values)))
(defreadtable hashtable-syntax
(:merge :standard)
(:macro-char #\# :dispatch)
(:dispatch-macro-char #\# #\{ #'|#{-reader-}|))
(handler-bind (#+sbcl(sb-kernel:redefinition-with-defmethod #'muffle-warning))
(defmethod print-object ((object hash-table) stream)
(if (= (hash-table-count object) 0)
(format stream "#{}")
(let ((data (loop for k being the hash-keys of object
for v being the hash-values of object
for res = (format nil "~S ~S" k v)
then (format nil "~A ~S ~S" res k v)
finally (return res))))
(format stream "#{~A}" data)))))