| 1 | ;;+----------------------------------------------------------------------------- |
|---|
| 2 | ;;+ Isidorus |
|---|
| 3 | ;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff |
|---|
| 4 | ;;+ |
|---|
| 5 | ;;+ Isidorus is freely distributable under the LLGPL license. |
|---|
| 6 | ;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and |
|---|
| 7 | ;;+ trunk/docs/LGPL-LICENSE.txt. |
|---|
| 8 | ;;+----------------------------------------------------------------------------- |
|---|
| 9 | |
|---|
| 10 | (in-package :rest-interface) |
|---|
| 11 | |
|---|
| 12 | (defparameter *gdl-get-fragment* "/gdl/fragment/(.+)$") |
|---|
| 13 | (defparameter *gdl-get-schema* "/gdl/schema/?$") |
|---|
| 14 | (defparameter *gdl-commit-fragment* "/gdl/commit/?") |
|---|
| 15 | (defparameter *gdl-delete-fragment* "/gdl/delete/?") |
|---|
| 16 | (defparameter *gdl-host-address-hash-object* "/hash-object") |
|---|
| 17 | (defparameter *gdl-host-address-environment* "/environment") |
|---|
| 18 | (defparameter *gdl-base-path* "anaToMia/hosted_files/") |
|---|
| 19 | (defparameter *gdl-host-file* (concat *gdl-base-path* "GDL_Widgets.html")) |
|---|
| 20 | (defparameter *gdl-tm-id* "http://textgrid.org/serviceregistry/gdl-frontend/gdl-tm") |
|---|
| 21 | (defparameter *gdl-sparql* "/gdl/tm-sparql/?$") |
|---|
| 22 | |
|---|
| 23 | |
|---|
| 24 | (defun set-up-gdl-interface (&key (get-fragment *gdl-get-fragment*) |
|---|
| 25 | (get-schema *gdl-get-schema*) |
|---|
| 26 | (commit-fragment *gdl-commit-fragment*) |
|---|
| 27 | (delete-fragment *gdl-delete-fragment*) |
|---|
| 28 | (gdl-sparql *gdl-sparql*) |
|---|
| 29 | (base-path *gdl-base-path*) |
|---|
| 30 | (host-address-hash-object *gdl-host-address-hash-object*) |
|---|
| 31 | (host-address-environment *gdl-host-address-environment*) |
|---|
| 32 | (host-file *gdl-host-file*)) |
|---|
| 33 | (declare (String get-fragment get-schema commit-fragment |
|---|
| 34 | delete-fragment host-address-hash-object |
|---|
| 35 | host-address-environment host-file)) |
|---|
| 36 | |
|---|
| 37 | ;(init-cache nil) |
|---|
| 38 | ;(format t "~%") |
|---|
| 39 | (init-fragments nil) |
|---|
| 40 | |
|---|
| 41 | ;; registers the http-code 500 for an internal server error to the standard |
|---|
| 42 | ;; return codes. so there won't be attached a hunchentoot default message, |
|---|
| 43 | ;; this is necessary to be able to send error messages in an individual way/syntax |
|---|
| 44 | ;; e.g. a json error-message. |
|---|
| 45 | (push hunchentoot:+http-internal-server-error+ hunchentoot:*approved-return-codes*) |
|---|
| 46 | |
|---|
| 47 | (init-hosted-files :host-address-hash-object host-address-hash-object |
|---|
| 48 | :host-address-environment host-address-environment |
|---|
| 49 | :host-file host-file :base-path base-path) |
|---|
| 50 | |
|---|
| 51 | (push |
|---|
| 52 | (create-regex-dispatcher get-fragment |
|---|
| 53 | (if (> *use-http-authentication* 2) |
|---|
| 54 | (lambda(&optional param) |
|---|
| 55 | (with-http-authentication |
|---|
| 56 | (return-json-fragment-handler param))) |
|---|
| 57 | #'return-json-fragment-handler)) |
|---|
| 58 | hunchentoot:*dispatch-table*) |
|---|
| 59 | |
|---|
| 60 | (push |
|---|
| 61 | (create-regex-dispatcher get-schema |
|---|
| 62 | (if (> *use-http-authentication* 2) |
|---|
| 63 | (lambda() |
|---|
| 64 | (with-http-authentication |
|---|
| 65 | (return-gdl-schema-handler))) |
|---|
| 66 | #'return-gdl-schema-handler)) |
|---|
| 67 | hunchentoot:*dispatch-table*) |
|---|
| 68 | |
|---|
| 69 | (push |
|---|
| 70 | (create-regex-dispatcher commit-fragment |
|---|
| 71 | (if (> *use-http-authentication* 1) |
|---|
| 72 | (lambda() |
|---|
| 73 | (with-http-authentication |
|---|
| 74 | (commit-fragment-handler))) |
|---|
| 75 | #'commit-fragment-handler)) |
|---|
| 76 | hunchentoot:*dispatch-table*) |
|---|
| 77 | |
|---|
| 78 | (push |
|---|
| 79 | (create-regex-dispatcher delete-fragment |
|---|
| 80 | (if (> *use-http-authentication* 1) |
|---|
| 81 | (lambda() |
|---|
| 82 | (with-http-authentication |
|---|
| 83 | (delete-handler))) |
|---|
| 84 | #'delete-handler)) |
|---|
| 85 | hunchentoot:*dispatch-table*) |
|---|
| 86 | |
|---|
| 87 | (push |
|---|
| 88 | (create-regex-dispatcher gdl-sparql |
|---|
| 89 | (if (> *use-http-authentication* 2) |
|---|
| 90 | (lambda(&optional param) |
|---|
| 91 | (with-http-authentication |
|---|
| 92 | (gdl-sparql-handler param))) |
|---|
| 93 | #'gdl-sparql-handler)) |
|---|
| 94 | hunchentoot:*dispatch-table*)) |
|---|
| 95 | |
|---|
| 96 | |
|---|
| 97 | (defun init-hosted-files (&key (host-address-hash-object *gdl-host-address-hash-object*) |
|---|
| 98 | (host-address-environment *gdl-host-address-environment*) |
|---|
| 99 | (host-file *gdl-host-file*) |
|---|
| 100 | (base-path *gdl-base-path*)) |
|---|
| 101 | "Adds handlers for the css, html and js files needed by the frontend." |
|---|
| 102 | (declare (String host-address-hash-object host-address-environment |
|---|
| 103 | host-file base-path)) |
|---|
| 104 | ;; add the actual html file |
|---|
| 105 | (let ((full-host-path |
|---|
| 106 | (concat (namestring |
|---|
| 107 | (asdf:component-pathname constants:*isidorus-system*)) |
|---|
| 108 | host-file)) |
|---|
| 109 | (absolute-base-path |
|---|
| 110 | (concat |
|---|
| 111 | (namestring |
|---|
| 112 | (asdf:component-pathname constants:*isidorus-system*)) |
|---|
| 113 | base-path))) |
|---|
| 114 | (if (> *use-http-authentication* 0) |
|---|
| 115 | (progn |
|---|
| 116 | (define-easy-handler (isidorus-ui :uri host-address-hash-object |
|---|
| 117 | :default-request-type :get) |
|---|
| 118 | () |
|---|
| 119 | (with-http-authentication |
|---|
| 120 | (serve-file full-host-path "text/html"))) |
|---|
| 121 | (define-easy-handler (isidorus-ui :uri host-address-environment |
|---|
| 122 | :default-request-type :get) |
|---|
| 123 | () |
|---|
| 124 | (with-http-authentication |
|---|
| 125 | (serve-file full-host-path "text/html")))) |
|---|
| 126 | (progn |
|---|
| 127 | (push |
|---|
| 128 | (create-static-file-dispatcher-and-handler |
|---|
| 129 | host-address-hash-object full-host-path "text/html") |
|---|
| 130 | hunchentoot:*dispatch-table*) |
|---|
| 131 | (push |
|---|
| 132 | (create-static-file-dispatcher-and-handler |
|---|
| 133 | host-address-environment full-host-path "text/html") |
|---|
| 134 | hunchentoot:*dispatch-table*))) |
|---|
| 135 | ; add all additional files |
|---|
| 136 | (let ((absolute-base-path-len (length absolute-base-path))) |
|---|
| 137 | (com.gigamonkeys.pathnames:walk-directory |
|---|
| 138 | "anaToMia/hosted_files" |
|---|
| 139 | (lambda(item) |
|---|
| 140 | (unless (or (search "/.svn/" (namestring item) :test #'string=) |
|---|
| 141 | (string= full-host-path (namestring item))) |
|---|
| 142 | (let* ((rel-addr (subseq (namestring item) absolute-base-path-len)) |
|---|
| 143 | (content-type (generate-content-type (file-namestring item))) |
|---|
| 144 | (rel-uri (concat "/" rel-addr))) |
|---|
| 145 | (push |
|---|
| 146 | (create-static-file-dispatcher-and-handler |
|---|
| 147 | rel-uri item content-type) |
|---|
| 148 | hunchentoot:*dispatch-table*)))))))) |
|---|
| 149 | |
|---|
| 150 | |
|---|
| 151 | (defun generate-content-type(file-name) |
|---|
| 152 | "Returns a mime-type that corresponds to the passed |
|---|
| 153 | file-ending, note currently onle a fey types are supported!" |
|---|
| 154 | (declare (String file-name)) |
|---|
| 155 | (cond ((string-ends-with file-name "png" :ignore-case t) |
|---|
| 156 | "image/png") |
|---|
| 157 | ((string-ends-with file-name "html" :ignore-case t) |
|---|
| 158 | "text/html") |
|---|
| 159 | ((string-ends-with file-name "js" :ignore-case t) |
|---|
| 160 | "application/json") |
|---|
| 161 | ((string-ends-with file-name "css" :ignore-case t) |
|---|
| 162 | "text/css") |
|---|
| 163 | ((string-ends-with file-name "gif" :ignore-case t) |
|---|
| 164 | "image/gif") |
|---|
| 165 | (t |
|---|
| 166 | "text/plain"))) |
|---|
| 167 | |
|---|
| 168 | |
|---|
| 169 | (defun delete-handler() |
|---|
| 170 | "marks the corresponding construct(s) as deleted" |
|---|
| 171 | (let ((http-method (hunchentoot:request-method*))) |
|---|
| 172 | (if (or (eq http-method :DELETE) |
|---|
| 173 | (eq http-method :POST)) |
|---|
| 174 | (let ((external-format |
|---|
| 175 | (flexi-streams:make-external-format :UTF-8 :eol-style :LF))) |
|---|
| 176 | (let ((json-data |
|---|
| 177 | (hunchentoot:raw-post-data :external-format external-format |
|---|
| 178 | :force-text t))) |
|---|
| 179 | (with-writer-lock |
|---|
| 180 | (let* ((rev (d:get-revision)) |
|---|
| 181 | (result (jtm-delete-interface:mark-as-deleted-from-jtm |
|---|
| 182 | json-data :revision rev))) |
|---|
| 183 | (let ((tops |
|---|
| 184 | (remove-null |
|---|
| 185 | (cond ((or (typep result 'OccurrenceC) |
|---|
| 186 | (typep result 'NameC)) |
|---|
| 187 | (let ((top (parent result :revision (1- rev)))) |
|---|
| 188 | (when top (list top)))) |
|---|
| 189 | ((typep result 'VariantC) |
|---|
| 190 | (let ((name (parent result :revision (1- rev)))) |
|---|
| 191 | (when name |
|---|
| 192 | (let ((top (parent name :revision (1- rev)))) |
|---|
| 193 | (when top (list top)))))) |
|---|
| 194 | ((typep result 'AssociationC) |
|---|
| 195 | (map 'list (lambda(role) |
|---|
| 196 | (player role :revision (1- rev))) |
|---|
| 197 | (roles result :revision (1- rev)))) |
|---|
| 198 | ((typep result 'TopicC) |
|---|
| 199 | (let ((assocs |
|---|
| 200 | (remove-null |
|---|
| 201 | (map 'list (lambda(role) |
|---|
| 202 | (parent role :revision (1- rev))) |
|---|
| 203 | (player-in-roles result :revision (1- rev))))) |
|---|
| 204 | (frags |
|---|
| 205 | (elephant:get-instances-by-value |
|---|
| 206 | 'd:FragmentC 'd:topic result))) |
|---|
| 207 | (map nil #'elephant:drop-instance frags) |
|---|
| 208 | (loop for assoc in assocs |
|---|
| 209 | append (map 'list (lambda(role) |
|---|
| 210 | (player role :revision (1- rev))) |
|---|
| 211 | (roles assoc :revision (1- rev)))))))))) |
|---|
| 212 | (map nil (lambda(top) |
|---|
| 213 | (let ((frags |
|---|
| 214 | (elephant:get-instances-by-value 'd:FragmentC 'd:topic top))) |
|---|
| 215 | (map nil #'elephant:drop-instance frags)) |
|---|
| 216 | (create-latest-fragment-of-topic top)) |
|---|
| 217 | (if (typep result 'd:TopicC) |
|---|
| 218 | (delete result tops) |
|---|
| 219 | tops))) |
|---|
| 220 | (unless result |
|---|
| 221 | (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+) |
|---|
| 222 | (format nil "object not found")))))) |
|---|
| 223 | (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)))) |
|---|
| 224 | |
|---|
| 225 | |
|---|
| 226 | (defun commit-fragment-handler () |
|---|
| 227 | "handles commits in the JTM 1.1 format." |
|---|
| 228 | (let ((http-method (hunchentoot:request-method*))) |
|---|
| 229 | (if (or (eq http-method :PUT) |
|---|
| 230 | (eq http-method :POST)) |
|---|
| 231 | (let ((external-format |
|---|
| 232 | (flexi-streams:make-external-format :UTF-8 :eol-style :LF))) |
|---|
| 233 | (let ((json-data |
|---|
| 234 | (hunchentoot:raw-post-data :external-format external-format |
|---|
| 235 | :force-text t))) |
|---|
| 236 | (with-writer-lock |
|---|
| 237 | (jtm-importer:import-construct-from-jtm-string |
|---|
| 238 | json-data :revision (get-revision) :tm-id *gdl-tm-id* |
|---|
| 239 | :create-fragments t)))) |
|---|
| 240 | (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)))) |
|---|
| 241 | |
|---|
| 242 | |
|---|
| 243 | (defun return-gdl-schema-handler() |
|---|
| 244 | "Currently the entore topic map is returned. |
|---|
| 245 | To emerge the efficiency it will be necessary |
|---|
| 246 | to structure the data as GDL-Fragments, so each view or schema |
|---|
| 247 | can be served separately." |
|---|
| 248 | (let ((http-method (hunchentoot:request-method*))) |
|---|
| 249 | (if (eq http-method :GET) |
|---|
| 250 | (progn (setf (hunchentoot:content-type*) "application/json") |
|---|
| 251 | (jtm-exporter:export-as-jtm-string :revision 0)) |
|---|
| 252 | (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)))) |
|---|
| 253 | |
|---|
| 254 | |
|---|
| 255 | (defun return-json-fragment-handler(&optional psi) |
|---|
| 256 | "returns the json-fragmen belonging to the psi passed by the parameter psi" |
|---|
| 257 | (assert psi) |
|---|
| 258 | (let ((http-method (hunchentoot:request-method*))) |
|---|
| 259 | (if (eq http-method :GET) |
|---|
| 260 | (let ((identifier (hunchentoot:url-decode psi))) |
|---|
| 261 | (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 |
|---|
| 262 | (let ((fragment |
|---|
| 263 | (with-reader-lock |
|---|
| 264 | (get-latest-fragment-of-topic identifier)))) |
|---|
| 265 | (if fragment |
|---|
| 266 | (with-reader-lock |
|---|
| 267 | (jtm-exporter:export-construct-as-jtm-string |
|---|
| 268 | fragment :revision 0)) |
|---|
| 269 | (progn |
|---|
| 270 | (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+) |
|---|
| 271 | (setf (hunchentoot:content-type*) "text") |
|---|
| 272 | (format nil "Topic \"~a\" not found" psi))))) |
|---|
| 273 | (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)))) |
|---|
| 274 | |
|---|
| 275 | |
|---|
| 276 | (defun gdl-sparql-handler(&optional param) |
|---|
| 277 | "Returns a JSON object representing a SPARQL response." |
|---|
| 278 | (declare (Ignorable param)) |
|---|
| 279 | (if (eql (hunchentoot:request-method*) :POST) |
|---|
| 280 | (let ((external-format (flexi-streams:make-external-format |
|---|
| 281 | :UTF-8 :eol-style :LF))) |
|---|
| 282 | (let ((sparql-request (hunchentoot:raw-post-data |
|---|
| 283 | :external-format external-format |
|---|
| 284 | :force-text t))) |
|---|
| 285 | (export-construct-as-isidorus-json-string |
|---|
| 286 | (make-instance 'SPARQL-Query :query sparql-request |
|---|
| 287 | :revision 0)))) |
|---|
| 288 | (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+))) |
|---|
