;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: XLE; Base: 10; Readtable: augmented-readtable -*-

(in-package :XLE)

#+allegro
(defmacro set-xle-performance-vars-from-request-query (request-query grammar)
  (with-gensyms (alist pair param-string val-string fun parser)
    `(let ((,alist (list ,@(collecting
			    (dolist (parameter +parameter-list+)
			      (collect `',parameter)
			      (collect
			       `(lambda (val)
				  (setf ,parameter val)
				  ;; set parameters of all charts
				  (when ,grammar
				    (dolist (,parser (parsers ,grammar))
				      (setf (ff:fslot-value-typed 'Chart nil (parser-address ,parser) ',parameter)
					val))))))))))
       (dolist (,pair ,request-query)
	 (print ,pair)
	 (destructuring-bind (,param-string . ,val-string) ,pair
	   (when-let (,fun (getf ,alist (intern (string-upcase ,param-string) :xle)))
		     (funcall ,fun (parse-integer ,val-string))))))))

#+allegro
(defmethod xle-admin-xml ((request http-request) entity)
  (with-xml-response (request entity stream (grammar base-name update unload-grammar
						     update-param reparse-on-timeout-topcat)
			      :xsl #'xle-admin-xsl
			      :force-xslt :sablotron)
    #-debug(print (request-query request))
    (let* ((*grammar* (find-grammar (utf-8-decode grammar)))
	   (grammar (name *grammar*)))
      #-debug(print (list :grammar *grammar* :default *default-grammar*))
      (when unload-grammar (unload-grammar *grammar*))
      (when update (mp:process-run-function "update-and-reload-grammar" #'update-and-reload-grammar))
      (ignore-errors
	(when reparse-on-timeout-topcat
	  (setf (reparse-on-timeout-topcat *grammar*)
		(unless (equal reparse-on-timeout-topcat "-")
		  reparse-on-timeout-topcat)))
	(when update-param
	  (set-xle-performance-vars-from-request-query (request-query request) *grammar*)
	  ;; Write parameters to file (reparse-on-timeout-topcat still missing!)
	  (with-open-file (stream (concat *pargram-path* "/norwegian/bokmal/performance-vars.txt")
				  :direction :output :if-exists :supersede)
	    (write-xle-performance-vars-to-stream stream))))
      #m(?xml-stylesheet :type "text/xsl" :href #s (concat "/" *url-base* "/xle-admin.xsl"))
      #m((grammar :name #s grammar
		  :user #s(get-basic-authorization request)
		  :owner #s(owner *grammar*)
		  :reparse-on-timeout-topcat #s(when (equal grammar *default-grammar*)
						 (reparse-on-timeout-topcat *grammar*)))
	 (grammars
	  #L(maphash (lambda (grammar obj)
		       #m((gram :name #s grammar :owner #s(owner obj))))
		     *grammars*))
	 ;;#L(print (list grammar *default-grammar* +parameter-list+))
	 #L(when (equal grammar *default-grammar*)
	     (macrolet ((write-parameters-xml (stream)
			  `(let ((stream ,stream))
			    ,@(collecting
			       (dolist (param +parameter-list+)
				 ;;(print (list :param param))
				 (collect `#m((parameter :name #S(string-downcase ',param)) #S ,param)))))))
	       #m(parameters
		  #L(write-parameters-xml stream))))))))

#+allegro
(defstylesheet xle-admin-xsl ()
  #m((xsl:stylesheet xmlns:xsl "http://www.w3.org/1999/XSL/Transform" :version "1.0")
     ((xsl:template :match "/")
      (html
       ((head)
	(title "XLE Administration")
	((style :type "text/css")
	 (CSS-STYLE
	  (body :font-family "Verdana, Tahoma, MS Sans Serif, Arial, Geneva, Helvetica")
	  (div :margin "16"
	       :color "#004499"
	       :font-family "Verdana, Tahoma, MS Sans Serif, Arial, Geneva, Helvetica")
	  (div.title :font-size "24" :font-weight "bold" :text-align "center")
	  (td.title :font-weight "bold" :color "#004499" :text-align "center")
	  (td.attribute :font-size "14")
	  (span.label :font-weight "bold")
	  (a :text-decoration "none" :color "black"))))
       ((body)
	((div :class "title") "XLE Administration")
	((form :method #+mcl "get" #-mcl "post" :id "searchForm")
	 ((div :class "text") ;;(p :style "color: black")
	  "Grammar: "
	  ((xsl:element :name "select")
	   ((xsl:attribute :name "name") "grammar")
	   ((xsl:attribute :name "onchange") "form.submit()")
	   (xsl:apply-templates/ :select "/grammar/grammars/gram"))
	  ((xsl:if :test "/grammar/@owner")
	   " Owner: " (xsl:value-of/ :select "/grammar/@owner"))
	  " | "
	  (input/ :style "font-size: 8pt"
		  :type "submit" :name "unload-grammar" :value "Reload"))
	 #+ignore
	 (div  "Update XLE grammar from remote repository: "
	       (input/ :type "submit" :name "update" :value "Update grammar"))
	 (div "Update XLE parameters:")
	 (table
	  (tr ((td :class "title") "Parameter") ((td :class "title") "Value"))
	  (xsl:apply-templates/ :select "grammar/parameters")
	  (tr ((td :class "attribute") "root-cat on timeout reparse")
	      ((td :class "value")
	       #+ignore
	       ((xsl:element :name "input")
		((xsl:attribute :name "value") "choice"))
	       ((xsl:element :name "select")
		((xsl:attribute :name "name") "reparse-on-timeout-topcat")
		#L(dolist (cat '("-" "REPARSECAT"))
		    #m((xsl:element :name "option")
		       ((xsl:attribute :name "value") #S cat)
		       ((xsl:if :test #L(concat "grammar/@reparse-on-timeout-topcat='" cat "'"))
			((xsl:attribute :name "selected") "true"))
		       #S cat))))))
	 (div (input/ :type "submit" :name "update-param" :value "Update parameters"))))))
     
     ((xsl:template :match "gram")
      ((xsl:if :test "not(@owner) or @owner = /grammar/@user")
       ((xsl:element :name "option")
	((xsl:attribute :name "value") (xsl:value-of/ :select "@name"))
	((xsl:if :test "@name=/grammar/@name")
	 ((xsl:attribute :name "selected") "true"))
	(xsl:value-of/ :select "@name"))))

     ((xsl:template :match "parameter")
       (tr
       ((td :class "attribute") (xsl:value-of/ :select "@name"))
       ((td :class "value")
	((xsl:element :name "input")
	 ((xsl:attribute :name "type") "text")
	 ((xsl:attribute :name "name") (xsl:value-of/ :select "@name"))
	 ((xsl:attribute :name "value") (xsl:value-of/ :select "text()"))))))))

;; those are read in from environment variables
;; XLE_WEB_EMAIL_SFX
(defparameter *email-suffixes* ())

(defparameter *site-administrators* ())

;; XLE_WEB_POSTMASTER
(defparameter *postmaster* nil)

;; XLE_WEB_SMTP
(defparameter *smtp-server* nil)

;; XLE_WEB_AUTHORIZATIONS
(defparameter *authorizations-file* nil)

;; XLE_WEB_SUPER_USERS ;; those that have access to all grammars
(defparameter *super-users* nil)

(defun load-authorizations-file (file)
  (setf (net.aserve::password-authorizer-allowed *grammar-authorizer*) ())
  (with-file-lines (line #+sbcl(translate-logical-pathname file) #-sbcl file)
    (let ((line (string-trim '(#\tab #\space) line)))
      (unless (or (zerop (length line))
		  (char= (char line 0) #\#)) ;; comment
	(destructuring-bind (user password) (split line #\tab)
	  (push (cons user password) (net.aserve::password-authorizer-allowed *grammar-authorizer*)))))))

(defun write-authorizations-file (file)
  (with-open-file (stream file :direction :output :if-exists :supersede)
    (dolist (user.password (net.aserve::password-authorizer-allowed *grammar-authorizer*))
      (destructuring-bind (user . password) user.password
	(format stream "~a~c~a~%" user #\Tab password)))))

(defun generate-and-register-password (user email)
  (let ((password (cdr (find user (net.aserve::password-authorizer-allowed *grammar-authorizer*)
			     :key #'car :test #'string-equal))))
    (if password
	(values password t)
	(let* ((pw-chars "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz123456789")
	       ;;(*random-state* (make-random-state))
	       (password (make-string (+ 6 (random 2)))))
	  ;;(print (list :password-string password :state *random-state*))
	  (dotimes (i (length password))
	    (setf (char password i)
		  (aref pw-chars (mod (+ (random (length pw-chars))
					 (reduce #'+ email :key #'char-code))
				      (length pw-chars)))))
	  ;;(Print (list :password password :state *random-state*))
	  (push (cons user password) (net.aserve::password-authorizer-allowed *grammar-authorizer*))
	  (write-authorizations-file *authorizations-file*)
	  password))))

#+test
(defun test ()
  (let ((pw-chars "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz123456789")
	(password (make-string (+ 6 (random 2)))))
    (dotimes (i (length password))
      (setf (char password i) (aref pw-chars (random (length pw-chars)))))
    (print password)
    ))

#+test
(dotimes (i 20)
  (test))

(defun register-xle-user (user email site-admin-email)
  #+debug(print (list user email site-admin-email))
  (cond ((or (null user)
	     (equal user ""))
	 "You have to specify a user name (at least four letters).")
	((< (length user) 4)
	 "Your user name should have at least four letters.")
	((or (null email) (not (find #\@ email)))
	 "You have to specify a valid email address.")
	((and (not (string-equal user email))
	      (find user (net.aserve::password-authorizer-allowed *grammar-authorizer*)
		    :key #'car :test #'string-equal))
	 (format nil "A user named ~s is already registered." user))
	((not (loop for suffix in *email-suffixes*
		    thereis
		    (let ((start (search suffix email)))
		      ;;(print (list :start start :sfx suffix :email email))
		      (and (eq start (- (length email) (length suffix)))
			   (find (char email (1- start)) "@.")))))
	 (cond ((null site-admin-email)
		(format nil "Your email address has to end in ~{~s~^ or ~}" *email-suffixes*))
	       ((not (find site-admin-email *site-administrators* :test #'string-equal))
		(format nil "The address ~a is not a site administrator" site-admin-email))
	       (t
		(multiple-value-bind (password exists-p) (generate-and-register-password user email)
		  (net.post-office:send-letter
		   *smtp-server*
		   *postmaster*
		   site-admin-email
		   (format nil (concat "Dear ~a,~2%"
				       "~a sent an XLE-Web registration request. ~2%His/her account information is:~2%"
				       "  User name: ~a~%  Password: ~a~2%"
				       "Please forward the account data to the user.")
			   site-admin-email user user password)
		   :bcc *postmaster*
		   :subject "XLE-Web registration request")
		  (net.post-office:send-letter
		   *smtp-server*
		   *postmaster*
		   email
		   (format nil (concat "Dear ~a,~2%"
				       "Your XLE-Web registration request has been forwarded to ~a.~2%"
				       "A login password will be mailed to you."
				       "(If you did not request this information, please report to ~a.)")
			   user site-admin-email
			   *postmaster*)
		   :bcc *postmaster*
		   :subject "Your XLE-Web registration request")
		  :confirm-request))))
	#+ignore
	((not (net.post-office::test-email-address email))
	 "The email address you specified was rejected by the server.")
	(t
	 (multiple-value-bind (password exists-p) (generate-and-register-password user email)
	   (net.post-office:send-letter
	    *smtp-server*
	    *postmaster*
	    email
	    (format nil (concat "Dear ~a,~2%"
				(if exists-p
				    "here is your lost account information:~2%"
				    "thank you for registering.~2%Your account information is:~2%")
				"  User name: ~a~%  Password: ~a~2%"
				;; "Upload and test your grammar(s) at http://decentius.aksis.uib.no:8000/~a/xle-web/xle.xml~2%"
				"(If you did not request this information, please report to ~a.)")
		    user user password ;; *url-base*
		    *postmaster*)
	    :bcc *postmaster*
	    :subject "XLE-Web registration information")
	   nil))))

(defmethod xle-register-xml ((request http-request) entity &key (email-only-p t) &allow-other-keys)
  (with-xml-response (request entity stream (user email site-admin-email)
			      :xsl #'xle-register-xsl
			      :force-xslt :sablotron)
    ;;(Print (request-query request))
    #m(?xml-stylesheet :type "text/xsl" :href #s (concat "/" *url-base* "/xle-register.xsl"))
    (if (or user email)
	(let ((result (register-xle-user (if email-only-p email user) email site-admin-email)))
	  (cond ((null result)
		 #m(confirm/ :email #s email :user #s user))
		((eq result :confirm-request)
		 #m(confirm-request/ :email #s email :user #s user :site-admin-email #s site-admin-email))
		(t
		 #m(register/ :email #s email :user #s user :error #s result :email-only #s(when email-only-p "yes")))))
	#m(register/ :email-only #s(when email-only-p "yes")))))

(defstylesheet xle-register-xsl ()
  #m((xsl:stylesheet xmlns:xsl "http://www.w3.org/1999/XSL/Transform" :version "1.0")
     ((xsl:template :match "/")
      (html
       ((head)
	(title "XLE-Web Registration Page")
	((style :type "text/css")
	 (CSS-STYLE
	  (body :font-family "Verdana, Tahoma, MS Sans Serif, Arial, Geneva, Helvetica")
	  (div :margin "16"
	       :color "#004499"
	       :font-family "Verdana, Tahoma, MS Sans Serif, Arial, Geneva, Helvetica")
	  (div.title :font-size "24" :font-weight "bold" :text-align "center")
	  (div.error :color "red")
	  (td.title :font-weight "bold" :color "#004499" :text-align "center")
	  (td.comment :font-size "10")
	  (span.label :font-weight "bold")
	  (a :text-decoration "none" :color "black"))))
       (xsl:apply-templates/)))
     
     ((xsl:template :match "register")
      ((body)
       ((div :class "title") "XLE-Web Registration")
       ((form :method "post" :id "registrationForm")
	(div  "Register here to be able to upload grammars. (Re-register to retrieve your lost password.)")
	#+ignore
	((xsl:element :name "input")
	 ((xsl:attribute :name "type") "hidden")
	 ((xsl:attribute :name "name") "email-only")
	 ((xsl:attribute :name "value") (xsl:value-of/ :select "@email-only")))
	((xsl:if :test "@email-only")
	 (div "Your user name is your email address."))
	((xsl:if :test "@error")
	 ((div :class "error")
	  "Error: " (xsl:value-of/ :select "@error"))
	 (div "Try again:"))
	(table
	 ((xsl:if :test "not(@email-only)")
	  (tr (td "User name:")
	      ((td :class "value")
	       ((xsl:element :name "input")
		((xsl:attribute :name "type") "text")
		((xsl:attribute :name "name") "user")
		((xsl:attribute :name "value") (xsl:value-of/ :select "@user"))))
	      ((td :class "comment") "Choose a user name that consists of at least four letters.")))
	 (tr (td "Email Address:")
	     ((td :class "value")
	      ((xsl:element :name "input")
	       ((xsl:attribute :name "type") "text")
	       ((xsl:attribute :name "name") "email")
	       ((xsl:attribute :name "value") (xsl:value-of/ :select "@email"))))
	     ((td :class "comment")
	      #s(format nil "Your email address must end in ~{~s~^ or ~}~a" *email-suffixes* (if *site-administrators* ", or ..." ""))))
	 #L(when *site-administrators*
	     #m(tr ((td :colspan 3 :class "comment")
		    #s(format nil "... if your email address is not of the above form, provide the email address of your site administrator, who will mail you the password:")))
	     #m(tr (td "Site Administrator:")
		   ((td :class "value")
		    ((xsl:element :name "input")
		     ((xsl:attribute :name "type") "text")
		     ((xsl:attribute :name "name") "site-admin-email")
		     ((xsl:attribute :name "value") ""))))))
	(div
	 (input/ :type "submit" :name "register" :value "Register")))))
     
     ((xsl:template :match "confirm")
      ((body)
       ((div :class "title") "XLE-Web Registration Confirmation")
       
       (div "Thank you for registering. Your account information has been sent to "
	    ((xsl:element :name "a")
	     ((xsl:attribute :name "href") "mailto:" #s *postmaster*)
	     #s *postmaster*)
	    (xsl:value-of/ :select "@email") ".")
       
       (div "Go to the " ((a :href #s(concat "/" *url-base* "/xle.xml")) "XLE-Web page")
	    " to upload and test your grammar(s).")
       
       ))

     ((xsl:template :match "confirm-request")
      ((body)
       ((div :class "title") "XLE-Web Registration Request Confirmation")
       
       (div "Thank you for your registration request. Your request has been sent to " 
	    ((xsl:element :name "a")
	     ((xsl:attribute :name "href") "mailto:" (xsl:value-of/ :select "@site-admin-email"))
	     (xsl:value-of/ :select "@site-admin-email")) ".")
       
       (div "After receiving your login data, go to the " ((a :href #s(concat "/" *url-base* "/xle.xml")) "XLE-Web page")
	    " to upload and test your grammar(s).")
       
       ))))

(defmethod xle-documentation-xml ((request http-request) entity)
  (with-xml-response (request entity stream (mrs)
			      :xsl #'xle-documentation-xsl
			      :force-xslt :sablotron)
    #m(?xml-stylesheet :type "text/xsl" :href #s (concat "/" *url-base* "/xle-web-documentation.xsl"))
    #m(text
       (title "XLE-Web Documentation")
       (div (div (head "About the XLE Web Interface")
		 (p "The XLE Web Interface (XLE-Web) is a web-based tool for parsing with " (link/ :url "http://www2.parc.com/istl/groups/nltt/xle/" :text "XLE") " and viewing c-structures, f-structures and mrs-structures. Initially, it was developed in the " (link/ :url "http://www.emmtee.net/" :text "LOGON") " project.")
		 (p "XLE-Web allows the user to choose a grammar and type in a sentence to be analyzed. The sentence is then processed by the XLE parser, and the resulting c-structures, f-structures and mrs-structures (HPSG-style Multiple Recursion Semantics structures) are displayed, either one solution at a time, or all solutions together in the form of packed c- and f-structure representations (there is no packed mrs-representation at present).")
		 (p "XLE-Web has a facility for uploading (small) user grammars, mainly for teaching purposes."))
	    (div (head "Browser recommendations")
		 (p "XLE-Web has been tested and works well with recent versions of the following browsers: Safari (MacOS X), Firefox, Internet Explorer. Firefox has built-in SVG support (needed for c-structure display); for the other browsers, you should install Adobe&#x2019;s " (link/ :url "http://www.adobe.com/svg/viewer/install/main.html" :text "SVG viewer plugin") " or any other SVG viewer.")) 
	    (div (head "Parsing Sentences")
		 (p "For parsing, type a sentence into the text box and press &#x2018;Parse sentence&#x2019;. After XLE has finished parsing (which might take some time), c- and f-structures are displayed. If you chose &#x2018;Packed representation&#x2019;, all solutions are displayed simultaneously; otherwise, you can move between solutions using the &#x2018;Previous&#x2019; and &#x2018;Next&#x2019; buttons.")
		 (p "By default, the root of the parse tree is the ROOTCAT of the grammar specified in the grammar file. If no solution is found, the solutions rooted in the REPARSECAT category (if specified) are displayed. You may explicitly specify a different root category for parsing by prepending the category name and a colon to the string (e.g., &#x2018;NP:small child&#x2019;).")
		 (p "You can disable the Optimality marks in your grammar by checking the appropriate check box.")
		 (div (head "C-structure display")
		      (p "C-structures are either displayed as ordinary c-structure trees, or, in packed mode, as graphs simultaneously displaying the c-structures of all solutions. Mousing over a c-structure node highlights both the f-structure projection of that node and all other nodes having the same projection. (The latter feature is (at present) only available for packed c-structures and does not work in all browsers.)"))
		 (div (head "F-structure display")
		      (p "In the same fashion, f-structures are either displayed as ordinary (uncontexted) f-structures, one for each solution, or as packed f-structures combining the f-structures of all solutions. Sub-structures of a packed f-structure pertaining to a given context (= subset of the set of all solutions) are labeled by green context labels (which correspond to the context labels in the packed c-structures). The abbreviated complex context labels (e.g. &#x2018;cv_005&#x2019;) are mouse-sensitive; mousing over them shows their definition in terms of basic choice labels (e.g. &#x2018;b3-b5|c4&#x2019;).")
		      (p "If several f-structure attributes share their value, the value sub-f-structure is displayed only once, whereas the other attributes only have a reference index (a red number, which is also displayed as a red subscript on the referenced structure) as displayed value. Mousing over the reference index highlights the referenced structure. Clicking on the index makes the highlighting stick.")))
	    #+not-yet
	    (div (Head "Disambiguation and Discriminants")
		 (p ""))
	    (div (head "Reloading a grammar")
		 (p "If you have made changes to a source file of your grammar which makes a reload necessary, you can do so by pressing the button labelled &#x2018;Reload and parse&#x2019;. Eventual errors in the grammar will be displayed in red. Pressing &#x2018;Reload, check and parse&#x2019; performes a more thorough check of the grammar (it loads the generator) and finds also errors in the lexicon section. This may take much longer than a simple reload."))
	    #L(when *email-suffixes*
		#m(div (head "Uploading Grammars")
		       (p "To be able to upload your own grammars, you have to register " 
			  (link/ :url #s(concat "/" *url-base* "/xle-register.xml") :text "here")
			  ".  An email with password and further instructions will be sent to you.")
		       (p "As of now, a grammar to be uploaded has to consist of one file only, and it should use the standard (XLE built-in) morphology. (That is, the grammar should not contain a Morphology section.)")
		       (p "The grammar file&#x2019;s name should only contain ASCII characters and have the extension &#x2018;.lfg&#x2019;. Use the &#x2018;Upload Grammar&#x2019; button to upload it from your local machine. The grammar will then appear as a choice in the Grammar pulldown menu. After editing your grammar, you may upload it again, and changes will take effect immediately. It is advisible to re-upload the edited grammar using the same file name.")))

	    (div (head "Implementation Details")
		 (p "Packed f-structures were first implemented in XLE in order to provide a compact and efficient internal representation of the set of solutions of a sentence. The XLE display system uses this packing to simultaneously display all f-structures in one graph, and the packed f-structures in XLE-Web have been tightly modeled after XLE&#x2019;s packed f-structure display. An innovation in XLE-Web is the display of packed c-structures as directed acyclic graphs, namely, as a set of c-structure trees where certain nodes that are equal across solutions are identified and where additional nodes indicate in which contexts their subnodes are valid.")
		 (p "The XLE-Web server software runs on Linux and MacOS; it is implemented in Common Lisp and uses a shared library version of the XLE core parsing engine which is dynamically linked into the server program. Internally, the interface web pages are generated as XML files, which are converted on the server side to HTML by means of XSLT. The interactive features of the displayed structures are implemented in Javascript. The c-structure trees (and graphs in the case of packed representations) are drawn using the XML-compliant standard SVG (Scalable Vector Graphics).
"))
	    #+not-yet
	    (div (head "Installing the Software")
		 (p ""))
	    
	    (p "Please refer to the " (link/ :url "http://www2.parc.com/istl/groups/nltt/xle/doc/xle_toc.html" :text "XLE documentation") " for more information.") ))))

(defstylesheet xle-documentation-xsl ()
  #m((xsl:stylesheet xmlns:xsl "http://www.w3.org/1999/XSL/Transform" :version "1.0")
     ((xsl:template :match "/text")
      (html
       ((head)
	(title (xsl:value-of/ :select "title"))
	((style :type "text/css")
	 (CSS-STYLE
	  (body :font-family "Verdana, Tahoma, MS Sans Serif, Arial, Geneva, Helvetica")
	  (div :margin "16"
	       :color "#004499"
	       :font-family "Verdana, Tahoma, MS Sans Serif, Arial, Geneva, Helvetica")
	  (div.title :font-size "24" :font-weight "bold" :text-align "center")
	  (div.error :color "red")
	  (td.title :font-weight "bold" :color "#004499" :text-align "center")
	  (td.comment :font-size "10")
	  (span.label :font-weight "bold")
	  (a ;;:text-decoration "none"
	     :color "#004499"))))
       ((body)
	;;((div :class "title") (xsl:value-of/ :select "title"))
	(xsl:apply-templates/)
	((div :class "link")
	 (hr/ :size "1" :color "black")
	 ((a :href "http://www.aksis.uib.no") "AKSIS, University of Bergen")
	 " " #s(u::now :format :year) ", "
	 ((a :href "mailto:paul.meurer@aksis.uib.no") "Paul Meurer")))))
	
     ((xsl:template :match "div")
      ;;((div :class "head") (xsl:value-of/ :select "head")
      (xsl:apply-templates/))

     ((xsl:template :match "p")
      ;;((div :class "head") (xsl:value-of/ :select "head")
      (p (xsl:apply-templates/)))
     
     ((xsl:template :match "title")
      ((div :class "title") (xsl:value-of/ :select ".")))
     
     ((xsl:template :match "head")
      ((div :class "head") (xsl:value-of/ :select ".")))
     
     ((xsl:template :match "link")
      ((xsl:element :name "a")
       ((xsl:attribute :name "href") (xsl:value-of/ :select "@url"))
       ;;((xsl:attribute :name "class") "link")
       (xsl:value-of/ :select "@text"))))
  )

(defparameter *xle-authorizer*
    (make-instance 'password-authorizer
      :allowed '(("paul" . "adzghab")
		 ("helge" . "tango")
		 ("victoria" . "lotus")
		 ("koenraad" . "fokus"))
      :realm "XLE"))

#+(and (not :pargram) :allegro)
(publish :path (concat "/" *url-base* "/xle-admin.xml")
	 :class 'xml/html-entity
	 :authorizer *xle-authorizer*
	 :function #'xle-admin-xml)

#+(and (not :pargram) :allegro)
(publish :path (concat "/" *url-base* "/xle-admin.xsl")
	 :content-type "text/xml"
	 :authorizer *xle-authorizer*
	 :function #'xle-admin-xsl)

(publish :path (concat "/" *url-base* "/xle-register.xml")
	 :class 'xml/html-entity
	 :function #'xle-register-xml)

(publish :path (concat "/" *url-base* "/xle-web-documentation.xml")
	 :class 'xml/html-entity
	 :function #'xle-documentation-xml)

(publish :path (concat "/" *url-base* "/xle-web-documentation.xsl")
	 :content-type "text/xml"
	 :function #'xle-documentation-xsl)

(publish :path (concat "/" *url-base* "/xle-register.xsl")
	 :content-type "text/xml"
	 :function #'xle-register-xsl)

(defun print-environment (variable-names &optional (stream t))
  (format stream "~&~{~a: ~a~%~}"
	  (collecting
	   (dolist (var variable-names)
	     (collect var)
	     (collect (sys:getenv var))))))

#+paul
(defmethod xle-web-download-html ((request http-request) entity)
  (with-html-response (request entity stream ())
    #m(html (head )
	    (body
	     (h3 "XLE-Web downloads")
	     (h4 "32 bit Linux")
	     #L(dolist (file (directory "~/lisp/projects/xle/build/linux.x86.32/*.gz"))
		 (let* ((file (namestring file))
			(name (subseq file (1+ (position #\/ file :from-end t)))))
		   #m(p ((a :href #s (concat "/xle-web/" name)) #s name))))))))

#+paul
(publish :path "/xle-web/download.html"
	 :content-type "text/html"
	 :authorizer (make-instance 'password-authorizer
				    :allowed '(("john" . "acdt")
					       ("ozlem" . "Istanbul")
					       ("ingo" . "draig")
					       ("paul" . "adzghab"))
				    :realm "XLE-Web")
	 :function #'xle-web-download-html)

#+paul
(publish-directory :prefix "/xle-web/"
		   :destination "/home/paul/lisp/projects/xle/build/linux.x86.32/")


:eof