Author: lgiessmann Date: Mon Sep 26 04:56:25 2011 New Revision: 977 Log: trunk: merged branches/gdl-frontend with trunk; fixed all conflicts Added: trunk/playground/GWT-Examples/ - copied from r976, branches/gdl-frontend/playground/GWT-Examples/ trunk/src/anaToMia/ - copied from r976, branches/gdl-frontend/src/anaToMia/ trunk/src/json/JTM/jtm_delete_interface.lisp - copied unchanged from r976, branches/gdl-frontend/src/json/JTM/jtm_delete_interface.lisp trunk/src/rest_interface/set-up-gdl-interface.lisp - copied unchanged from r976, branches/gdl-frontend/src/rest_interface/set-up-gdl-interface.lisp Modified: trunk/src/TM-SPARQL/sparql_parser.lisp trunk/src/isidorus.asd trunk/src/json/JTM/jtm_aliases.lisp trunk/src/json/JTM/jtm_importer.lisp trunk/src/json/JTM/jtm_tools.lisp trunk/src/model/changes.lisp trunk/src/rest_interface/rest-interface.lisp trunk/src/rest_interface/set-up-json-interface.lisp trunk/src/xml/xtm/exporter.lisp Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp Mon Sep 26 02:48:59 2011 (r976) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Mon Sep 26 04:56:25 2011 (r977) @@ -427,7 +427,7 @@ (progn (add-variable construct "*") (parse-variables construct (string-after trimmed-str "*"))) (let ((result (parse-variable-name construct trimmed-str))) - (add-variable construct (getf result :value)) + (add-variable construct (trim-whitespace-right (getf result :value))) (parse-variables construct (getf result :next-query)))))))) Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd Mon Sep 26 02:48:59 2011 (r976) +++ trunk/src/isidorus.asd Mon Sep 26 04:56:25 2011 (r977) @@ -113,6 +113,9 @@ :depends-on ("rest-interface")) (:file "admin-interface" :depends-on ("rest-interface")) + (:file "set-up-gdl-interface" + :depends-on ("rest-interface" + "set-up-json-interface")) (:file "read" :depends-on ("rest-interface"))) :depends-on ("model" "atom" "xml" "TM-SPARQL" @@ -210,6 +213,8 @@ :depends-on ("jtm_tools")) (:file "jtm_exporter" :depends-on ("jtm_tools")) + (:file "jtm_delete_interface" + :depends-on ("jtm_tools" "jtm_importer")) (:file "jtm_aliases" :depends-on ("jtm_tools" "jtm_importer" "jtm_exporter"))))) :depends-on ("base-tools" "model" "xml" "TM-SPARQL")) Modified: trunk/src/json/JTM/jtm_aliases.lisp ============================================================================== --- trunk/src/json/JTM/jtm_aliases.lisp Mon Sep 26 02:48:59 2011 (r976) +++ trunk/src/json/JTM/jtm_aliases.lisp Mon Sep 26 04:56:25 2011 (r977) @@ -27,10 +27,17 @@ :constants :exceptions :jtm) (:export :import-from-jtm :import-construct-from-jtm-string + :import-construct-from-jtm-decoded-list :item_type-topicmap :item_type-topic :item_type-name :item_type-variant :item_type-occurrence :item_type-association - :item_type-role)) \ No newline at end of file + :item_type-role)) + + +(defpackage :jtm-delete-interface + (:use :cl :json :datamodel :base-tools :isidorus-threading + :constants :exceptions :jtm) + (:export :mark-as-deleted-from-jtm)) \ No newline at end of file Copied: trunk/src/json/JTM/jtm_delete_interface.lisp (from r976, branches/gdl-frontend/src/json/JTM/jtm_delete_interface.lisp) ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/json/JTM/jtm_delete_interface.lisp Mon Sep 26 04:56:25 2011 (r977, copy of r976, branches/gdl-frontend/src/json/JTM/jtm_delete_interface.lisp) @@ -0,0 +1,393 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff +;;+ +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + +(defpackage :jtm-delete-interface + (:use :cl :datamodel :jtm) + (:export :mark-as-deleted-from-jtm)) + +(in-package :jtm-delete-interface) + +(defun mark-as-deleted-from-jtm (jtm-data &key (revision *TM-REVISION*)) + "Marks an object that is specified by the given JSON data as deleted." + (declare (string jtm-data) (integer revision)) + (let ((json-list (json:decode-json-from-string jtm-data))) + (let ((type nil) + (parent nil) + (parent-of-parent nil) + (delete nil)) + (loop for json-entry in json-list + do (let ((st (car json-entry)) + (nd (cdr json-entry))) + (cond ((eql st :type) + (setf type nd)) + ((eql st :delete) + (setf delete nd)) + ((eql st :parent) + (setf parent nd)) + ((eql st :parent-of-parent) + (setf parent-of-parent nd))))) + (cond ((string= type "Topic") + (delete-topic-from-jtm delete :revision revision)) + ((string= type "PSI") + (delete-identifier-from-jtm delete 'd:PersistentIdC + #'d:delete-psi :revision revision)) + ((string= type "ItemIdentity") + (delete-identifier-from-jtm delete 'd:ItemIdentifierC + #'d:delete-item-identifier + :revision revision)) + ((string= type "SubjectLocator") + (delete-identifier-from-jtm delete 'd:SubjectLocatorC + #'d:delete-locator :revision revision)) + ((string= type "Name") + (delete-name-from-jtm delete :revision revision)) + ((string= type "Variant") + (delete-variant-from-jtm delete :revision revision)) + ((string= type "Occurrence") + (delete-occurrence-from-jtm delete :revision revision)) + ((string= type "Association") + (delete-association-from-jtm delete :revision revision)) + ((string= type "Role") + (delete-role-from-jtm delete :revision revision)) + (t + (error "Type \"~a\" is not defined" type)))))) + + +(defun delete-role-from-jtm (jtm-decoded-list + &key (revision *TM-REVISION*)) + "Deletes the passed role object and returns t otherwise this + function returns nil." + (declare (list jtm-decoded-list) (integer revision)) + (let* ((prefs (jtm::make-prefix-list-from-jtm-list + (jtm::get-item :PREFIXES jtm-decoded-list))) + (ii + (let ((curies (jtm::get-item :ITEM--IDENTIFIERS jtm-decoded-list))) + (when curies + (jtm::compute-uri-from-jtm-identifier (first curies) prefs)))) + (type + (let ((curie (jtm::get-item :TYPE jtm-decoded-list))) + (when curie + (jtm::get-item-from-jtm-reference curie :revision revision + :prefixes prefs)))) + (reifier + (let ((curie (jtm::get-item :REIFIER jtm-decoded-list))) + (when curie + (jtm::get-item-from-jtm-reference + curie :revision revision :prefixes prefs)))) + (parent + (let* ((curies (jtm::get-item :PARENT jtm-decoded-list)) + (parents (jtm::get-items-from-jtm-references + curies :revision revision :prefixes prefs))) + (when parents + (first parents)))) + (player-top + (let ((curie (jtm::get-item :PLAYER jtm-decoded-list))) + (when curie + (jtm::get-item-from-jtm-reference curie :revision revision + :prefixes prefs))))) + (let ((role-to-delete + (cond (ii + (identified-construct ii :revision revision)) + (reifier + (reified-construct reifier :revision revision)) + (parent + (let ((found-roles + (tools:remove-null + (map 'list (lambda(role) + (when (d::equivalent-construct + role :start-revision revision + :player player-top + :instance-of type) + role)) + (roles parent :revision revision))))) + (when found-roles + (first found-roles)))) + (t + (error "when deleting a role, there must be an item-identifier, reifier or parent set!"))))) + (when role-to-delete + (delete-role (parent role-to-delete :revision revision) + role-to-delete :revision revision) + role-to-delete)))) + + + + +(defun delete-association-from-jtm (jtm-decoded-list &key + (revision *TM-REVISION*)) + "Deletes the passed association object and returns t otherwise this + function returns nil." + (declare (list jtm-decoded-list) (integer revision)) + (let* ((prefs (jtm::make-prefix-list-from-jtm-list + (jtm::get-item :PREFIXES jtm-decoded-list))) + (ii + (let ((curies (jtm::get-item :ITEM--IDENTIFIERS jtm-decoded-list))) + (when curies + (jtm::compute-uri-from-jtm-identifier (first curies) prefs)))) + (scope + (let ((curies (jtm::get-item :SCOPE jtm-decoded-list))) + (jtm::get-items-from-jtm-references + curies :revision revision :prefixes prefs))) + (type + (let ((curie (jtm::get-item :TYPE jtm-decoded-list))) + (when curie + (jtm::get-item-from-jtm-reference curie :revision revision + :prefixes prefs)))) + (reifier + (let ((curie (jtm::get-item :REIFIER jtm-decoded-list))) + (when curie + (jtm::get-item-from-jtm-reference + curie :revision revision :prefixes prefs)))) + (roles + (map 'list (lambda(jtm-role) + (jtm::make-plist-of-jtm-role + jtm-role :revision revision :prefixes prefs)) + (jtm::get-item :ROLES jtm-decoded-list)))) + (let ((assoc-to-delete + (cond (ii + (identified-construct ii :revision revision)) + (reifier + (reified-construct reifier :revision revision)) + (t + (let ((found-assocs + (tools:remove-null + (map 'list (lambda(assoc) + (d::equivalent-construct + assoc :start-revision revision + :roles roles :instance-of type + :themes scope)) + (get-all-associations revision))))) + (when found-assocs + (first found-assocs))))))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision) + assoc-to-delete)))) + + +(defun delete-variant-from-jtm (jtm-decoded-list + &key (revision *TM-REVISION*)) + "Deletes the passed variant from the given name and returns t if the + operation succeeded." + (declare (list jtm-decoded-list) (integer revision)) + (let* ((prefs (jtm::make-prefix-list-from-jtm-list + (jtm::get-item :PREFIXES jtm-decoded-list))) + (ii + (let ((curies (jtm::get-item :ITEM--IDENTIFIERS jtm-decoded-list))) + (when curies + (jtm::compute-uri-from-jtm-identifier (first curies) prefs)))) + (value (jtm::get-item :VALUE jtm-decoded-list)) + (datatype (jtm::get-item :DATATYPE jtm-decoded-list)) + (scope + (let ((curies (jtm::get-item :SCOPE jtm-decoded-list))) + (jtm::get-items-from-jtm-references + curies :revision revision :prefixes prefs))) + (parent + (let* ((curies (jtm::get-item :PARENT jtm-decoded-list)) + (parents (jtm::get-items-from-jtm-references + curies :revision revision :prefixes prefs))) + (when parents + (first parents)))) + (reifier + (let ((curie (jtm::get-item :REIFIER jtm-decoded-list))) + (when curie + (jtm::get-item-from-jtm-reference + curie :revision revision :prefixes prefs))))) + (let ((var-to-delete + (cond (ii + (identified-construct ii :revision revision)) + (reifier + (reified-construct reifier :revision revision)) + (parent + (let ((found-vars + (tools:remove-null + (map 'list (lambda(var) + (when (d::equivalent-construct + var :start-revision revision + :charvalue value :themes scope + :datatype datatype) + var)) + (variants parent :revision revision))))) + (when found-vars + (first found-vars)))) + (t + (error "when deleting a variant, there must be an item-identifier, reifier or parent set!"))))) + (when var-to-delete + (delete-variant (parent var-to-delete :revision revision) + var-to-delete :revision revision) + var-to-delete)))) + + +(defun delete-occurrence-from-jtm (jtm-decoded-list + &key (revision *TM-REVISION*)) + "Deletes the passed occurrence from the given topic and returns t if the + operation succeeded." + (declare (list jtm-decoded-list) (integer revision)) + (let* ((prefs (jtm::make-prefix-list-from-jtm-list + (jtm::get-item :PREFIXES jtm-decoded-list))) + (ii + (let ((curies (jtm::get-item :ITEM--IDENTIFIERS jtm-decoded-list))) + (when curies + (jtm::compute-uri-from-jtm-identifier (first curies) prefs)))) + (value (jtm::get-item :VALUE jtm-decoded-list)) + (datatype + (let ((curie (jtm::get-item :DATATYPE jtm-decoded-list))) + (cond ((null curie) + constants:*xml-string*) + ((and (tools:string-starts-with curie "[") + (tools:string-ends-with curie "]")) + (jtm::compute-uri-from-jtm-identifier curie prefs)) + (t + curie)))) + (type + (let ((curie (jtm::get-item :TYPE jtm-decoded-list))) + (when curie + (jtm::get-item-from-jtm-reference curie :revision revision + :prefixes prefs)))) + (scope + (let ((curies (jtm::get-item :SCOPE jtm-decoded-list))) + (jtm::get-items-from-jtm-references + curies :revision revision :prefixes prefs))) + (parent + (let* ((curies (jtm::get-item :PARENT jtm-decoded-list)) + (parents (jtm::get-items-from-jtm-references + curies :revision revision :prefixes prefs))) + (when parents + (first parents)))) + (reifier + (let ((curie (jtm::get-item :REIFIER jtm-decoded-list))) + (when curie + (jtm::get-item-from-jtm-reference + curie :revision revision :prefixes prefs))))) + (let ((occ-to-delete + (cond (ii + (identified-construct ii :revision revision)) + (reifier + (reified-construct reifier :revision revision)) + (parent + (let ((found-occs + (tools:remove-null + (map 'list (lambda(occ) + (when (d::equivalent-construct + occ :start-revision revision + :charvalue value :themes scope + :instance-of type :datatype datatype) + occ)) + (occurrences parent :revision revision))))) + (when found-occs + (first found-occs)))) + (t + (error "when deleting an occurrence, there must be an item-identifier, reifier or parent set!"))))) + (when occ-to-delete + (delete-occurrence (parent occ-to-delete :revision revision) + occ-to-delete :revision revision) + occ-to-delete)))) + + +(defun delete-name-from-jtm (jtm-decoded-list + &key (revision *TM-REVISION*)) + (declare (list jtm-decoded-list) (integer revision)) + (let* ((prefs (jtm::make-prefix-list-from-jtm-list + (jtm::get-item :PREFIXES jtm-decoded-list))) + (ii + (let ((curies (jtm::get-item :ITEM--IDENTIFIERS jtm-decoded-list))) + (when curies + (jtm::compute-uri-from-jtm-identifier (first curies) prefs)))) + (value (jtm::get-item :VALUE jtm-decoded-list)) + (type + (let ((curie (jtm::get-item :TYPE jtm-decoded-list))) + (if curie + (jtm::get-item-from-jtm-reference curie :revision revision + :prefixes prefs) + (get-item-by-psi constants:*topic-name-psi* + :revision revision :error-if-nil t)))) + (scope + (let ((curies (jtm::get-item :SCOPE jtm-decoded-list))) + (jtm::get-items-from-jtm-references + curies :revision revision :prefixes prefs))) + (parent + (let* ((curies (jtm::get-item :PARENT jtm-decoded-list)) + (parents (jtm::get-items-from-jtm-references + curies :revision revision :prefixes prefs))) + (when parents + (first parents)))) + (reifier + (let ((curie (jtm::get-item :REIFIER jtm-decoded-list))) + (when curie + (jtm::get-item-from-jtm-reference + curie :revision revision :prefixes prefs))))) + (let ((name-to-delete + (cond (ii + (identified-construct ii :revision revision)) + (reifier + (reified-construct reifier :revision revision)) + (parent + (let ((found-names + (tools:remove-null + (map 'list (lambda(name) + (when (d::equivalent-construct + name :start-revision revision + :charvalue value :themes scope + :instance-of type) + name)) + (names parent :revision revision))))) + (when found-names + (first found-names)))) + (t + (error "when deleting a name, there must be an item-identifier, reifier or parent set!"))))) + (when name-to-delete + (delete-name (parent name-to-delete :revision revision) + name-to-delete :revision revision) + name-to-delete)))) + + +(defun delete-identifier-from-json (uri class delete-function + &key (revision *TM-REVISION*)) + "Deleted the passed identifier of the construct it is associated with. + Returns t if there was deleted an item otherweise it returns nil." + (declare (string uri) (integer revision) (symbol class)) + (let ((id (elephant:get-instance-by-value + class 'd:uri uri))) + (if (and id (typep id class)) + (progn + (apply delete-function + (list (d:identified-construct id :revision revision) + id :revision revision)) + id) + nil))) + + +(defun delete-topic-from-jtm (jtm-decoded-list &key (revision *TM-REVISION*)) + "Searches for a topic corresponding to the given identifiers. + Returns t if there was deleted an item otherweise it returns nil." + (declare (list jtm-decoded-list) (integer revision)) + (let* ((prefs + (jtm::make-prefix-list-from-jtm-list + (jtm::get-item :PREFIXES jtm-decoded-list))) + (ids (append + (jtm::get-item :SUBJECT--IDENTIFIERS jtm-decoded-list) + (jtm::get-item :ITEM--IDENTIFIERS jtm-decoded-list) + (jtm::get-item :SUBJECT--LOCATORS jtm-decoded-list))) + (uri (if (null ids) + (error (make-condition 'exceptions::JTM-error :message (format nil "From merge-topic-from-jtm-list(): the passed topic has to own at least one identifier: ~a" jtm-decoded-list))) + (jtm::compute-uri-from-jtm-identifier (first ids) prefs)))) + (let ((top-to-delete (get-item-by-any-id uri :revision revision))) + (when top-to-delete + (mark-as-deleted top-to-delete :source-locator uri :revision revision) + top-to-delete)))) + + +(defun delete-identifier-from-jtm (uri class delete-function + &key (revision *TM-REVISION*)) + "Deleted the passed identifier of the construct it is associated with. + Returns t if there was deleted an item otherweise it returns nil." + (declare (string uri) (integer revision) (symbol class)) + (let ((id (elephant:get-instance-by-value + class 'd:uri uri))) + (when (and id (typep id class)) + (apply delete-function + (list (d:identified-construct id :revision revision) + id :revision revision))))) \ No newline at end of file Modified: trunk/src/json/JTM/jtm_importer.lisp ============================================================================== --- trunk/src/json/JTM/jtm_importer.lisp Mon Sep 26 02:48:59 2011 (r976) +++ trunk/src/json/JTM/jtm_importer.lisp Mon Sep 26 04:56:25 2011 (r977) @@ -29,7 +29,8 @@ (defun import-construct-from-jtm-string (jtm-string &key (revision *TM-REVISION*) - (jtm-format :1.1) tm-id) + (jtm-format :1.1) tm-id + (create-fragments nil)) "Imports the passed jtm-string. Note tm-id needs not to be declared, but if the imported construct is a topicmap and it has no item-identifiers defined, a JTM-error @@ -37,32 +38,52 @@ (declare (String jtm-string) (type (or Null String) tm-id) (Integer revision) - (Keyword jtm-format)) - (let* ((jtm-list (json:decode-json-from-string jtm-string)) - (version (get-item :VERSION jtm-list)) + (Keyword jtm-format) + (Boolean create-fragments)) + (let* ((jtm-list (json:decode-json-from-string jtm-string))) + (import-construct-from-jtm-decoded-list + jtm-list :revision revision :jtm-format jtm-format + :tm-id tm-id :create-fragments create-fragments))) + + +(defun import-construct-from-jtm-decoded-list (jtm-list &key + (revision *TM-REVISION*) + (jtm-format :1.1) tm-id + (create-fragments nil)) + "Imports the passed jtm-decoded-list. + Note tm-id needs not to be declared, but if the imported construct + is a topicmap and it has no item-identifiers defined, a JTM-error + is thrown." + (declare (List jtm-list) + (Integer revision) + (Keyword jtm-format) + (type (or Null String) tm-id) + (Boolean create-fragments)) + (let* ((version (get-item :VERSION jtm-list)) (item_type (get-item :ITEM--TYPE jtm-list)) (prefixes (make-prefix-list-from-jtm-list (get-item :PREFIXES jtm-list))) (format-1.1-p (eql jtm-format :1.1))) (cond ((eql jtm-format :1.0) (unless (string= version "1.0") - (error (make-condition 'exceptions:JTM-error :message (format nil "From import-construct-from-jtm-string(): the member version must be set to \"1.0\" in JTM version 1.0, but is ~a" version)))) + (error (make-condition 'exceptions:JTM-error :message (format nil "From import-construct-from-jtm-decoded-list(): the member version must be set to \"1.0\" in JTM version 1.0, but is ~a" version)))) (when prefixes - (error (make-condition 'exceptions:JTM-error :message (format nil "From import-construct-from-jtm-string(): the member prefixes must not be set when using JTM version 1.0, but found: ~a" prefixes))))) + (error (make-condition 'exceptions:JTM-error :message (format nil "From import-construct-from-jtm-decoded-list(): the member prefixes must not be set when using JTM version 1.0, but found: ~a" prefixes))))) ((eql jtm-format :1.1) (unless (string= version "1.1") - (error (make-condition 'exceptions:JTM-error :message (format nil "From import-construct-from-jtm-string(): the member version must be set to \"1.1\" in JTM version 1.1, but is ~a" version))))) + (error (make-condition 'exceptions:JTM-error :message (format nil "From import-construct-from-jtm-decoded-list(): the member version must be set to \"1.1\" in JTM version 1.1, but is ~a" version))))) (t - (error (make-condition 'exceptions:JTM-error :message (format nil "From import-construct-from-jtm-string(): only JTM format \"1.0\" and \"1.1\" is supported, but found: \"~a\"" jtm-format))))) + (error (make-condition 'exceptions:JTM-error :message (format nil "From import-construct-from-jtm-decoded-list(): only JTM format \"1.0\" and \"1.1\" is supported, but found: \"~a\"" jtm-format))))) (cond ((or (not item_type) (string= item_type item_type-topicmap)) (import-topic-map-from-jtm-list jtm-list tm-id :revision revision :prefixes prefixes - :instance-of-p format-1.1-p)) + :instance-of-p format-1.1-p :create-fragments create-fragments)) ((string= item_type item_type-topic) (import-topic-stub-from-jtm-list jtm-list nil :revision revision :prefixes prefixes) - (merge-topic-from-jtm-list jtm-list nil :instance-of-p format-1.1-p - :revision revision :prefixes prefixes)) + (merge-topic-from-jtm-list jtm-list :instance-of-p format-1.1-p + :revision revision :prefixes prefixes + :create-fragment create-fragments)) ((string= item_type item_type-name) (import-name-from-jtm-list jtm-list nil :revision revision :prefixes prefixes)) @@ -79,7 +100,7 @@ (import-association-from-jtm-list jtm-list nil :revision revision :prefixes prefixes)) (t - (error (make-condition 'exceptions:JTM-error :message (format nil "From import-construct-from-jtm-string(): the member \"item_type\" must be set to one of ~a or nil, but found \"~a\". If \"item_type\" is not specified or nil the JTM-data is treated as a topicmap." item_type (list item_type-topicmap item_type-topic item_type-name item_type-variant item_type-occurrence item_type-role item_type-association)))))))) + (error (make-condition 'exceptions:JTM-error :message (format nil "From import-construct-from-jtm-decoded-list(): the member \"item_type\" must be set to one of ~a or nil, but found \"~a\". If \"item_type\" is not specified or nil the JTM-data is treated as a topicmap." item_type (list item_type-topicmap item_type-topic item_type-name item_type-variant item_type-occurrence item_type-role item_type-association)))))))) (defun import-from-jtm (jtm-path repository-path &key (tm-id (error "you must provide a stable identifier (PSI-style) for this TM")) (revision *TM-REVISION*) (jtm-format :1.1)) @@ -96,13 +117,14 @@ (defun import-topic-map-from-jtm-list (jtm-list tm-id &key (revision *TM-REVISION*) - prefixes (instance-of-p t)) + prefixes (instance-of-p t) + (create-fragments nil)) "Creates and returns a topic map corresponding to the tm-id or a given item-identifier in the jtm-list and returns the tm construct after all topics and associations contained in the jtm-list has been created." (declare (List jtm-list prefixes) (Integer revision) - (Boolean instance-of-p)) + (Boolean instance-of-p create-fragments)) (let* ((iis (let ((value (append (import-identifiers-from-jtm-strings (get-item :ITEM--IDENTIFIERS jtm-list) :prefixes prefixes) @@ -119,8 +141,9 @@ :item-identifiers iis))) (import-topic-stubs-from-jtm-lists j-tops (list tm) :revision revision :prefixes prefixes) - (merge-topics-from-jtm-lists j-tops (list tm) :instance-of-p instance-of-p - :revision revision :prefixes prefixes) + (merge-topics-from-jtm-lists j-tops :instance-of-p instance-of-p + :revision revision :prefixes prefixes + :create-fragments create-fragments) (import-associations-from-jtm-lists j-assocs (list tm) :revision revision :prefixes prefixes) tm)) @@ -324,30 +347,34 @@ assoc))) -(defun merge-topics-from-jtm-lists (jtm-lists parents &key (instance-of-p t) - (revision *TM-REVISION*) prefixes) +(defun merge-topics-from-jtm-lists (jtm-lists &key (instance-of-p t) + (revision *TM-REVISION*) prefixes + (create-fragments nil)) "Creates and returns a list of topics." - (declare (List jtm-lists parents prefixes) - (Boolean instance-of-p) + (declare (List jtm-lists prefixes) + (Boolean instance-of-p create-fragments) (Integer revision)) (map 'list #'(lambda(jtm-list) (merge-topic-from-jtm-list - jtm-list parents :revision revision :prefixes prefixes - :instance-of-p instance-of-p)) + jtm-list :revision revision :prefixes prefixes + :instance-of-p instance-of-p + :create-fragment create-fragments)) jtm-lists)) -(defun merge-topic-from-jtm-list(jtm-list parents &key (instance-of-p t) - (revision *TM-REVISION*) prefixes) +(defun merge-topic-from-jtm-list(jtm-list &key (instance-of-p t) + (revision *TM-REVISION*) prefixes + (create-fragment nil)) "Creates and returns a topic object from the passed jtm list generated by json:decode-json-from-string. Note that the merged topics are not added explicitly to the parent topic maps, it is only needed for the instance-of-associations - topics are added in the function import-topic-stubs-from-jtm-lists to their topic map elements." - (declare (List jtm-list prefixes parents) + (declare (List jtm-list prefixes) (Boolean instance-of-p) - (Integer revision)) + (Integer revision) + (Boolean create-fragment)) (let* ((ids (append (get-item :ITEM--IDENTIFIERS jtm-list) (get-item :SUBJECT--IDENTIFIERS jtm-list) (get-item :SUBJECT--LOCATORS jtm-list))) @@ -373,11 +400,29 @@ (when (and (not instance-of-p) instanceof) (error (make-condition 'JTM-error :message (format nil "From merge-topic-from-jtm-list(): the JTM-topic has an instance_of member set, but JTM version 1.0 does not allow an intance_of member within a topic object: ~a" jtm-list)))) (dolist (type-top instanceof) - (make-instance-of-association top type-top parents :revision revision)) + (make-instance-of-association + top type-top (in-topicmaps top :revision revision) + :revision revision)) (dolist (name top-names) (add-name top name :revision revision)) (dolist (occ top-occs) (add-occurrence top occ :revision revision)) + (when create-fragment + (let ((all-assocs + (remove-null (map 'list (lambda(role) + (parent role :revision revision)) + (player-in-roles top :revision revision))))) + (let ((all-tops + (remove-null + (loop for assoc in all-assocs + append (map 'list (lambda(role) + (d:player role :revision revision)) + (roles assoc :revision revision)))))) + (map nil (lambda(top) + (map nil #'elephant:drop-instance + (elephant:get-instances-by-value 'FragmentC 'topic top)) + (create-latest-fragment-of-topic top)) + (append all-tops (list top)))))) (format t "t") top)) @@ -438,7 +483,15 @@ (let* ((iis (import-identifiers-from-jtm-strings (get-item :ITEM--IDENTIFIERS jtm-list) :prefixes prefixes)) - (datatype (get-item :DATATYPE jtm-list)) + (datatype + (let ((curie (jtm::get-item :DATATYPE jtm-list))) + (cond ((null curie) + constants:*xml-string*) + ((and (tools:string-starts-with curie "[") + (tools:string-ends-with curie "]")) + (jtm::compute-uri-from-jtm-identifier curie prefixes)) + (t + curie)))) (scope (get-item :SCOPE jtm-list)) (type (get-item :TYPE jtm-list)) (value (get-item :VALUE jtm-list)) @@ -456,7 +509,7 @@ (error (make-condition 'JTM-error :message (format nil "From import-occurrence-from-jtm-list(): the JTM occurrence ~a must have a type set in its members." jtm-list)))) (make-construct 'OccurrenceC :start-revision revision :item-identifiers iis - :datatype (if datatype datatype *xml-string*) + :datatype datatype :charvalue value :themes (get-items-from-jtm-references scope :revision revision :prefixes prefixes) @@ -491,7 +544,15 @@ (let* ((iis (import-identifiers-from-jtm-strings (get-item :ITEM--IDENTIFIERS jtm-list) :prefixes prefixes)) - (datatype (get-item :DATATYPE jtm-list)) + (datatype + (let ((curie (jtm::get-item :DATATYPE jtm-list))) + (cond ((null curie) + constants:*xml-string*) + ((and (tools:string-starts-with curie "[") + (tools:string-ends-with curie "]")) + (jtm::compute-uri-from-jtm-identifier curie prefixes)) + (t + curie)))) (value (get-item :VALUE jtm-list)) (reifier (get-item :REIFIER jtm-list)) (parent-references (get-item :PARENT jtm-list)) Modified: trunk/src/json/JTM/jtm_tools.lisp ============================================================================== --- trunk/src/json/JTM/jtm_tools.lisp Mon Sep 26 02:48:59 2011 (r976) +++ trunk/src/json/JTM/jtm_tools.lisp Mon Sep 26 04:56:25 2011 (r977) @@ -11,6 +11,7 @@ (:use :cl :json :datamodel :base-tools :isidorus-threading :constants :exceptions) (:export :import-from-jtm + :import-construct-from-jtm-decoded-list :import-construct-from-jtm-string :export-as-jtm :export-as-jtm-string Modified: trunk/src/model/changes.lisp ============================================================================== --- trunk/src/model/changes.lisp Mon Sep 26 02:48:59 2011 (r976) +++ trunk/src/model/changes.lisp Mon Sep 26 04:56:25 2011 (r977) @@ -422,7 +422,7 @@ (defun create-latest-fragment-of-topic (topic-or-psi) "Returns the latest fragment of the passed topic-psi" - (declare (type (or TopicC String) topic-or-psi)) + (declare (type (or String TopicC) topic-or-psi)) (let ((topic (if (stringp topic-or-psi) (get-latest-topic-by-psi topic-or-psi) topic-or-psi))) Modified: trunk/src/rest_interface/rest-interface.lisp ============================================================================== --- trunk/src/rest_interface/rest-interface.lisp Mon Sep 26 02:48:59 2011 (r976) +++ trunk/src/rest_interface/rest-interface.lisp Mon Sep 26 04:56:25 2011 (r977) @@ -32,6 +32,7 @@ :start-json-engine :start-atom-engine :start-admin-server + :start-gdl-engine :shutdown-json-engine :shutdown-atom-engine :*admin-local-backup* @@ -43,6 +44,8 @@ :*remote-backup-remote-address* :*local-backup-remote-address* :*shutdown-remote-address* + :set-up-json-interface + :set-up-gdl-interface :*json-get-prefix* :*get-rdf-prefix* :*json-commit-url* @@ -61,9 +64,19 @@ :*xtm-commit-prefix* :*ready-to-die* :die-when-finished - :*sparql-url* :*use-http-authentication* - :*users*)) + :*users* + :*sparql-url* + :*gdl-get-fragment* + :*gdl-get-schema* + :*gdl-commit-fragment* + :*gdl-delete-fragment* + :*gdl-host-address-hash-object* + :*gdl-host-address-environment* + :*gdl-base-path* + :*gdl-host-file* + :*gdl-tm-id* + :*gdl-sparql*)) (in-package :rest-interface) @@ -84,6 +97,7 @@ (defvar *json-server-acceptor* nil) +(defvar *gdl-server-acceptor* nil) (defvar *atom-server-acceptor* nil) (defvar *admin-server-acceptor* nil) (defvar *admin-host-name* "127.0.0.1") @@ -115,6 +129,25 @@ (setf *admin-server-acceptor* nil)) +(defun start-gdl-engine (repository-path &key + (host-name "localhost") (port 8018)) + "Starts the Topic Maps engine with a given port and address, + so the engine can serve and consume gdl-fragments for the + gdl-frontend anaToMia." + (when *gdl-server-acceptor* + (error "The gdl-server is already running")) + (setf hunchentoot:*show-lisp-errors-p* t) ;for now + (setf hunchentoot:*hunchentoot-default-external-format* + (flex:make-external-format :utf-8 :eol-style :lf)) + (open-tm-store repository-path) + (set-up-gdl-interface) + (setf *gdl-server-acceptor* + (make-instance 'hunchentoot:acceptor :address host-name :port port)) + (setf hunchentoot:*lisp-errors-log-level* :info) + (setf hunchentoot:*message-log-pathname* "./gdl-hunchentoot-errors.log") + (hunchentoot:start *gdl-server-acceptor*)) + + (defun start-json-engine (repository-path &key (host-name "localhost") (port 8000)) "Start the Topic Maps Engine on a given port, assuming a given Copied: trunk/src/rest_interface/set-up-gdl-interface.lisp (from r976, branches/gdl-frontend/src/rest_interface/set-up-gdl-interface.lisp) ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/src/rest_interface/set-up-gdl-interface.lisp Mon Sep 26 04:56:25 2011 (r977, copy of r976, branches/gdl-frontend/src/rest_interface/set-up-gdl-interface.lisp) @@ -0,0 +1,250 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff +;;+ +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + +(in-package :rest-interface) + +(defparameter *gdl-get-fragment* "/gdl/fragment/(.+)$") +(defparameter *gdl-get-schema* "/gdl/schema/?$") +(defparameter *gdl-commit-fragment* "/gdl/commit/?") +(defparameter *gdl-delete-fragment* "/gdl/delete/?") +(defparameter *gdl-host-address-hash-object* "/hash-object") +(defparameter *gdl-host-address-environment* "/environment") +(defparameter *gdl-base-path* "anaToMia/hosted_files/") +(defparameter *gdl-host-file* (concat *gdl-base-path* "GDL_Widgets.html")) +(defparameter *gdl-tm-id* "http://textgrid.org/serviceregistry/gdl-frontend/gdl-tm") +(defparameter *gdl-sparql* "/gdl/tm-sparql/?$") + + +(defun set-up-gdl-interface (&key (get-fragment *gdl-get-fragment*) + (get-schema *gdl-get-schema*) + (commit-fragment *gdl-commit-fragment*) + (delete-fragment *gdl-delete-fragment*) + (gdl-sparql *gdl-sparql*) + (base-path *gdl-base-path*) + (host-address-hash-object *gdl-host-address-hash-object*) + (host-address-environment *gdl-host-address-environment*) + (host-file *gdl-host-file*)) + (declare (String get-fragment get-schema commit-fragment + delete-fragment host-address-hash-object + host-address-environment host-file)) + + ;(init-cache nil) + ;(format t "~%") + (init-fragments nil) + + ;; registers the http-code 500 for an internal server error to the standard + ;; return codes. so there won't be attached a hunchentoot default message, + ;; this is necessary to be able to send error messages in an individual way/syntax + ;; e.g. a json error-message. + (push hunchentoot:+http-internal-server-error+ hunchentoot:*approved-return-codes*) + + (init-hosted-files :host-address-hash-object host-address-hash-object + :host-address-environment host-address-environment + :host-file host-file :base-path base-path) + + (push + (create-regex-dispatcher get-fragment #'return-json-fragment-handler) + hunchentoot:*dispatch-table*) + + (push + (create-regex-dispatcher get-schema #'return-gdl-schema-handler) + hunchentoot:*dispatch-table*) + + (push + (create-regex-dispatcher commit-fragment #'commit-fragment-handler) + hunchentoot:*dispatch-table*) + + (push + (create-regex-dispatcher delete-fragment #'delete-handler) + hunchentoot:*dispatch-table*) + + (push + (create-regex-dispatcher gdl-sparql #'gdl-sparql-handler) + hunchentoot:*dispatch-table*)) + + +(defun init-hosted-files (&key (host-address-hash-object *gdl-host-address-hash-object*) + (host-address-environment *gdl-host-address-environment*) + (host-file *gdl-host-file*) + (base-path *gdl-base-path*)) + "Adds handlers for the css, html and js files needed by the frontend." + (declare (String host-address-hash-object host-address-environment + host-file base-path)) + ;; add the actual html file + (let ((full-host-path + (concat (namestring + (asdf:component-pathname constants:*isidorus-system*)) + host-file)) + (absolute-base-path + (concat + (namestring + (asdf:component-pathname constants:*isidorus-system*)) + base-path))) + (push + (create-static-file-dispatcher-and-handler + host-address-hash-object full-host-path "text/html") + hunchentoot:*dispatch-table*) + (push + (create-static-file-dispatcher-and-handler + host-address-environment full-host-path "text/html") + hunchentoot:*dispatch-table*) + ; add all additional files + (let ((absolute-base-path-len (length absolute-base-path))) + (com.gigamonkeys.pathnames:walk-directory + "anaToMia/hosted_files" + (lambda(item) + (unless (or (search "/.svn/" (namestring item) :test #'string=) + (string= full-host-path (namestring item))) + (let* ((rel-addr (subseq (namestring item) absolute-base-path-len)) + (content-type (generate-content-type (file-namestring item))) + (rel-uri (concat "/" rel-addr))) + (push + (create-static-file-dispatcher-and-handler + rel-uri item content-type) + hunchentoot:*dispatch-table*)))))))) + + +(defun generate-content-type(file-name) + "Returns a mime-type that corresponds to the passed + file-ending, note currently onle a fey types are supported!" + (declare (String file-name)) + (cond ((string-ends-with file-name "png" :ignore-case t) + "image/png") + ((string-ends-with file-name "html" :ignore-case t) + "text/html") + ((string-ends-with file-name "js" :ignore-case t) + "application/json") + ((string-ends-with file-name "css" :ignore-case t) + "text/css") + ((string-ends-with file-name "gif" :ignore-case t) + "image/gif") + (t + "text/plain"))) + + +(defun delete-handler() + "marks the corresponding construct(s) as deleted" + (let ((http-method (hunchentoot:request-method*))) + (if (or (eq http-method :DELETE) + (eq http-method :POST)) + (let ((external-format + (flexi-streams:make-external-format :UTF-8 :eol-style :LF))) + (let ((json-data + (hunchentoot:raw-post-data :external-format external-format + :force-text t))) + (with-writer-lock + (let* ((rev (d:get-revision)) + (result (jtm-delete-interface:mark-as-deleted-from-jtm + json-data :revision rev))) + (let ((tops + (remove-null + (cond ((or (typep result 'OccurrenceC) + (typep result 'NameC)) + (let ((top (parent result :revision (1- rev)))) + (when top (list top)))) + ((typep result 'VariantC) + (let ((name (parent result :revision (1- rev)))) + (when name + (let ((top (parent name :revision (1- rev)))) + (when top (list top)))))) + ((typep result 'AssociationC) + (map 'list (lambda(role) + (player role :revision (1- rev))) + (roles result :revision (1- rev)))) + ((typep result 'TopicC) + (let ((assocs + (remove-null + (map 'list (lambda(role) + (parent role :revision (1- rev))) + (player-in-roles result :revision (1- rev))))) + (frags + (elephant:get-instances-by-value + 'd:FragmentC 'd:topic result))) + (map nil #'elephant:drop-instance frags) + (loop for assoc in assocs + append (map 'list (lambda(role) + (player role :revision (1- rev))) + (roles assoc :revision (1- rev)))))))))) + (map nil (lambda(top) + (let ((frags + (elephant:get-instances-by-value 'd:FragmentC 'd:topic top))) + (map nil #'elephant:drop-instance frags)) + (create-latest-fragment-of-topic top)) + (if (typep result 'd:TopicC) + (delete result tops) + tops))) + (unless result + (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+) + (format nil "object not found")))))) + (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)))) + + +(defun commit-fragment-handler () + "handles commits in the JTM 1.1 format." + (let ((http-method (hunchentoot:request-method*))) + (if (or (eq http-method :PUT) + (eq http-method :POST)) + (let ((external-format + (flexi-streams:make-external-format :UTF-8 :eol-style :LF))) + (let ((json-data + (hunchentoot:raw-post-data :external-format external-format + :force-text t))) + (with-writer-lock + (jtm-importer:import-construct-from-jtm-string + json-data :revision (get-revision) :tm-id *gdl-tm-id* + :create-fragments t)))) + (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)))) + + +(defun return-gdl-schema-handler() + "Currently the entore topic map is returned. + To emerge the efficiency it will be necessary + to structure the data as GDL-Fragments, so each view or schema + can be served separately." + (let ((http-method (hunchentoot:request-method*))) + (if (eq http-method :GET) + (progn (setf (hunchentoot:content-type*) "application/json") + (jtm-exporter:export-as-jtm-string :revision 0)) + (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)))) + + +(defun return-json-fragment-handler(&optional psi) + "returns the json-fragmen belonging to the psi passed by the parameter psi" + (assert psi) + (let ((http-method (hunchentoot:request-method*))) + (if (eq http-method :GET) + (let ((identifier (hunchentoot:url-decode psi))) + (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 + (let ((fragment + (with-reader-lock + (get-latest-fragment-of-topic identifier)))) + (if fragment + (with-reader-lock + (jtm-exporter:export-construct-as-jtm-string + fragment :revision 0)) + (progn + (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+) + (setf (hunchentoot:content-type*) "text") + (format nil "Topic \"~a\" not found" psi))))) + (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)))) + + +(defun gdl-sparql-handler(&optional param) + "Returns a JSON object representing a SPARQL response." + (declare (Ignorable param)) + (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))) + (export-construct-as-isidorus-json-string + (make-instance 'SPARQL-Query :query sparql-request + :revision 0)))) + (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+))) \ No newline at end of file Modified: trunk/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- trunk/src/rest_interface/set-up-json-interface.lisp Mon Sep 26 02:48:59 2011 (r976) +++ trunk/src/rest_interface/set-up-json-interface.lisp Mon Sep 26 04:56:25 2011 (r977) @@ -35,6 +35,12 @@ is required.") +(defparameter *cache-initialised* nil "determines wheter the cache has been + already set or not") + +(defparameter *fragments-initialised* nil "determines wheter the fragments has + been already initialised or not.") + ;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> @@ -108,9 +114,9 @@ and also registers a file-hanlder to the html-user-interface" ;initializes cache and fragments - (init-cache) + (init-cache nil) (format t "~%") - (init-fragments) + (init-fragments nil) ;; registers the http-code 500 for an internal server error to the standard ;; return codes. so there won't be attached a hunchentoot default message, @@ -148,8 +154,7 @@ (script-url (getf (elt files-and-urls idx) :url))) (push (create-static-file-dispatcher-and-handler script-url script-path) - hunchentoot:*dispatch-table*)))) - + hunchentoot:*dispatch-table*)))) ;; === rest interface ======================================================== (push @@ -700,7 +705,6 @@ (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)))) - (defun update-fragments-after-delete(deleted-topic delete-revision) "Updates all fragments of topics that directly and indireclty related to the delete-topic." @@ -844,7 +848,7 @@ files-and-urls))) -(defun init-cache() +(defun init-cache(force-init) "Initializes the type and instance cache-tables with all valid types/instances" (with-writer-lock (setf *type-table* nil) @@ -880,15 +884,15 @@ (handler-case (progn (json-tmcl::topictype-p topic-instance topictype topictype-constraint nil 0) - (push (elephant::oid topic-instance) *type-table*)) + (pushnew (elephant::oid topic-instance) *type-table*)) (condition () nil))) (handler-case (progn (json-tmcl::valid-instance-p topic-instance nil nil 0) - (push (elephant::oid topic-instance) *instance-table*)) + (pushnew (elephant::oid topic-instance) *instance-table*)) (condition () nil))) -(defun init-fragments () +(defun init-fragments (force-init) "Creates fragments of all topics that have a PSI." (format t "creating fragments: ") (map Modified: trunk/src/xml/xtm/exporter.lisp ============================================================================== --- trunk/src/xml/xtm/exporter.lisp Mon Sep 26 02:48:59 2011 (r976) +++ trunk/src/xml/xtm/exporter.lisp Mon Sep 26 04:56:25 2011 (r977) @@ -16,41 +16,33 @@ (let ((instance-topic (get-item-by-psi *instance-psi* :revision 0)) (type-topic - (get-item-by-psi *type-psi* :revision 0))) - (cond ((and (not (and instance-topic type-topic)) - (elephant:get-instances-by-class 'TopicMapC)) - (error (make-condition - 'missing-reference-error - :message - (format nil "Could not resolvethe topics: ~a and ~a~%" - *instance-psi* *type-psi*)))) - ((not (and instance-topic type-topic)) - nil) - (t - (loop for item in (d:get-all-associations revision) - when (or (/= (length (roles item :revision revision)) 2) - (and - (= (length (roles item :revision revision)) 2) - (not - (and - (or - (eq instance-topic - (instance-of (first (roles item - :revision revision)) - :revision revision)) - (eq instance-topic - (instance-of (second (roles item - :revision revision)) - :revision revision))) - (or (eq type-topic - (instance-of (first (roles item - :revision revision)) - :revision revision)) - (eq type-topic - (instance-of (second (roles item - :revision revision)) - :revision revision))))))) - collect item))))) + (identified-construct + (elephant:get-instance-by-value 'PersistentIdC 'uri *type-psi*)))) + (loop for item in (d:get-all-associations revision) + when (let ((assoc-roles (length (roles item :revision revision)))) + (or (/= assoc-roles 2) + (and (= assoc-roles 2) + (not (and (or (eq instance-topic + (instance-of + (first (roles item + :revision revision)) + :revision revision)) + (eq instance-topic + (instance-of + (second (roles item + :revision revision)) + :revision revision))) + (or (eq type-topic + (instance-of + (first (roles item + :revision revision)) + :revision revision)) + (eq type-topic + (instance-of + (second (roles item + :revision revision)) + :revision revision)))))))) + collect item))) (defmacro with-xtm2.0 ((tm revision) &body body) @@ -91,10 +83,11 @@ (if ,tm (union (filter-type-instance-topics (d:topics ,tm) tm :revision revision) - (d:associations ,tm)) + (list-extern-associations :revision revision)) (union (elephant:get-instances-by-class 'd:TopicC) - (list-extern-associations :revision revision))))))) + (d:associations ,tm))))))) + (defun export-as-xtm (xtm-path &key