Revision: 3562 Author: ksprotte URL: http://bknr.net/trac/changeset/3562

added kml-upload facility - no handler yetz U trunk/projects/bos/web/kml-handlers.lisp U trunk/projects/bos/web/webserver.lisp

Modified: trunk/projects/bos/web/kml-handlers.lisp =================================================================== --- trunk/projects/bos/web/kml-handlers.lisp 2008-07-22 16:37:36 UTC (rev 3561) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-07-22 16:37:55 UTC (rev 3562) @@ -1,6 +1,64 @@ ;;; -*- coding: utf-8 -*- (in-package :bos.web)

+(defpersistent-class kml-root-data () + ((language :initarg :language :reader language :type string + :index-type string-unique-index + :index-reader kml-root-data-with-language) + (kml-string :accessor kml-string))) + +(defun ensure-kml-root-data-for-language (language) + (or (kml-root-data-with-language language) + (make-object 'kml-root-data :language language))) + +(defun kml-root-data-validate-file-upload (file-upload) + (cxml:parse-file (upload-pathname file-upload) + (cxml-dom:make-dom-builder))) + +(defclass kml-upload-handler (admin-only-handler form-handler) + ()) + +(defmethod handle-form ((handler kml-upload-handler) action) + (dolist (language (class-instances 'website-language)) + (ensure-kml-root-data-for-language (website-language-code language))) + (labels ((xml-parse-error-context (xml-parse-error) + (ppcre:register-groups-bind (line column) + ("Line +(\d+).*column +(\d+)" + (princ-to-string xml-parse-error)) + (when (and line column) + (values (parse-integer line) (parse-integer column)))))) + (with-bos-cms-page (:title "KML Upload") + (html ((:form + :method "POST" :enctype "multipart/form-data") + (dolist (kml-root-data (class-instances 'kml-root-data)) + (let ((language (language kml-root-data))) + (html (:h2 (:princ language)) + (:p ((:input :type "file" :name language)) + " " + (let ((file-upload (request-uploaded-file language))) + (when file-upload + (handler-case + (progn + (kml-root-data-validate-file-upload file-upload) + (with-transaction ("update kml-string") + (setf (kml-string kml-root-data) + (arnesi:read-string-from-file (upload-pathname file-upload) + :external-format :utf-8))) + (html (:princ "updated successfully"))) + (cxml:xml-parse-error (c) + (multiple-value-bind (line column) + (xml-parse-error-context c) + (print (list line column)) + (html ((:span :class "error") + (:format "there was a xml parse error ~:[~;near line ~D, column ~D~]" + (and line column) + line column))))))))) + ;; we want this after the processing + (:p (:format "last-change: ~A" + (format-date-time (store-object-last-change kml-root-data 0))))))) + (submit-button "upload" "upload")))))) + +;;; kml-format utils (defun kml-format-points (points stream) (mapc #'(lambda (point) (kml-format-point point stream)) points))

Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-07-22 16:37:36 UTC (rev 3561) +++ trunk/projects/bos/web/webserver.lisp 2008-07-22 16:37:55 UTC (rev 3562) @@ -199,6 +199,7 @@ :handler-definitions `(("/edit-poi" edit-poi-handler) ("/edit-poi-image" edit-poi-image-handler) ("/edit-sponsor" edit-sponsor-handler) + ("/kml-upload" kml-upload-handler) ("/kml-root" kml-root-handler) ("/country-stats" country-stats-handler) ("/contract-tree-kml" contract-tree-kml-handler) @@ -255,7 +256,8 @@ :admin-navigation '(("user" . "user/") ("languages" . "languages") ("allocation area" . "allocation-area/") - ("allocation cache" . "allocation-cache")) + ("allocation cache" . "allocation-cache") + ("kml-upload" . "kml-upload")) :authorizer (make-instance 'bos-authorizer) :site-logo-url "/images/bos-logo.gif" :style-sheet-urls '("/static/cms.css")