[isidorus-cvs] r360 - in trunk/src: . TM-SPARQL base-tools json rest_interface
Lukas Giessmann
lgiessmann at common-lisp.net
Sat Dec 4 21:05:06 UTC 2010
Author: lgiessmann
Date: Sat Dec 4 16:05:05 2010
New Revision: 360
Log:
fixed ticket #87 => added a JSON-handler for SPARQL-requests; fixed a bug in base-tools:trim-whitespace => #\cr is also added as a whitespace character
Modified:
trunk/src/TM-SPARQL/sparql.lisp
trunk/src/TM-SPARQL/sparql_parser.lisp
trunk/src/base-tools/base-tools.lisp
trunk/src/isidorus.asd
trunk/src/json/json_exporter.lisp
trunk/src/rest_interface/rest-interface.lisp
trunk/src/rest_interface/set-up-json-interface.lisp
Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp (original)
+++ trunk/src/TM-SPARQL/sparql.lisp Sat Dec 4 16:05:05 2010
@@ -759,9 +759,9 @@
(let ((result-lists (make-result-lists construct)))
(reduce-results construct result-lists)
(let* ((response-variables
- (if (*-p construct)
- (all-variables construct)
- (variables construct)))
+ (reverse (if (*-p construct)
+ (all-variables construct)
+ (variables construct))))
(cleaned-results (make-result-lists construct)))
(map 'list #'(lambda(response-variable)
(list :variable response-variable
Modified: trunk/src/TM-SPARQL/sparql_parser.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_parser.lisp (original)
+++ trunk/src/TM-SPARQL/sparql_parser.lisp Sat Dec 4 16:05:05 2010
@@ -76,7 +76,8 @@
(t
(error (make-sparql-parser-condition
trimmed-query-string (original-query construct)
- "SELECT, PREFIX or BASE")))))))
+ (format nil "SELECT, PREFIX or BASE, but found: ~a..."
+ (subseq trimmed-query-string 0 10)))))))))
(defgeneric parse-select (construct query-string)
Modified: trunk/src/base-tools/base-tools.lisp
==============================================================================
--- trunk/src/base-tools/base-tools.lisp (original)
+++ trunk/src/base-tools/base-tools.lisp Sat Dec 4 16:05:05 2010
@@ -70,19 +70,19 @@
(defun trim-whitespace-left (value)
"Uses string-left-trim with a predefined character-list."
(declare (String value))
- (string-left-trim '(#\Space #\Tab #\Newline) value))
+ (string-left-trim '(#\Space #\Tab #\Newline #\cr) value))
(defun trim-whitespace-right (value)
"Uses string-right-trim with a predefined character-list."
(declare (String value))
- (string-right-trim '(#\Space #\Tab #\Newline) value))
+ (string-right-trim '(#\Space #\Tab #\Newline #\cr) value))
(defun trim-whitespace (value)
"Uses string-trim with a predefined character-list."
(declare (String value))
- (string-trim '(#\Space #\Tab #\Newline) value))
+ (string-trim '(#\Space #\Tab #\Newline #\cr) value))
(defun string-starts-with (str prefix &key (ignore-case nil))
Modified: trunk/src/isidorus.asd
==============================================================================
--- trunk/src/isidorus.asd (original)
+++ trunk/src/isidorus.asd Sat Dec 4 16:05:05 2010
@@ -104,6 +104,7 @@
:depends-on ("model"
"atom"
"xml"
+ "TM-SPARQL"
"json"
"threading"))
(:module "unit_tests"
@@ -194,7 +195,8 @@
(:file "json_delete_interface"
:depends-on ("json_importer")))
:depends-on ("model"
- "xml"))
+ "xml"
+ "TM-SPARQL"))
(:module "ajax"
:components ((:static-file "isidorus.html")
(:module "javascripts"
Modified: trunk/src/json/json_exporter.lisp
==============================================================================
--- trunk/src/json/json_exporter.lisp (original)
+++ trunk/src/json/json_exporter.lisp Sat Dec 4 16:05:05 2010
@@ -8,7 +8,7 @@
;;+-----------------------------------------------------------------------------
(defpackage :json-exporter
- (:use :cl :json :datamodel)
+ (:use :cl :json :datamodel :TM-SPARQL :base-tools)
(:export :to-json-string
:get-all-topic-psis
:to-json-string-summary
@@ -475,4 +475,25 @@
(to-json-string-summary topic :revision revision) ","))))
(subseq inner-string 0 (- (length inner-string) 1)))))
(concatenate 'string "[" json-string "]"))
- "null"))
\ No newline at end of file
+ "null"))
+
+
+;; =============================================================================
+;; --- json data sparql-results ------------------------------------------------
+;; =============================================================================
+
+(defmethod to-json-string ((construct SPARQL-Query) &key xtm-id revision)
+ "Returns a JSON string that represents the object query result."
+ (declare (Ignorable revision xtm-id))
+ (let ((query-result (result construct)))
+ (if (not query-result)
+ "null"
+ (let ((j-str "{"))
+ (loop for entry in query-result
+ do (push-string
+ (concatenate
+ 'string
+ (json:encode-json-to-string (getf entry :variable)) ":"
+ (json:encode-json-to-string (getf entry :result)) ",")
+ j-str))
+ (concatenate 'string (subseq j-str 0 (- (length j-str) 1)) "}")))))
\ No newline at end of file
Modified: trunk/src/rest_interface/rest-interface.lisp
==============================================================================
--- trunk/src/rest_interface/rest-interface.lisp (original)
+++ trunk/src/rest_interface/rest-interface.lisp Sat Dec 4 16:05:05 2010
@@ -12,6 +12,8 @@
(:use :cl :hunchentoot
:cxml
:constants
+ :exceptions
+ :TM-SPARQL
:atom
:datamodel
:exporter
@@ -44,7 +46,8 @@
:*ajax-user-interface-file-path*
:*ajax-javascript-directory-path*
:*ajax-javascript-url-prefix*
- :*xtm-commit-prefix*))
+ :*xtm-commit-prefix*
+ :*sparql-url*))
(in-package :rest-interface)
Modified: trunk/src/rest_interface/set-up-json-interface.lisp
==============================================================================
--- trunk/src/rest_interface/set-up-json-interface.lisp (original)
+++ trunk/src/rest_interface/set-up-json-interface.lisp Sat Dec 4 16:05:05 2010
@@ -59,6 +59,8 @@
(defparameter *mark-as-deleted-url* "/mark-as-deleted")
;the get url to request the latest revision of the storage
(defparameter *latest-revision-url* "/json/latest-revision/?$")
+;the ulr to invoke a SPARQL query
+(defparameter *sparql-url* "/json/tm-sparql/?$")
(defun set-up-json-interface (&key (json-get-prefix *json-get-prefix*)
@@ -80,7 +82,8 @@
(ajax-javascripts-url-prefix *ajax-javascript-url-prefix*)
(mark-as-deleted-url *mark-as-deleted-url*)
(latest-revision-url *latest-revision-url*)
- (xtm-commit-prefix *xtm-commit-prefix*))
+ (xtm-commit-prefix *xtm-commit-prefix*)
+ (sparql-url *sparql-url*))
"registers the json im/exporter to the passed base-url in hunchentoot's dispatch-table
and also registers a file-hanlder to the html-user-interface"
@@ -162,6 +165,9 @@
hunchentoot:*dispatch-table*)
(push
(create-regex-dispatcher latest-revision-url #'return-latest-revision)
+ hunchentoot:*dispatch-table*)
+ (push
+ (create-regex-dispatcher sparql-url #'return-tm-sparql)
hunchentoot:*dispatch-table*))
;; =============================================================================
@@ -485,6 +491,28 @@
(setf (hunchentoot:content-type*) "text")
(format nil "Condition: \"~a\"" err)))))
+
+(defun return-tm-sparql (&optional param)
+ "Returns a JSON object representing a SPARQL response."
+ (declare (Ignorable param))
+ (handler-case
+ (if (eql (hunchentoot:request-method*) :POST)
+ (let ((external-format (flexi-streams:make-external-format
+ :UTF-8 :eol-style :LF)))
+ (let ((sparql-request (hunchentoot:raw-post-data
+ :external-format external-format
+ :force-text t)))
+ (to-json-string (make-instance 'SPARQL-Query :query sparql-request
+ :revision 0))))
+ (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+))
+ (condition (err)
+ (progn
+ (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+)
+ (setf (hunchentoot:content-type*) "text")
+ (if (typep err 'SPARQL-Parser-Error)
+ (format nil "SPARQL-Parser-Error: \"~a\"" (exceptions::message err))
+ (format nil "Condition: \"~a\"" err))))))
+
;; =============================================================================
;; --- some helper functions ---------------------------------------------------
;; =============================================================================
More information about the Isidorus-cvs
mailing list