[isidorus-cvs] r715 - trunk/src/rest_interface
lgiessmann at common-lisp.net
lgiessmann at common-lisp.net
Sun Aug 7 01:54:31 UTC 2011
Author: lgiessmann
Date: Sat Aug 6 18:54:30 2011
New Revision: 715
Log:
fixed ticket #118
Modified:
trunk/src/rest_interface/rest-interface.lisp
trunk/src/rest_interface/set-up-json-interface.lisp
Modified: trunk/src/rest_interface/rest-interface.lisp
==============================================================================
--- trunk/src/rest_interface/rest-interface.lisp Fri Aug 5 04:02:12 2011 (r714)
+++ trunk/src/rest_interface/rest-interface.lisp Sat Aug 6 18:54:30 2011 (r715)
@@ -61,7 +61,9 @@
:*xtm-commit-prefix*
:*ready-to-die*
:die-when-finished
- :*sparql-url*))
+ :*sparql-url*
+ :*use-http-authentication*
+ :*users*))
(in-package :rest-interface)
@@ -89,6 +91,7 @@
(defvar *remote-backup-remote-address* "127.0.0.1")
(defvar *local-backup-remote-address* "127.0.0.1")
(defvar *shutdown-remote-address* "127.0.0.1")
+(defvar *users* (list (list :uname "admin" :passwd "admin")))
(defun start-admin-server ()
@@ -168,3 +171,15 @@
(hunchentoot:stop *atom-server-acceptor*))
(setf *atom-server-acceptor* nil)
(close-tm-store))
+
+
+(defmacro with-http-authentication (&rest body)
+ `(multiple-value-bind (username password) (hunchentoot:authorization)
+ (if (find-if (lambda(item)
+ (and (stringp (getf item :uname))
+ (stringp (getf item :passwd))
+ (string= (getf item :uname) username)
+ (string= (getf item :passwd) password)))
+ *users*)
+ , at body
+ (hunchentoot:require-authorization "isidorus"))))
Modified: trunk/src/rest_interface/set-up-json-interface.lisp
==============================================================================
--- trunk/src/rest_interface/set-up-json-interface.lisp Fri Aug 5 04:02:12 2011 (r714)
+++ trunk/src/rest_interface/set-up-json-interface.lisp Sat Aug 6 18:54:30 2011 (r715)
@@ -12,18 +12,27 @@
;caching tables
(defparameter *type-table* nil "Cointains integer==OIDs that represent a topic
instance of a vylid type-topic")
+
(defparameter *instance-table* nil "Contains integer==OIDs that represent a topic
instance of a valid instance-topic")
+
(defparameter *overview-table* nil "Is of the following structure
((:topic <oid> :psis (<oid> <oid> <...>)) (...))
that represents a list of topics and their
valid psi object id's")
-
(defparameter *use-overview-cache* t "if this boolean vaue is set to t, the rest
interface uses the *verview-table*-list to
cache topics and their psis.")
+(defparameter *use-http-authentication* 0 "if this variable is set to > 0, the
+ host page will require basic
+ authentication. If it's value is set
+ to > 1, all json handlers will require
+ basic-authentication. If this value is
+ set to 0, no authentication is required.")
+
+
;the prefix to get a fragment by the psi -> localhost:8000/json/get/<fragment-psi>
(defparameter *json-get-prefix* "/json/get/(.+)$")
;the prefix to get a fragment by the psi -> localhost:8000/json/rdf/get/<fragment-psi>
@@ -107,78 +116,173 @@
;; e.g. a json error-message.
(push hunchentoot:+http-internal-server-error+ hunchentoot:*approved-return-codes*)
;; === html and css files ====================================================
- (push
- (create-static-file-dispatcher-and-handler ajax-user-interface-url ajax-user-interface-file-path "text/html")
- hunchentoot:*dispatch-table*)
-
- (dolist (script-path-and-url (make-file-path-and-url ajax-user-interface-css-directory-path ajax-user-interface-css-prefix))
- (let ((script-path (getf script-path-and-url :path))
- (script-url (getf script-path-and-url :url)))
- (push
- (create-static-file-dispatcher-and-handler script-url script-path)
- hunchentoot:*dispatch-table*)))
+ (if (> *use-http-authentication* 0)
+ (define-easy-handler (isidorus-ui :uri ajax-user-interface-url
+ :default-request-type :get)
+ ()
+ (with-http-authentication
+ (serve-file ajax-user-interface-file-path "text/html")))
+ (push
+ (create-static-file-dispatcher-and-handler
+ ajax-user-interface-url ajax-user-interface-file-path "text/html")
+ hunchentoot:*dispatch-table*))
+
+ (let ((files-and-urls
+ (make-file-path-and-url ajax-user-interface-css-directory-path
+ ajax-user-interface-css-prefix)))
+ (dotimes (idx (length files-and-urls))
+ (let ((script-path (getf (elt files-and-urls idx) :path))
+ (script-url (getf (elt files-and-urls idx) :url)))
+ (push
+ (create-static-file-dispatcher-and-handler script-url script-path)
+ hunchentoot:*dispatch-table*))))
;; === ajax frameworks and javascript files ==================================
- (dolist (script-path-and-url (make-file-path-and-url ajax-javascripts-directory-path ajax-javascripts-url-prefix))
- (let ((script-path (getf script-path-and-url :path))
- (script-url (getf script-path-and-url :url)))
- (push
- (create-static-file-dispatcher-and-handler script-url script-path)
- hunchentoot:*dispatch-table*)))
+ (let ((files-and-urls (make-file-path-and-url ajax-javascripts-directory-path
+ ajax-javascripts-url-prefix)))
+ (dotimes (idx (length files-and-urls))
+ (let ((script-path (getf (elt files-and-urls idx) :path))
+ (script-url (getf (elt files-and-urls idx) :url)))
+ (push
+ (create-static-file-dispatcher-and-handler script-url script-path)
+ hunchentoot:*dispatch-table*))))
;; === rest interface ========================================================
(push
(if *use-overview-cache*
- (create-regex-dispatcher json-get-all-psis #'cached-return-all-topic-psis)
- (create-regex-dispatcher json-get-all-psis #'return-all-topic-psis))
- hunchentoot:*dispatch-table*)
- (push
- (create-regex-dispatcher json-get-prefix #'return-json-fragment)
- hunchentoot:*dispatch-table*)
- (push
- (create-regex-dispatcher get-rdf-prefix #'return-json-rdf-fragment)
- hunchentoot:*dispatch-table*)
- (push
- (create-regex-dispatcher json-get-topic-stub-prefix #'return-topic-stub-of-psi)
- hunchentoot:*dispatch-table*)
- (push
- (create-regex-dispatcher json-get-all-type-psis #'return-all-tmcl-types)
- hunchentoot:*dispatch-table*)
- (push
- (create-regex-dispatcher json-get-all-instance-psis #'return-all-tmcl-instances)
- hunchentoot:*dispatch-table*)
- (push
- (create-regex-dispatcher json-get-type-tmcl-url #'(lambda(&optional param)
- (declare (ignorable param))
- (return-tmcl-info-of-psis 'json-tmcl::type)))
- hunchentoot:*dispatch-table*)
- (push
- (create-regex-dispatcher json-get-instance-tmcl-url #'(lambda(&optional param)
- (declare (ignorable param))
- (return-tmcl-info-of-psis 'json-tmcl::instance)))
- hunchentoot:*dispatch-table*)
- (push
- (create-regex-dispatcher json-get-overview #'return-overview)
- hunchentoot:*dispatch-table*)
- (push
- (create-regex-dispatcher json-commit-url #'json-commit)
- hunchentoot:*dispatch-table*)
- (push
- (create-regex-dispatcher json-get-summary-url #'return-topic-summaries)
- hunchentoot:*dispatch-table*)
- (push
- (create-regex-dispatcher mark-as-deleted-url #'mark-as-deleted-handler)
- hunchentoot:*dispatch-table*)
- (push
- (create-regex-dispatcher xtm-commit-prefix #'xtm-import-handler)
- 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)
+ (create-regex-dispatcher json-get-all-psis
+ (if (> *use-http-authentication* 1)
+ (lambda(&optional param)
+ (with-http-authentication
+ (cached-return-all-topic-psis param)))
+ #'cached-return-all-topic-psis))
+ (create-regex-dispatcher json-get-all-psis
+ (if (> *use-http-authentication* 1)
+ (lambda(&optional param)
+ (with-http-authentication
+ (return-all-topic-psis param)))
+ #'return-all-topic-psis)))
+ hunchentoot:*dispatch-table*)
+ (push
+ (create-regex-dispatcher json-get-prefix
+ (if (> *use-http-authentication* 1)
+ (lambda(&optional psi)
+ (with-http-authentication
+ (return-json-fragment psi)))
+ #'return-json-fragment))
+ hunchentoot:*dispatch-table*)
+ (push
+ (create-regex-dispatcher get-rdf-prefix
+ (if (> *use-http-authentication* 1)
+ (lambda(&optional psi)
+ (with-http-authentication
+ (return-json-rdf-fragment psi)))
+ #'return-json-rdf-fragment))
+ hunchentoot:*dispatch-table*)
+ (push
+ (create-regex-dispatcher json-get-topic-stub-prefix
+ (if (> *use-http-authentication* 1)
+ (lambda(&optional psi)
+ (with-http-authentication
+ (return-topic-stub-of-psi psi)))
+ #'return-topic-stub-of-psi))
+ hunchentoot:*dispatch-table*)
+ (push
+ (create-regex-dispatcher json-get-all-type-psis
+ (if (> *use-http-authentication* 1)
+ (lambda(&optional param)
+ (with-http-authentication
+ (return-all-tmcl-types param)))
+ #'return-all-tmcl-types))
+ hunchentoot:*dispatch-table*)
+ (push
+ (create-regex-dispatcher json-get-all-instance-psis
+ (if (> *use-http-authentication* 1)
+ (lambda(&optional param)
+ (with-http-authentication
+ (return-all-tmcl-instances param)))
+ #'return-all-tmcl-instances))
+ hunchentoot:*dispatch-table*)
+ (push
+ (create-regex-dispatcher json-get-type-tmcl-url
+ (if (> *use-http-authentication* 1)
+ (lambda(&optional param)
+ (declare (ignorable param))
+ (with-http-authentication
+ (return-tmcl-info-of-psis 'json-tmcl::type)))
+ (lambda(&optional param)
+ (declare (ignorable param))
+ (return-tmcl-info-of-psis 'json-tmcl::type))))
+ hunchentoot:*dispatch-table*)
+ (push
+ (create-regex-dispatcher json-get-instance-tmcl-url
+ (if (> *use-http-authentication* 1)
+ (lambda(&optional param)
+ (declare (ignorable param))
+ (with-http-authentication
+ (return-tmcl-info-of-psis 'json-tmcl::instance)))
+ (lambda(&optional param)
+ (declare (ignorable param))
+ (return-tmcl-info-of-psis 'json-tmcl::instance))))
+ hunchentoot:*dispatch-table*)
+ (push
+ (create-regex-dispatcher json-get-overview
+ (if (> *use-http-authentication* 1)
+ (lambda(&optional param)
+ (with-http-authentication
+ (return-overview param)))
+ #'return-overview))
+ hunchentoot:*dispatch-table*)
+ (push
+ (create-regex-dispatcher json-commit-url
+ (if (> *use-http-authentication* 1)
+ (lambda(&optional param)
+ (with-http-authentication
+ (json-commit param)))
+ #'json-commit))
+ hunchentoot:*dispatch-table*)
+ (push
+ (create-regex-dispatcher json-get-summary-url
+ (if (> *use-http-authentication* 1)
+ (lambda(&optional param)
+ (with-http-authentication
+ (return-topic-summaries param)))
+ #'return-topic-summaries))
+ hunchentoot:*dispatch-table*)
+ (push
+ (create-regex-dispatcher mark-as-deleted-url
+ (if (> *use-http-authentication* 1)
+ (lambda(&optional param)
+ (with-http-authentication
+ (mark-as-deleted-handler param)))
+ #'mark-as-deleted-handler))
+ hunchentoot:*dispatch-table*)
+ (push
+ (create-regex-dispatcher xtm-commit-prefix
+ (if (> *use-http-authentication* 1)
+ (lambda(&optional tm-id)
+ (with-http-authentication
+ (xtm-import-handler tm-id)))
+ #'xtm-import-handler))
+ hunchentoot:*dispatch-table*)
+ (push
+ (create-regex-dispatcher latest-revision-url
+ (if (> *use-http-authentication* 1)
+ (lambda(&optional param)
+ (declare (ignorable param))
+ (with-http-authentication
+ (return-latest-revision)))
+ #'return-latest-revision))
+ hunchentoot:*dispatch-table*)
+ (push
+ (create-regex-dispatcher sparql-url
+ (if *use-http-authentication*
+ (lambda(&optional param)
+ (with-http-authentication
+ (return-tm-sparql param)))
+ #'return-tm-sparql))
hunchentoot:*dispatch-table*))
;; =============================================================================
@@ -462,17 +566,17 @@
"Returns a json-object representing a topic map overview as a tree(s)"
(declare (ignorable param))
(with-reader-lock
- (handler-case
- (let ((json-string
- (json-tmcl::tree-view-to-json-string
- (json-tmcl::make-tree-view :revision 0))))
- (setf (hunchentoot:content-type*) "application/json") ;RFC 4627
- json-string)
- (Condition (err)
- (progn
- (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+)
- (setf (hunchentoot:content-type*) "text")
- (format nil "Condition: \"~a\"" err))))))
+ (handler-case
+ (let ((json-string
+ (json-tmcl::tree-view-to-json-string
+ (json-tmcl::make-tree-view :revision 0))))
+ (setf (hunchentoot:content-type*) "application/json") ;RFC 4627
+ json-string)
+ (Condition (err)
+ (progn
+ (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+)
+ (setf (hunchentoot:content-type*) "text")
+ (format nil "Condition: \"~a\"" err))))))
(defun mark-as-deleted-handler (&optional param)
@@ -762,6 +866,18 @@
*overview-table*))
(psi-oids (map 'list #'elephant::oid psis)))
(if node
- (dolist (psi psi-oids)
+ (dolist (psi psi-oids)1
(pushnew psi (getf node :psis) :test #'=))
- (push (list :topic top-oid :psis psi-oids) *overview-table*)))))
\ No newline at end of file
+ (push (list :topic top-oid :psis psi-oids) *overview-table*)))))
+
+
+(defun serve-file (file-path &optional mime-type)
+ "Returns a stream of the corresponding file."
+ (with-open-file (in file-path :direction :input
+ :element-type 'flex:octet)
+ (when mime-type
+ (setf (hunchentoot:content-type*) mime-type))
+ (let ((data (make-array (file-length in)
+ :element-type 'flex:octet)))
+ (read-sequence data in)
+ data)))
\ No newline at end of file
More information about the Isidorus-cvs
mailing list