├── webjure
    ├── src
    │   ├── init.clj
    │   ├── test
    │   │   └── resources
    │   │   │   ├── message.cpt
    │   │   │   ├── repeat-binding.cpt
    │   │   │   ├── simple.cpt
    │   │   │   └── inbox.cpt
    │   ├── main
    │   │   └── resources
    │   │   │   ├── profiler
    │   │   │       ├── profiler.js
    │   │   │       ├── report.xml
    │   │   │       └── profiler.css
    │   │   │   └── crud
    │   │   │       ├── generic-listing-template.cpt
    │   │   │       └── crud-styles.cpt
    │   ├── webjure
    │   │   ├── servlet.clj
    │   │   ├── sql
    │   │   │   ├── crud
    │   │   │   │   └── editors.clj
    │   │   │   └── crud.clj
    │   │   ├── html.clj
    │   │   ├── sql.clj
    │   │   ├── xml
    │   │   │   └── feeds.clj
    │   │   ├── json.clj
    │   │   ├── csv.clj
    │   │   ├── profiler.clj
    │   │   ├── xml.clj
    │   │   └── cpt.clj
    │   └── webjure.clj
    ├── test
    │   └── webjure
    │   │   ├── html
    │   │       └── test.clj
    │   │   ├── cpt
    │   │       └── test.clj
    │   │   └── csv
    │   │       └── test.clj
    └── project.clj
├── demos
    ├── src
    │   └── main
    │   │   ├── resources
    │   │       ├── var.cpt
    │   │       ├── function.cpt
    │   │       ├── docs.cpt
    │   │       ├── page.cpt
    │   │       └── docs-pdf.cpt
    │   │   ├── webapp
    │   │       ├── resource
    │   │       │   ├── images
    │   │       │   │   ├── img01.gif
    │   │       │   │   ├── img02.gif
    │   │       │   │   ├── img03.gif
    │   │       │   │   ├── img04.gif
    │   │       │   │   └── spacer.gif
    │   │       │   ├── repl.js
    │   │       │   └── default.css
    │   │       └── WEB-INF
    │   │       │   └── web.xml
    │   │   └── clojure
    │   │       └── webjure
    │   │           ├── wiki.clj
    │   │           ├── demos.clj~
    │   │           └── demos.clj
    └── pom.xml
├── .classpath
├── .gitignore
├── .project
├── LICENSE
├── pom.xml
├── README.markdown
└── changes.txt


/webjure/src/init.clj:
--------------------------------------------------------------------------------
1 | 
2 | 
3 | (require 'swank.swank)
4 | (swank.swank/start-repl 4005)


--------------------------------------------------------------------------------
/demos/src/main/resources/var.cpt:
--------------------------------------------------------------------------------
1 | <div xmlns:cpt="http://webjure.org/namespaces/cpt">
2 |   var: $(:name var) <br/>
3 |   $(:doc var)
4 | </div>


--------------------------------------------------------------------------------
/demos/src/main/webapp/resource/images/img01.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/tatut/Webjure/HEAD/demos/src/main/webapp/resource/images/img01.gif


--------------------------------------------------------------------------------
/demos/src/main/webapp/resource/images/img02.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/tatut/Webjure/HEAD/demos/src/main/webapp/resource/images/img02.gif


--------------------------------------------------------------------------------
/demos/src/main/webapp/resource/images/img03.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/tatut/Webjure/HEAD/demos/src/main/webapp/resource/images/img03.gif


--------------------------------------------------------------------------------
/demos/src/main/webapp/resource/images/img04.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/tatut/Webjure/HEAD/demos/src/main/webapp/resource/images/img04.gif


--------------------------------------------------------------------------------
/demos/src/main/webapp/resource/images/spacer.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/tatut/Webjure/HEAD/demos/src/main/webapp/resource/images/spacer.gif


--------------------------------------------------------------------------------
/webjure/src/test/resources/message.cpt:
--------------------------------------------------------------------------------
1 | <?xml version="1.0" encoding="utf-8"?>
2 | <span class="message">
3 |   Title: $(:title m) <br/>
4 |   Message: $(:body m) <br/>
5 | </span>
6 | 


--------------------------------------------------------------------------------
/webjure/src/test/resources/repeat-binding.cpt:
--------------------------------------------------------------------------------
1 | <?xml version="1.0" encoding="utf-8"?>
2 | <foo xmlns:cpt="http://webjure.org/namespaces/cpt">
3 | <value cpt:repeat="[id value] here" id="$id">$value</value>
4 | </foo>


--------------------------------------------------------------------------------
/demos/src/main/resources/function.cpt:
--------------------------------------------------------------------------------
1 | <div xmlns:cpt="http://webjure.org/namespaces/cpt">
2 |   <b>$(:name var)</b> (function) <br/>
3 |   arglists: 
4 |   <span cpt:repeat="al (:arglists var)">
5 |     <br/> &#160;&#160; $(str al)
6 |   </span>
7 |   <br/>
8 |   $(:doc var)
9 | </div>


--------------------------------------------------------------------------------
/.classpath:
--------------------------------------------------------------------------------
1 | <?xml version="1.0" encoding="UTF-8"?>
2 | <classpath>
3 | 	<classpathentry kind="con" path="org.devzuz.q.maven.jdt.core.mavenClasspathContainer"/>
4 | 	<classpathentry kind="con" path="org.eclipse.jdt.launching.JRE_CONTAINER"/>
5 | 	<classpathentry kind="output" path="target/classes"/>
6 | </classpath>
7 | 


--------------------------------------------------------------------------------
/webjure/src/test/resources/simple.cpt:
--------------------------------------------------------------------------------
1 | <?xml version="1.0" encoding="utf-8"?>
2 | <foo xmlns:cpt="http://webjure.org/namespaces/cpt">
3 | <number cpt:repeat="n here" cpt:replace="n">
4 |   Nothign in here will be output... the whole element will be replaced by a number
5 |     <me>
6 |        <neither/>
7 |     </me>
8 | </number>
9 | </foo>


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
 1 | demos/src/main/clojure/webjure/*~
 2 | demos/src/main/resources/*~
 3 | webjure/src/main/clojure/webjure/*~
 4 | webjure/src/test/clojure/webjure/cpt/*~
 5 | webjure/src/main/clojure/webjure/sql/*~
 6 | webjure/src/test/resources/*~
 7 | webjure/src/main/resources/crud/*~
 8 | webjure/src/main/resources/profiler/*~
 9 | webjure/src/*~
10 | webjure/src/webjure/*~
11 | webjure/*~
12 | demos/target/
13 | webjure/target/
14 | .gitignore~
15 | derby.log


--------------------------------------------------------------------------------
/webjure/src/test/resources/inbox.cpt:
--------------------------------------------------------------------------------
 1 | <?xml version="1.0" encoding="utf-8"?>
 2 | <html xmlns:cpt="http://webjure.org/namespaces/cpt">
 3 |   <head><title>Inbox</title></head>
 4 |   <body>
 5 |     <div>
 6 |       <h3>Unnumbered list of messages</h3>
 7 |       <span cpt:let="msgs (:messages here)">
 8 | 	<span cpt:when="(empty? msgs)">There are no messages!</span>
 9 | 	<span cpt:repeat="m msgs" cpt:include="message.cpt"/>
10 |       </span>
11 |     </div>
12 |   </body>    
13 | </html>
14 | 


--------------------------------------------------------------------------------
/webjure/test/webjure/html/test.clj:
--------------------------------------------------------------------------------
 1 | (ns webjure.html.test
 2 |   (:refer-clojure)
 3 |   (:use clojure.test)
 4 |   (:use webjure.html))
 5 | 
 6 | 
 7 | (deftest simple-element
 8 |   (is (= (html-format `(:a {:href "foo"} "something"))
 9 | 	 "<a href=\"foo\">something</a>")))
10 | 
11 | (deftest empty-element
12 |   (is (= (html-format `(:br))
13 | 	 "<br />")))
14 | 
15 | (deftest escaped-text
16 |   (is (= (html-format `(:div "< and > are escaped here"))
17 | 	 "<div>&lt; and &gt; are escaped here</div>")))
18 | 
19 | (deftest raw-text
20 |   (is (= (html-format `(:div ~(fn [] "< and > are not escaped here")))
21 | 	 "<div>< and > are not escaped here</div>")))


--------------------------------------------------------------------------------
/.project:
--------------------------------------------------------------------------------
 1 | <?xml version="1.0" encoding="UTF-8"?>
 2 | <projectDescription>
 3 | 	<name>webjure</name>
 4 | 	<comment></comment>
 5 | 	<projects>
 6 | 	</projects>
 7 | 	<buildSpec>
 8 | 		<buildCommand>
 9 | 			<name>org.eclipse.jdt.core.javabuilder</name>
10 | 			<arguments>
11 | 			</arguments>
12 | 		</buildCommand>
13 | 		<buildCommand>
14 | 			<name>org.devzuz.q.maven.jdt.core.mavenIncrementalBuilder</name>
15 | 			<arguments>
16 | 			</arguments>
17 | 		</buildCommand>
18 | 	</buildSpec>
19 | 	<natures>
20 | 		<nature>org.eclipse.jdt.core.javanature</nature>
21 | 		<nature>org.devzuz.q.maven.jdt.core.mavenNature</nature>
22 | 	</natures>
23 | </projectDescription>
24 | 


--------------------------------------------------------------------------------
/demos/src/main/resources/docs.cpt:
--------------------------------------------------------------------------------
 1 | <html xmlns:cpt="http://webjure.org/namespaces/cpt">
 2 |   <head>
 3 |     <title>Webjure docs</title>
 4 |   </head>
 5 |   <body>
 6 |     <h3>Documentation on all public vars in the webjure namespace</h3>
 7 |     <a href="$(base-url)/docs/pdf">PDF version</a>
 8 |     <div class="documentation-container" cpt:repeat="var here">
 9 |       <hr/>
10 |       <div cpt:when="(:arglists var)" cpt:include="function.cpt">
11 | 	documentation for a function
12 |       </div>
13 |       <div cpt:when="(not (:arglists var))" cpt:include="var.cpt">
14 | 	documentation for other vars
15 |       </div>
16 |     </div>
17 |   </body>
18 | </html>
19 | 


--------------------------------------------------------------------------------
/webjure/project.clj:
--------------------------------------------------------------------------------
 1 | (defproject webjure "0.9.1-SNAPSHOT"
 2 |   :description "Webjure - a Clojure web framework"
 3 |   :dependencies [[org.clojure/clojure "1.2.0"]
 4 | 		 [org.clojure/clojure-contrib "1.2.0"]]
 5 |   :dev-dependencies [[leiningen/lein-swank "1.2.0-SNAPSHOT"]
 6 | 		     [javax.servlet/servlet-api "2.4"]
 7 | 		     [org.mortbay.jetty/jetty "6.1.26"]]
 8 |   :aot [webjure
 9 | 	webjure.servlet
10 | 	webjure.sql webjure.sql.crud webjure.sql.crud.editors
11 | 	webjure.cpt
12 | 	webjure.html
13 | 	webjure.xml webjure.xml.feeds
14 | 	webjure.json
15 | 	webjure.csv
16 | 	webjure.profiler
17 | 	;;webjure.websocket
18 | 	]
19 |   :repl-init-script "src/init.clj"
20 |   :omit-source true
21 |   )


--------------------------------------------------------------------------------
/webjure/src/main/resources/profiler/profiler.js:
--------------------------------------------------------------------------------
 1 | var WebjureMiniProfiler = {
 2 | 
 3 |     init: function(requestId, fShowImmediately) {
 4 |         // Fetch profile results for any ajax calls
 5 |         // (see http://code.google.com/p/mvc-mini-profiler/source/browse/MvcMiniProfiler/UI/Includes.js)
 6 |         $(document).ajaxComplete(function (e, xhr, settings) {
 7 |             if (xhr) {
 8 |                 var requestId = xhr.getResponseHeader('X-MiniProfiler-Id');
 9 |                 if (requestId) {
10 |                     WebjureMiniProfiler.fetch(requestId);
11 |                 }
12 |             }
13 |         });
14 | 	
15 | 	$().ready(function() { WebjureMiniProfiler.fetch(requestId, fShowImmediately) });
16 |     },
17 | 
18 |     fetch: function(requestId, fShowImmediately) {
19 |         $.get("/_webjure_profiler/request", { "id": requestId },
20 |               function(data) {
21 |                   $('body').append(data);
22 |               });
23 |     }
24 | };
25 | 
26 | 


--------------------------------------------------------------------------------
/webjure/src/webjure/servlet.clj:
--------------------------------------------------------------------------------
 1 | (ns webjure.servlet
 2 |   (:refer-clojure)
 3 |   (:use webjure)
 4 |   (:import (javax.servlet ServletConfig ServletException UnavailableException))
 5 |   (:import (javax.servlet.http
 6 | 	    HttpServlet HttpServletRequest HttpServletResponse))
 7 |   (:gen-class :name webjure.servlet.WebjureServlet
 8 | 	      :extends javax.servlet.http.HttpServlet
 9 | 	      :exposes-methods {init superInit
10 | 				}))
11 | 
12 | 
13 | (defn -doGet [this ^HttpServletRequest request ^HttpServletResponse response]
14 |   (dispatch "GET" request response))
15 | 
16 | (defn -doPost [this ^HttpServletRequest request ^HttpServletResponse response]
17 |   (dispatch "POST" request response))
18 | 
19 | (defn -init
20 |   ([this] (.log this "Webjure servlet initialized."))
21 |   ([this ^ServletConfig config]
22 |      (let [start-ns (.getInitParameter config "startupNamespace")]
23 |        (when start-ns
24 | 	 (require (symbol start-ns))))
25 |      (.superInit this config)))
26 | 
27 | 
28 | 


--------------------------------------------------------------------------------
/demos/src/main/webapp/resource/repl.js:
--------------------------------------------------------------------------------
 1 | 
 2 | var req;
 3 | function replCallback(txt) {
 4 |   if(req.readyState == 4) {
 5 |     if(req.status == 200) {
 6 |       if(req.responseText.length > 0) appendContent('=> '+req.responseText);
 7 |       readRepl();
 8 |     } else {
 9 |       alert('Unable to read repl: '+req.statusText);
10 |     }
11 |   }
12 | } 
13 | 
14 | function readRepl() { 
15 |   req = new XMLHttpRequest();
16 |   req.onreadystatechange = replCallback;
17 |   req.open('GET', '/webjure-demos/ajaxrepl-out', true);
18 |   req.send(null);
19 | } 
20 |     
21 | function appendContent(txt) {
22 |   var elt = document.getElementById('replout');
23 |   elt.innerHTML += txt + '\n';
24 |   elt.scrollTop = elt.scrollHeight;
25 | } 
26 |          
27 | function keyHandler(event) { if(event.keyCode == 13) write(); } 
28 | function write() { 
29 |   var elt = document.getElementById('replin');
30 |   var r = new XMLHttpRequest();
31 |   r.open('POST', '/webjure-demos/ajaxrepl-in', true);
32 |   appendContent(elt.value);
33 |   r.send(elt.value);
34 |   elt.value = '';
35 | }
36 | window.onload = readRepl;
37 | 
38 | 
39 | 


--------------------------------------------------------------------------------
/webjure/test/webjure/cpt/test.clj:
--------------------------------------------------------------------------------
 1 | (ns webjure.cpt.test
 2 |   (:refer-clojure)
 3 |   (:use clojure.test)
 4 |   (:use webjure.cpt))
 5 | 
 6 | (set! *warn-on-reflection* true)
 7 | 
 8 | ;; Very simple template
 9 | (define-template simple1 "src/test/resources/simple.cpt")
10 |     
11 | ;; A template that loops over messages and includes
12 | ;; a subtemplate for each item
13 | (define-template inbox "src/test/resources/inbox.cpt")
14 | 
15 | (define-template repeat-binding "src/test/resources/repeat-binding.cpt")
16 | 
17 | (defn t [template here]
18 |   (with-out-str (template here)))
19 | 
20 | (deftest simple-template 
21 |   (is (= (t simple1 [1 2 3]) "<foo>\n123\n</foo>")))
22 |   
23 | 
24 | (deftest test-inbox
25 |   (is (= (t inbox {:messages [ {:title "Welcome to CPT" :body "something or other..."}
26 | 			       {:title "Another message" :body "lorem ipsum etc"} ]})
27 | 	 "<html>\n  <head><title>Inbox</title></head>\n  <body>\n    <div>\n      <h3>Unnumbered list of messages</h3>\n      <span>\n\t\n\t<span class=\"message\">\n  Title: Welcome to CPT <br/>\n  Message: something or other... <br/>\n</span><span class=\"message\">\n  Title: Another message <br/>\n  Message: lorem ipsum etc <br/>\n</span>\n      </span>\n    </div>\n  </body>    \n</html>")))
28 | 
29 | (deftest test-repeat-binding
30 |     (is (= (t repeat-binding [[1 "one"] [2 "two"]])
31 | 	   "<foo>\n<value id=\"1\">one</value><value id=\"2\">two</value>\n</foo>")))


--------------------------------------------------------------------------------
/webjure/src/webjure/sql/crud/editors.clj:
--------------------------------------------------------------------------------
 1 | ;;
 2 | ;; Inline editor support implementations
 3 | ;;
 4 | 
 5 | 
 6 | (ns webjure.sql.crud.editors
 7 |   (:refer-clojure)
 8 |   (:use webjure.sql)
 9 |   (:use webjure)
10 |   (:use webjure.sql.crud))
11 | 
12 | 
13 | ;; Inline editor for simple short text input
14 | ;; Shows the text normally (with a hover edit icon). When the text is clicked
15 | ;; it is replaced with an input field containing the text.
16 | ;; Pressing enter in the input field will submit the replacement text.
17 | 
18 | (defn text-inline-edit []
19 |   (reify InlineEdit
20 |     (render-inline-edit-view [this field current-value]
21 |       (let [s (gensym)
22 |             post-url (crud-url "/inline-edit" {})]
23 |         (str "<span class=\"editable\" onclick=\"event.stopPropagation(); $('#" s "').hide(); $('#" s "_edit').show(); if(typeof(init"s")=='undefined') { init"s" = 1; $('#" s "_input').keypress(function(e) { if(e.which==13) { $.post('" post-url  "', {value: $('#" s "_edit input').val()}); } }); } return false;\">"
24 |              "<span class=\"current\" id=\"" s "\">" current-value "</span>"
25 |              "<span style=\"display: none;\" id=\"" s "_edit\"><input id=\"" s "_input\" type=\"text\" value=\"" (.replace current-value "\"" "%22") "\" /></span>"
26 |              
27 |              "</span>"
28 |              )))
29 | 
30 |     (update-value [this id field new-value]
31 |       (println "Got new " field " value for row " id ": " new-value))))
32 |     
33 |   
34 | 


--------------------------------------------------------------------------------
/demos/src/main/resources/page.cpt:
--------------------------------------------------------------------------------
 1 | <html xmlns="http://www.w3.org/1999/xhtml"
 2 |       xmlns:cpt="http://webjure.org/namespaces/cpt">
 3 |   <head>
 4 |     <meta http-equiv="content-type" content="text/html; charset=utf-8"/>
 5 |     <title>$(or (:title here) "Webjure demos page")</title>
 6 |     
 7 |     <link href="$(base-url)/resource/default.css" rel="stylesheet" type="text/css"/>
 8 |   </head>    
 9 |   <body> 
10 |     <div id="header">
11 |       <h1>Webjure</h1>
12 |       <h2>By Free CSS Templates</h2>
13 |     </div> 
14 |     
15 |     <div id="menu">
16 |       <ul>
17 | 	<li class="first"><a href="$(base-url)/index">Home</a></li>
18 | 	<li><a href="http://github.com/tatut/Webjure">On Github</a></li>
19 |       </ul>
20 |     </div>
21 |     
22 |     <div id="content">
23 |       <div id="columnA">
24 | 	$@(:content here)
25 |       </div>
26 |       <div id="columnB">
27 | 	<h2>Recent Updates</h2>
28 | 	<p><strong>September 2 2010</strong>
29 | 	<br/>Updated to 0.7-SNAPSHOT, now works with Clojure 1.2 and has page templates.</p>
30 | 	<br/><br/>
31 | 	<p><strong>January 11 2010</strong>
32 | 	<br/>Updated to 0.5-SNAPSHOT, now works with Clojure 1.1 and does AOT compiling.</p>
33 |       </div>
34 |       
35 |       <div style="clear: both;">&#160;</div>
36 |     </div>
37 |     
38 |     <div id="footer">
39 |       <p>Copyright  2009-2010 Tatu Tarvainen. Designed by 
40 |       <a href="http://www.freecsstemplates.org" class="link1">Free CSS Templates</a></p>
41 |     </div>
42 |   </body>
43 | </html>


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2008 - 2009, Tatu Tarvainen
 2 | 
 3 | All rights reserved.
 4 | 
 5 | Redistribution and use in source and binary forms, with or without modification, 
 6 | are permitted provided that the following conditions are met:
 7 | 
 8 | Redistributions of source code must retain the above copyright notice, this list 
 9 | of conditions and the following disclaimer.
10 | Redistributions in binary form must reproduce the above copyright notice, this 
11 | list of conditions and the following disclaimer in the documentation and/or other 
12 | materials provided with the distribution.
13 | Neither the name of Tatu Tarvainen nor the names of its contributors may be used 
14 | to endorse or promote products derived from this software without specific prior 
15 | written permission.
16 | 
17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
18 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
19 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
20 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
21 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
22 | EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
23 | PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
24 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
25 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
26 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
27 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
28 | 


--------------------------------------------------------------------------------
/webjure/src/main/resources/profiler/report.xml:
--------------------------------------------------------------------------------
 1 | <?xml version="1.0" encoding="utf-8"?>
 2 | <span xmlns:cpt="http://www.webjure.org/namespaces/cpt">
 3 |   <div class="g-m-p-corner"
 4 |        onclick="var jCorner = jQuery('.g-m-p-corner'); jQuery('#$(:id here)').css('left', jCorner.offset().left + jCorner.width() + 18).toggle()">
 5 |     
 6 |     $(:total here) ms
 7 |     
 8 |   </div>
 9 | 
10 |   <div class="g-m-p" style="display: none;" id="$(:id here)">
11 |     <div class="title">             
12 |       <span class="url" title="$(:url here)">
13 | 	$(:url here)
14 |       </span>
15 |       <div class="total">$(:total here) <span class="ms">ms</span> 
16 |       </div>
17 |       </div>
18 |       <div class="date_and_share">
19 | 	<span class="date">$(.format (java.text.SimpleDateFormat. "dd.MM.yyyy HH:mm:ss") (java.util.Date.))</span>
20 |       </div>      
21 | 
22 |       <div class="profiler-details details fancy-scrollbar">
23 | 	<table>
24 | 	  <thead>
25 | 	    <tr>
26 | 	      <th class="left" width="70%">item</th>
27 | 	      <th class="right" width="15%"><nobr>total ms</nobr></th>
28 | 	      <th class="right" width="15%"><nobr>own ms</nobr></th>
29 | 	    </tr>
30 | 	  </thead>
31 | 
32 | 	  <tbody>
33 | 	    <tr cpt:repeat="{:keys [name indent total-ms own-ms]} (:report here)">
34 | 	      <td title="$name">
35 | 		<span style="padding: $(* 8 indent)px;">$@"&amp;nbsp;"</span>
36 | 		$name
37 | 	      </td>
38 | 	      <td class="right">
39 | 		$total-ms
40 | 	      </td>
41 | 	      <td class="right">
42 | 		$own-ms
43 | 	      </td>
44 | 	    </tr>
45 | 	  </tbody>
46 | 	</table>
47 |       </div>
48 |   </div>
49 | </span>


--------------------------------------------------------------------------------
/demos/src/main/webapp/WEB-INF/web.xml:
--------------------------------------------------------------------------------
 1 | <?xml version="1.0" encoding="utf-8"?>
 2 | <web-app version="2.4">
 3 |   <display-name>Webjure</display-name>
 4 |     
 5 |   <context-param>
 6 |     <param-name>shell</param-name>
 7 |     <param-value>127.0.0.1:27272</param-value>
 8 |   </context-param>
 9 |   
10 |   <servlet>
11 |     <servlet-name>webjure</servlet-name>
12 |     <servlet-class>webjure.servlet.WebjureServlet</servlet-class>
13 | 
14 |     <!-- This is the clojure script that is loaded on startup (after webjure init),
15 |          it is loaded using the ClassLoader so it should be in WEB-INF/classes or 
16 | 	 in a .jar file in WEB-INF/lib 
17 | 
18 | 	 Note this is only used for source scripts, use startupNamespace for AOT
19 | 	 namespaces to initialize.
20 |     <init-param>      
21 |       <param-name>startup</param-name>      
22 |       <param-value>demos.clj</param-value>
23 |     </init-param>
24 | 
25 |     -->
26 | 
27 |     <!-- Names the namespace to load when initializing -->
28 |     <init-param>
29 |       <param-name>startupNamespace</param-name>
30 |       <param-value>webjure.demos</param-value>
31 |     </init-param>
32 | 
33 |   </servlet>
34 | 
35 |   <servlet>
36 |     <servlet-name>default</servlet-name>
37 |     <servlet-class>org.mortbay.jetty.servlet.DefaultServlet</servlet-class>
38 |   </servlet>
39 | 
40 |   <servlet-mapping>
41 |     <servlet-name>default</servlet-name>
42 |     <url-pattern>/resource/*</url-pattern>
43 |   </servlet-mapping>
44 | 
45 | 
46 |   <servlet-mapping>
47 |     <servlet-name>webjure</servlet-name>
48 |     <url-pattern>/*</url-pattern>
49 |   </servlet-mapping>
50 | 
51 | </web-app>
52 | 


--------------------------------------------------------------------------------
/webjure/test/webjure/csv/test.clj:
--------------------------------------------------------------------------------
 1 | 
 2 | (ns webjure.csv.test
 3 |   (:refer-clojure)
 4 |   (:use clojure.test)
 5 |   (:use webjure.csv)
 6 |   (:import (java.util Date)))
 7 | 
 8 | (defn csv [data]
 9 |   (with-out-str 
10 |     (csv-format *out* data)))
11 | 
12 | (deftest simple-output-without-headers
13 |   (let [result (csv {:rows [["foo" "bar"]]})]
14 |     (is (= result "foo;bar\n"))))
15 | 
16 | (deftest simple-output-with-headers
17 |   (let [result (csv 
18 | 		{:headers [{:label "Name"}
19 | 			   {:label "Shoe size"
20 | 			    :format #(if (nil? %) "shoe size unknown" (str %))}]
21 | 		 :rows [["Tatu" 45]
22 | 			["Rolf" 38]
23 | 			["Tutte" nil]]})
24 | 	lines (seq (.split result "\n"))]
25 |     ;; we should have four lines, 1 header + 3 rows
26 |     (is (= (count lines) 4))
27 | 
28 |     ;; first line should be headers
29 |     (is (= (first lines) "Name;Shoe size"))
30 | 
31 | 
32 |     ;; Rolf has tiny feet
33 |     (is (= (nth lines 2) "Rolf;38"))
34 | 
35 |     ;; formatter for the 2nd column of the last line should output 
36 |     ;; "shoe size unknown"
37 |     (is (= (last lines) "Tutte;shoe size unknown"))
38 | ))
39 | 
40 | (deftest output-user-objects-with-separator
41 |   (let [result (csv {:rows [{:name "Rolf Teflon" :birthday (Date. 81 3 8)}
42 | 			    {:name "Tutte" :birthday (Date. 99 11 2)}
43 | 			    {:name "Foo Barsky" :birthday (Date. 70 0 1)}]
44 | 		     :headers [{:label "Name" :accessor :name} 
45 | 			       {:label "Year born"
46 | 				:accessor #(+ 1900 (.getYear (:birthday %)))}]
47 | 		     :separator \|})
48 | 	lines (seq (.split result "\n"))]
49 |     
50 |     (is (= (count lines) 4))
51 | 
52 |     (is (= (nth lines 2) "Tutte|1999"))))
53 | 


--------------------------------------------------------------------------------
/pom.xml:
--------------------------------------------------------------------------------
 1 | <project xmlns="http://maven.apache.org/POM/4.0.0" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
 2 |   xsi:schemaLocation="http://maven.apache.org/POM/4.0.0 http://maven.apache.org/maven-v4_0_0.xsd">
 3 |   <modelVersion>4.0.0</modelVersion>
 4 |   <groupId>webjure</groupId>
 5 |   <artifactId>webjure-top</artifactId>
 6 |   <packaging>pom</packaging>
 7 |   <version>0.8-SNAPSHOT</version>
 8 |   <name>webjure-top</name>
 9 |   <url>http://github.com/tatut/Webjure</url>
10 | 
11 |   <modules>
12 |     <module>webjure</module>
13 |     <module>demos</module>
14 |   </modules>
15 | 
16 |   <build>
17 |     <plugins>
18 |       <plugin>
19 | 	<groupId>org.apache.maven.plugins</groupId>
20 | 	<artifactId>maven-compiler-plugin</artifactId>
21 | 	<configuration>
22 | 	  <source>1.5</source>
23 | 	  <target>1.5</target>
24 | 	</configuration>
25 |       </plugin>
26 |     </plugins>
27 |   </build>
28 | 
29 |   <pluginRepositories>
30 |     <pluginRepository>
31 |       <id>codehaus snapshot repository</id>
32 |       <url>http://snapshots.repository.codehaus.org/</url>
33 |       <releases>
34 | 	<enabled>true</enabled>
35 |       </releases>
36 |     </pluginRepository>
37 |   </pluginRepositories>  
38 |     <dependencies>
39 |     <dependency>
40 |       <groupId>javax.servlet</groupId>
41 |       <artifactId>servlet-api</artifactId>
42 |       <version>2.5</version>
43 |       <scope>provided</scope>
44 |     </dependency>
45 | 
46 |     <dependency>
47 |         <groupId>javax.portlet</groupId>
48 |         <artifactId>portlet-api</artifactId>
49 |         <version>1.0</version>
50 |     </dependency>
51 | 
52 |     <dependency>
53 |       <groupId>org.clojure</groupId>
54 |       <artifactId>clojure</artifactId>
55 |       <version>1.2.0</version>
56 |     </dependency>
57 | 
58 |   </dependencies>
59 | 
60 | </project>
61 | 


--------------------------------------------------------------------------------
/README.markdown:
--------------------------------------------------------------------------------
 1 | # Webjure, a web programming framework for Clojure
 2 | 
 3 | ## Overview
 4 | 
 5 | Webjure is a simple web framework for Clojure.
 6 | It provides basic routing, request and response functionality on top
 7 | of Java servlets and then gets out of your way. 
 8 | 
 9 | The defh macro can be used for more automagic behaviour
10 | when defining handlers. It can be used to automatically read and parse
11 | input parameters (both parts of the URL path and GET/POST params).
12 | The defh can also automatically send the response as HTML or JSON.
13 | 
14 | Webjure also provides Clojure Page Templates (see webjure.cpt namespace) 
15 | can be used for dynamic HTML templates similar to ZPT/JPT. The templates
16 | are compiled to bytecode for good performance.
17 | 
18 | ## Hello world
19 | 
20 | A hello world in Webjure is very simple:
21 | 
22 |     (ns my-hello-world
23 |         (:refer-clojure)
24 |         (:use webjure))
25 |     
26 |     (defh "/hello" [] {:output :html}
27 |        `(:html
28 |           (:head (:title "Hello world from Webjure"))
29 |           (:body
30 |            "Hello world!")))
31 | 
32 | ## Wiki
33 | 
34 | For a slightly more complex example, see [in-memory wiki](http://gist.github.com/385152).
35 | 
36 | 
37 | ## Installation
38 | 
39 | 
40 | To install, you will need Apache Maven 2. 
41 | 
42 | Run "mvn install" in the main directory.
43 | 
44 | ## Running
45 | 
46 | After installation is done, you can depend on the webjure jar in your own web projects (or just copy the .jar from the target directory). To check out the demos, go to the "demos" subdirectory and run "mvn jetty:run" and point your browser to http://localhost:8080/webjure-demos/index.
47 | 
48 | SLIME users: To hack on the demos, first start swank by going to http://localhost:8080/webjure-demos/start-swank?port=4005 and then use slime-connect from Emacs.
49 | 
50 | 
51 | 
52 | 
53 | 


--------------------------------------------------------------------------------
/webjure/src/webjure/html.clj:
--------------------------------------------------------------------------------
 1 | (ns webjure.html
 2 |     (:refer-clojure))
 3 | 
 4 | (defn- append [^java.lang.Appendable out & stuff]
 5 |   (doseq [thing stuff]
 6 |     (.append out (str thing))))
 7 | 
 8 | (defprotocol HtmlFormat
 9 |   (format-item [thing out]))
10 | 
11 | (defn- html-format-tag [tag out]
12 |   (let [tagname (name (first tag))
13 | 	attrs   (second tag)
14 | 	content (if (map? attrs) (rest (rest tag)) (rest tag))]
15 |     (append out "<" tagname)
16 |     (if (map? attrs)
17 |       (doseq [[key value] attrs]
18 | 	;; append the attribute value, replace disallowed " character with '
19 | 	(append out
20 | 		" " (name key) "=\"" (.replace (str value) "\"" "'") "\"")))
21 |     (if (empty? content)
22 |       (append out " />")
23 |       (do	
24 | 	(append out ">")
25 | 	(doseq [c content]
26 | 	  (format-item c out))
27 | 	(append out "</" tagname ">")))))
28 | 
29 | (extend-protocol HtmlFormat
30 |   clojure.lang.Cons
31 |   (format-item [tag out] (html-format-tag tag out))
32 | 
33 |   clojure.lang.PersistentList
34 |   (format-item [tag out] (html-format-tag tag out))
35 | 
36 |   clojure.lang.Keyword
37 |   (format-item [tag out] (append out "<" (name tag) " />"))
38 | 
39 |   clojure.lang.IFn
40 |   (format-item [fun out] (append out (fun)))
41 |   
42 |   nil
43 |   (format-item [nothing out]) ;; Nothing in, nothing out
44 | 
45 |   java.lang.String
46 |   (format-item [string out]
47 | 	       (append out (.replace (.replace (.replace string "&" "&amp;") "<" "&lt;") ">" "&gt;")))
48 | 
49 | 
50 |   java.lang.Object
51 |   (format-item [obj out]
52 | 	       (format-item (str obj) out))
53 |   )
54 | 
55 | (defn html-format
56 |   "Format object as HTML to output. If called without
57 | specifying output the object is formatted into a newly
58 | created StringBuilder and the value returned."
59 |   ([obj] (let [out (StringBuilder.)]
60 | 	   (html-format out obj)
61 | 	   (str out)))
62 |   ([out obj]
63 |      (format-item obj out)))


--------------------------------------------------------------------------------
/demos/src/main/resources/docs-pdf.cpt:
--------------------------------------------------------------------------------
 1 | <fo:root xmlns:fo="http://www.w3.org/1999/XSL/Format"
 2 | 	 xmlns:cpt="http://webjure.org/namespaces/cpt">
 3 |   <fo:layout-master-set>
 4 |     <fo:simple-page-master master-name="normal" page-width="auto" page-height="auto" margin="20pt">
 5 |       
 6 |       <fo:region-body margin-top="30mm" />
 7 |       <fo:region-before />
 8 |       <fo:region-after/>
 9 |       
10 |     </fo:simple-page-master>
11 |   </fo:layout-master-set>
12 |   <fo:page-sequence master-reference="normal">
13 |     
14 |     <fo:static-content flow-name="xsl-region-before">
15 |       <fo:block font-weight="bold">Webjure docs</fo:block>
16 |     </fo:static-content>
17 |     
18 |     <fo:static-content flow-name="xsl-region-after">
19 |       <fo:block>
20 | 	Page <fo:page-number/> / <fo:page-number-citation ref-id="last-page"/>
21 |       </fo:block>
22 |     </fo:static-content>
23 |     
24 |     <fo:flow flow-name="xsl-region-body">
25 |       <fo:block font-weight="bold">Documentation on all public vars in the webjure namespace</fo:block>
26 |       <fo:block>
27 | 	<fo:table margin-top="5mm" table-layout="fixed" width="100%" border="1pt solid black">
28 | 	  <fo:table-column column-width="30%" background-color="rgb(245,245,245)" />
29 | 	  <fo:table-column column-width="70%" background-color="rgb(245,245,245)" />
30 | 	  <fo:table-body>
31 | 	    <fo:table-row border-bottom="1pt dotted black" cpt:repeat="var here">
32 | 	      <fo:table-cell>
33 | 		<fo:block>$(:name var)</fo:block>
34 | 	      </fo:table-cell>
35 | 	      <fo:table-cell>
36 | 		<fo:block cpt:when="(:arglists var)">
37 | 		  $(:arglists var)
38 | 		</fo:block>
39 | 		<fo:block wrap-option="wrap" white-space-collapse="true">$(:doc var)</fo:block>
40 | 	      </fo:table-cell>
41 | 	    </fo:table-row>
42 | 	  </fo:table-body>
43 | 	</fo:table>
44 |       </fo:block>
45 |       
46 |       <fo:block id="last-page"/>	
47 |     </fo:flow>
48 |   </fo:page-sequence>
49 | </fo:root>
50 | 
51 | 


--------------------------------------------------------------------------------
/demos/src/main/clojure/webjure/wiki.clj:
--------------------------------------------------------------------------------
 1 | (ns webjure.wiki
 2 |   (:refer-clojure)
 3 |   (:use webjure)
 4 |   (:use webjure.html))
 5 | 
 6 | (def *pages* (ref {}))
 7 | 
 8 | (defn update-page [page-name title body]
 9 |   (dosync
10 |    (alter *pages*
11 | 	  #(assoc % page-name {:title title :body body}))))
12 | 
13 | (defn get-page [page-name]
14 |   (@*pages* page-name))
15 | 
16 | (defn html-page [title & body]
17 |   `(:html
18 |     (:head (:title ~title))
19 |     (:body ~@body)))
20 | 
21 | 
22 | (defh #"/wiki/([^/]+)$" [page-name 1]
23 |   {:output :html}
24 |   (let [page (get-page page-name)]
25 |     (if (nil? page)
26 |       (html-page (str "Page does not exist: " page-name)
27 | 		 `(:div
28 | 		   (:h3 "Page \"" ~page-name "\" does not exist!")
29 | 		   (:a {:href ~(url (str "/wiki/" page-name "/edit"))}
30 | 		       "Create it")))		 
31 |       
32 |       (html-page (:title page)
33 | 		 `(:h3 ~(:title page))
34 | 		 `(:a {:href ~(url (str "/wiki/" page-name "/edit"))
35 | 		       :style "float: right;"} "edit this page")
36 | 		 `(:div ~#(:body page))))))
37 | 
38 | 
39 |        
40 | (defh #"/wiki/(.+)/edit$" [page-name 1]
41 |   {:output :html}
42 |   (let [page (get-page page-name)]
43 |     (html-page (if (nil? page)
44 | 		 (str "Create page: " page-name)
45 | 		 (str "Edit page: " (:title page)))
46 | 
47 | 	       `(:form 
48 | 		 {:action ~(url (str "/wiki/" page-name "/save"))
49 | 		  :method "POST"}
50 | 
51 | 		 "Title: " (:input {:type "text" :name "title"
52 | 				    :value ~(or (:title page) page-name)})
53 | 		 (:br)
54 | 
55 | 		 "Body: " (:br)
56 | 		 (:textarea {:name "body" :rows "20" :cols "70"}
57 | 			    ~(or (:body page) ""))
58 | 		 (:br)
59 | 		 (:input {:type "submit" :value "Save"})))))
60 | 
61 | (defn redirect [url]
62 |   (.sendRedirect (.getActualResponse *response*) url))
63 | 
64 | (defh #"/wiki/(.+)/save$" [page-name 1
65 | 			   title "title"
66 | 			   body "body"]  
67 |   {}
68 |   (update-page page-name title body)
69 |   (redirect (url (str "/wiki/" page-name))))


--------------------------------------------------------------------------------
/demos/pom.xml:
--------------------------------------------------------------------------------
 1 | <project xmlns="http://maven.apache.org/POM/4.0.0" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
 2 |   xsi:schemaLocation="http://maven.apache.org/POM/4.0.0 http://maven.apache.org/maven-v4_0_0.xsd">
 3 |   <modelVersion>4.0.0</modelVersion>
 4 |   <groupId>webjure</groupId>
 5 |   <artifactId>webjure-demos</artifactId>
 6 |   <packaging>war</packaging>
 7 |   <version>0.8-SNAPSHOT</version>
 8 |   <name>webjure-demos</name>
 9 | 
10 |   <parent>
11 |     <groupId>webjure</groupId>
12 |     <artifactId>webjure-top</artifactId>
13 |     <version>0.8-SNAPSHOT</version>
14 |     <relativePath>../pom.xml</relativePath>
15 |   </parent>
16 | 
17 |   <dependencies>
18 |     <dependency>
19 |       <groupId>webjure</groupId>
20 |       <artifactId>webjure</artifactId>
21 |       <version>${project.version}</version>
22 |     </dependency>
23 | 
24 |     <dependency>
25 |       <groupId>org.apache.derby</groupId>
26 |       <artifactId>derby</artifactId>
27 |       <version>10.4.1.3</version>
28 |     </dependency>
29 | 
30 |     <dependency>
31 |       <groupId>swank-clojure</groupId>
32 |       <artifactId>swank-clojure</artifactId>
33 |       <version>1.2.1</version>
34 |     </dependency>
35 |     
36 |     <dependency>
37 |       <groupId>org.apache.xmlgraphics</groupId>
38 |       <artifactId>fop</artifactId>
39 |       <version>1.0</version>
40 |     </dependency>
41 | 
42 |   </dependencies>
43 | 
44 |   <build>
45 |     <plugins>
46 |       <plugin>
47 | 	<groupId>com.theoryinpractise</groupId>
48 | 	<artifactId>clojure-maven-plugin</artifactId>
49 | 	<version>1.3.3</version>
50 | 	<configuration>
51 | 	  <clojureOptions>-Dwebjure.cpt.path=${basedir}/src/main/resources</clojureOptions>
52 | 	</configuration>
53 | 	<executions>
54 | 	  <execution>
55 | 	    <phase>compile</phase>
56 | 	    <goals>
57 |               <goal>compile</goal>
58 | 	    </goals>
59 | 	  </execution>
60 | 	</executions>
61 |       </plugin>
62 |       <plugin>
63 | 	<groupId>org.mortbay.jetty</groupId>
64 | 	<artifactId>maven-jetty-plugin</artifactId>
65 |       </plugin>
66 |     </plugins>
67 |   </build>
68 | 
69 | </project>  
70 | 


--------------------------------------------------------------------------------
/webjure/src/webjure/sql.clj:
--------------------------------------------------------------------------------
 1 |  
 2 | (ns webjure.sql
 3 |     (:refer-clojure))
 4 | 
 5 | (defn register-driver [drv]
 6 |   (. Class (forName drv)))
 7 | 
 8 | (defn connect 
 9 |   ([url] (. java.sql.DriverManager (getConnection url)))
10 |   ([url user pass] (. java.sql.DriverManager (getConnection url user pass))))
11 | 
12 | 
13 | (defn prepare-statement [#^java.sql.Connection con query query-args]
14 |   (let [stmt (.prepareStatement con query)]
15 |     ;; Set query arguments
16 |     (doseq [i (range 0 (count query-args))]
17 |       (.setObject stmt (+ i 1) (nth query-args i)))
18 |     stmt))
19 | 
20 |   
21 | (defn #^{:private true}
22 |   dbg [& items]
23 |   (. (. System err) (println (reduce str (map str items)))))
24 | 
25 | ;; Execute query and return results as a list of lists.
26 | ;; Result set metadata is attached to the returned list.
27 | (defn query [#^java.sql.Connection con query & query-args]
28 |   (let [stmt (prepare-statement con query query-args)
29 |         result-set   (. stmt (executeQuery))
30 | 	metadata     (. result-set (getMetaData))
31 | 	column-count (. metadata (getColumnCount))
32 | 	columns      (doall (map (fn [i]
33 | 				     [(. metadata (getColumnName i))
34 | 				      (. metadata (getColumnClassName i))]) (range 1 (+ 1 column-count))))]
35 |     (loop [acc []
36 | 	   row-count 0]	   
37 |       (if (= false (. result-set (next)))
38 | 	(let [result-list acc]
39 | 	  (with-meta result-list {:columns columns :rows row-count}))
40 | 	(recur (conj acc (doall (map (fn [i] (. result-set (getObject i)))
41 | 						     (range 1 (+ 1 column-count)))))
42 | 	       (+ 1 row-count))))))
43 | 
44 | (defn update [#^java.sql.Connection con update & update-args]
45 |   (let [stmt (prepare-statement con update update-args)]
46 |     (. stmt (executeUpdate))
47 |     (. stmt (close))))
48 | 
49 | (defn call-with-tx [#^java.sql.Connection con func]
50 |   (let [autocommit (. con (getAutoCommit))]
51 |     (when autocommit
52 |       (. con (setAutoCommit false)))
53 |     (try (func)
54 | 	 (. con (commit))
55 | 	 (catch java.sql.SQLException se
56 | 		(. con (rollback))
57 | 		false))
58 |     (when autocommit
59 |       (. con (setAutoCommit true)))))
60 |     
61 | 


--------------------------------------------------------------------------------
/webjure/src/webjure/xml/feeds.clj:
--------------------------------------------------------------------------------
 1 | 
 2 | ;; Working with XML-based feed formats
 3 | 
 4 | (ns webjure.xml.feeds
 5 |     (:refer-clojure)
 6 |     (:use webjure.xml))
 7 | 
 8 | (defn parse-atom1-link [link-node]
 9 |   (parse link-node
10 | 	 {}
11 | 	 (attr "href" (collect-as :url #(.getValue %)))
12 | 	 (attr "rel" (collect-as :rel #(.getValue %)))))
13 | 
14 | (defn parse-atom1-entry [entry-node]
15 |   (parse entry-node 
16 | 	 {:links {}}
17 | 	 (<> "title" (collect-as :title text))
18 | 	 (<>* "link" (modify-key :links #(let [lnk (parse-atom1-link %2)]
19 | 					   (assoc %1 (lnk :rel) lnk))))
20 | 
21 | 	 (<>? "author"
22 | 	      (<>? "email" (collect-as :email text))
23 | 	      (<>? "name" (collect-as :author text)))))
24 | 
25 | (defn load-atom1-feed [file-or-istream]
26 |   (parse
27 |    (. (load-dom file-or-istream) (getDocumentElement))
28 |    {:entries []}
29 |    (<> "title" (collect-as :title text))
30 |    (<>? "subtitle" (collect-as :subtitle text))
31 |    (<>* "entry" 
32 | 	(modify-key :entries #(conj %1 (parse-atom1-entry %2))))))
33 | 
34 | 
35 | ;; example modified from Wikipedia:
36 | (def +atom-test-xml+
37 |      "<?xml version=\"1.0\" encoding=\"utf-8\"?>
38 | <feed xmlns=\"http://www.w3.org/2005/Atom\">
39 |  
40 |  <title>Example Feed</title>
41 |  <subtitle>A subtitle.</subtitle>
42 |  <link href=\"http://example.org/feed/\" rel=\"self\"/>
43 |  <link href=\"http://example.org/\"/>
44 |  <updated>2003-12-13T18:30:02Z</updated>
45 |  <author>
46 |    <name>John Doe</name>
47 |    <email>johndoe@example.com</email>
48 |  </author>
49 |  <id>urn:uuid:60a76c80-d399-11d9-b91C-0003939e0af6</id>
50 |  
51 |  <entry>
52 |    <title>Atom-Powered Robots Run Amok</title>
53 |    <link href=\"http://example.org/2003/12/13/atom03\"/>
54 |    <id>urn:uuid:1225c695-cfb8-4ebb-aaaa-80da344efa6a</id>
55 |    <updated>2003-12-13T18:30:02Z</updated>
56 |    <summary>Some text.</summary>
57 |  </entry>
58 | 
59 |  <entry>
60 |    <title>Webjure gains preliminary support form feeds</title>
61 |    <link href=\"http://example.org/2008/11/18/story\"/>
62 |    <id>urn:uuid:this-is-my-story-and-im-sticking-to-it-2008118tt</id>
63 |    <summary>We can parse these.</summary>
64 |  </entry>
65 | </feed>")


--------------------------------------------------------------------------------
/webjure/src/main/resources/crud/generic-listing-template.cpt:
--------------------------------------------------------------------------------
 1 | <html>
 2 |   <head> 
 3 |     <script type="text/javascript" src="https://ajax.googleapis.com/ajax/libs/jquery/1.6.4/jquery.min.js"> </script> 
 4 | 
 5 |     <style cpt:include="crud-styles.cpt"/>
 6 |   </head>
 7 |   <body>
 8 |     <table cpt:let="field-label (fn [f] (or (get (get (:fields here) f) :label) (name f)))">
 9 |       <tr class="header">
10 | 	<td cpt:repeat="[label field] (map (fn [x] [(field-label x) x]) (:list-fields here))"
11 | 	    cpt:attributes='(listing-header-sort-attributes here field)'>
12 | 	  $label
13 | 	</td>
14 |       </tr>
15 |       <tr class="data" 
16 | 	  cpt:repeat="[row primary-key foreign-keys] (:rows here)" 
17 | 	  onclick="document.location.pathname += '/$primary-key'">
18 | 	<td cpt:repeat="[col {lnk :listing-link-to join :join edit :inline-edit :as field-options} field] (map (fn [row f] [row (get (:fields here) f) f]) row (:list-fields here))">
19 | 	  <cpt:block cpt:when="(and col lnk)">
20 | 	    <a class="listingLink" cpt:attributes="(lnk (foreign-keys (:table join)) col)">$(render-list-view col)</a>
21 | 	  </cpt:block>
22 | 	  <cpt:block cpt:when="(not (and col lnk))">
23 | 	    <cpt:block cpt:when="(not (nil? edit))">
24 | 	      $@(render-inline-edit-view edit field col)		      
25 | 	    </cpt:block>
26 | 	    <cpt:block cpt:when="(nil? edit)">
27 | 	      $@(render-list-view col)
28 | 	    </cpt:block>
29 | 	  </cpt:block>
30 | 	</td>
31 |       </tr>
32 |       <tr class="paging">
33 | 	<td cpt:attributes='{"colspan" (count (:list-fields here))}'>
34 | 	  <span cpt:when="(> (:start here) 0)">
35 | 	    <a href="$(page-link here (dec (/ (:start here) (:limit here))))">&lt; previous</a>
36 | 	  </span>
37 | 
38 | 	  <span cpt:repeat="page (range 0 (/ (:total-rows here) (:limit here)))">
39 | 	    <a cpt:when="(not (= (:start here) (* page (:limit here))))"
40 | 	       href="$(page-link here page)">$(+ page 1)</a>
41 | 	    <span cpt:when="(= (:start here) (* page (:limit here)))"
42 | 		  cpt:replace="(+ page 1)">pagenum</span>
43 | 	  </span>
44 | 
45 | 	  <span cpt:when="(&lt; (+ (:start here) (:limit here)) (:total-rows here))">
46 | 	    <a href="$(page-link here (inc (/ (:start here) (:limit here))))">next &gt;</a>
47 | 	  </span>
48 | 	    
49 | 	</td>
50 |       </tr>
51 |     </table>
52 | 
53 |     $@(webjure.profiler/inject-profiler-html)
54 |   </body>
55 | </html>
56 | 


--------------------------------------------------------------------------------
/webjure/src/webjure/json.clj:
--------------------------------------------------------------------------------
 1 | 
 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 3 | ;; JSON (JavaScript Object Notation) serialization support for Webjure
 4 | ;;
 5 | ;; Author: Tatu Tarvainen
 6 | ;; Since: 2008-11-23 
 7 | ;; Time-stamp: <2009-05-12 14:19:49>
 8 | 
 9 | (ns webjure.json
10 |     (:refer-clojure))
11 | 
12 | (defn #^{:private true} determine-serializer [_ thing]
13 |   (cond 
14 |    (nil? thing) :null
15 |    (map? thing) :map
16 |    (coll? thing) :array
17 |    (string? thing) :string
18 |    :default :default))
19 | 
20 | (defmulti #^{:doc "Serialize Clojure data structure in JSON format to output. Takes a writer and an object."}
21 | 	  serialize determine-serializer)
22 | 
23 | (defn #^{:doc "Serialize Clojure data structure in JSON format to a string."}
24 |   serialize-str [thing]
25 |   (let [out (new java.io.StringWriter)]
26 |     (serialize out thing)
27 |     (str out)))
28 | 
29 | (defmethod serialize :null [out _]
30 |   (.append out "null"))
31 | 
32 | (defmethod serialize :map [out the-map]
33 |   (.append out "{")
34 |   (loop [first-entry true
35 | 	 entries the-map]
36 |     (when-let [[key value] (first entries)]
37 | 	(do 
38 | 	  (if (not first-entry)
39 | 	    (.append out ", "))
40 | 	  (serialize out key) 
41 | 	  (.append out ": ")
42 | 	  (serialize out value)
43 | 	  (recur false (rest entries)))))
44 |   (.append out "}"))
45 | 
46 | (def +control-chars-replacements+ 
47 |      [["\\" "\\\\"]
48 |       ["\"" "\\\""]
49 |       ["\b" "\\b"]
50 |       ["\f" "\\f"]
51 |       ["\n" "\\n"]
52 |       ["\r" "\\r"]
53 |       ["\t" "\\t"]])
54 | 
55 | (defmethod serialize :string [out string]
56 |   (.append out "\"")
57 |   (loop [string string
58 |          ctrls +control-chars-replacements+]
59 |     (if (empty? ctrls)
60 |       (.append out string)
61 |       (let [[ctrl replacement] (first ctrls)]
62 | 	(recur (.replace string ctrl replacement)
63 | 	       (rest ctrls)))))
64 |   (.append out "\""))
65 | 
66 | (defmethod serialize :default [out something]
67 |   (.append out (str something)))
68 | 
69 | (defmethod serialize :array [out things]
70 |   (.append out "[")
71 |   (loop [first-element true
72 | 	 things (seq things)]
73 |     (if (empty? things)
74 |       (.append out "]")
75 |       (do (if (not first-element)
76 | 	    (.append out ", "))
77 | 	  (serialize out (first things))
78 | 	  (recur false (rest things))))))
79 | 
80 | 


--------------------------------------------------------------------------------
/demos/src/main/webapp/resource/default.css:
--------------------------------------------------------------------------------
  1 | /** BASIC */
  2 | 
  3 | body {
  4 | 	margin: 10px 0;
  5 | 	font: normal small Arial, Helvetica, sans-serif;
  6 | 	color: #83895C;
  7 | }
  8 | 
  9 | h1, h2, h3, h4, h5, h6 {
 10 | 	margin-top: 0;
 11 | 	padding-top: 0;
 12 | 	font-family: "Trebuchet MS", Arial, Helvetica, sans-serif;
 13 | 	color: #CC6600;
 14 | }
 15 | 
 16 | a {
 17 | 	text-decoration: none;
 18 | 	color: #CC6600;
 19 | 	border-bottom: 1px solid #EBA45E;
 20 | }
 21 | 
 22 | a:hover {
 23 | 	border: none;
 24 | }
 25 | 
 26 | /** HEADER */
 27 | 
 28 | #header {
 29 | 	width: 700px;
 30 | 	height: 80px;
 31 | 	margin: 0 auto;
 32 | }
 33 | 
 34 | #header h1 {
 35 | 	margin: 0;
 36 | 	padding: 30px 10px 0 20px;
 37 | 	text-transform: lowercase;
 38 | 	font-size: 36px;
 39 | 	letter-spacing: -.05em;
 40 | 	color: #83895C;
 41 | }
 42 | 
 43 | #header h2 {
 44 | 	display: none;
 45 | }
 46 | 
 47 | /** MENU */
 48 | 
 49 | #menu {
 50 | 	width: 700px;
 51 | 	margin: -2.25em auto 0 auto;
 52 | }
 53 | 
 54 | #menu ul {
 55 | 	margin: 0;
 56 | 	padding: 0;
 57 | 	list-style: none;
 58 | 	text-align: right;
 59 | }
 60 | 
 61 | #menu li {
 62 | 	display: inline;
 63 | }
 64 | 
 65 | #menu a {
 66 | 	padding: 0 10px 0 11px;
 67 | 	border: none;
 68 | 	border-left: 1px solid #83895C;
 69 | 	color: #83895C;
 70 | }
 71 | 
 72 | #menu a:hover {
 73 | 	color: #83895C;
 74 | }
 75 | 
 76 | #menu .first a {
 77 | 	border: none;
 78 | }
 79 | 
 80 | /** CONTENT */
 81 | 
 82 | #content {
 83 | 	width: 720px;
 84 | 	margin: 0 auto;
 85 | 	background: #EFEBDF url(images/img01.gif) repeat-y left top;
 86 | }
 87 | 
 88 | #content * {
 89 | 	line-height: 140%;
 90 | }
 91 | 
 92 | #columnA {
 93 | 	float: left;
 94 | 	width: 440px;
 95 | 	padding: 25px 20px 0 30px;
 96 | 	background: url(images/img02.gif) no-repeat left top;
 97 | }
 98 | 
 99 | #columnB {
100 | 	float: right;
101 | 	width: 200px;
102 | 	padding: 25px 20px 0 10px;
103 | 	background: url(images/img03.gif) no-repeat left top;
104 | }
105 | 
106 | #columnB * {
107 | 	color: #EFEBDF;
108 | }
109 | 
110 | #columnB ul {
111 | 	margin-left: 0;
112 | 	padding-left: 0;
113 | 	list-style: inside circle;
114 | }
115 | 
116 | #columnB a {
117 | 	border-bottom-color: #EBD8B7;
118 | 	color: #FFFFFF;
119 | }
120 | 
121 | /** FOOTER */
122 | 
123 | #footer {
124 | 	width: 720px;
125 | 	height: 50px;
126 | 	margin: 0 auto;
127 | 	background: url(images/img04.gif) no-repeat left top;
128 | }
129 | 
130 | #footer p {
131 | 	margin: 0;
132 | 	padding: 35px 0 0 20px;
133 | 	font: bold 9px Arial, Helvetica, sans-serif;
134 | }


--------------------------------------------------------------------------------
/webjure/src/webjure/csv.clj:
--------------------------------------------------------------------------------
 1 | 
 2 | (ns webjure.csv
 3 |   (:refer-clojure))
 4 | 
 5 | (defn csv-format 
 6 |   "Format comma separated values (CSV) to the given output.
 7 |    The output must be a java.io.Writer.
 8 | 
 9 |    The CSV is a map containing the following keys:
10 |    :rows             Sequence of rows to format, each row is a seq 
11 |                      of values or a user object (*).
12 |    :separator        Separator between values, defaults to \\; if omitted.
13 |    :line-separator 
14 |    :headers          Sequence of headers for the values, should have the
15 |                      same amount of values as each row. May be omitted if
16 |                      the values are simple seqs.
17 |  
18 |    A header is a map containing the following keys:
19 |    :label            Optional label for the for column.
20 |    :format           Function (1-arg) to format the values, defaults to 
21 |                      clojure.core/str if omitted.
22 |    :accessor         Function (1-arg) to get the column value from the row
23 |                      object. Used only if the rows are user objects.
24 |    
25 |    A header row is formatted in the output if any of the given headers 
26 |    contain a label.
27 | 
28 |    (*) If the rows are not seqs of values but user objects (a map, some Java 
29 |        object, etc), the headers must be specified and each header must have
30 |        the :accessor defined.
31 | "
32 |   [#^java.io.Writer output csv]
33 |   (let [headers (or (:headers csv) [])
34 | 	separator (or (:separator csv) \;)
35 | 	output-header-row (not (nil? (some :label headers)))
36 | 	write-line (fn [values]
37 | 		     (.append output
38 | 			      (str (reduce str
39 | 					   (butlast (interleave values (repeat separator)))) "\n"))
40 | 		     ;; for debugging purposes
41 | 		     (.flush output))
42 | 	fmt (fn [column value]
43 | 	      ;; apply the column specific formatting function (or str)
44 | 	      (let [hdr (nth headers column {})]
45 | 		((or (:format hdr) str) value)))]
46 | 
47 |     ;; Output header row, if necessary 
48 |     (if output-header-row
49 |       (write-line (map :label headers)))
50 | 
51 |     ;; Output all the rows
52 |     (doseq [row (:rows csv)]
53 |       (write-line
54 |        (if (or (vector? row) (seq? row))
55 | 	 ;; Row is a sequence or vector of values, format all values
56 | 	 (loop [acc []
57 | 		column 0 
58 | 		[value & values] (replace {nil ::csv-no-value} row)]
59 | 	   (if (nil? value)
60 | 	     acc
61 | 	     (recur (conj acc (fmt column (if (= ::csv-no-value value) nil value)))
62 | 		    (+ 1 column)
63 | 		    values)))
64 | 
65 | 	 ;; Row is a user object, loop headers and use accessors to get values
66 | 	 (loop [acc []
67 | 		column 0
68 | 		[hdr & headers] headers]
69 | 	   (if (nil? hdr)
70 | 	     acc
71 | 	     (recur (conj acc (fmt column ((:accessor hdr) row)))
72 | 		    (+ 1 column)
73 | 		    headers))))
74 | 	 ))))
75 | 
76 | 	


--------------------------------------------------------------------------------
/changes.txt:
--------------------------------------------------------------------------------
 1 | 2009-05-12:
 2 | 
 3 |   Upgrade to Clojure 1.0.0. Mostly just removed nil punning usage.
 4 | 
 5 | 2008-11-23:
 6 | 
 7 |   Removed evil re-defing of *handlers*. It is now a ref.
 8 |   
 9 |   defh can now take a regex pattern instead of string.
10 |   If a regular expression matches, it is used before any string matches.
11 | 
12 |   Added support for binding path components. If the accessor in defh
13 |   if a Number it is considered a regular expression group index.
14 |   You can also use :group key in a map accessor.
15 | 
16 |   Fixed multiple request parameters bug. 
17 | 
18 |   Added JSON serialization support. See webjure.json namespace.
19 |   Also supported in defh automagic by using {:output :json} and 
20 |   anything the body returns will be JSONified and sent to the client
21 |   with application/json content type.
22 | 
23 | 
24 | 2008-11-18:
25 | 
26 |   Refactored XML parsing and feed support.
27 |   They are now in webjure.xml and webjure.xml.feeds respectively.
28 | 
29 |   Added an Atom feed test (Clojure news) to demos.
30 | 
31 | 2008-11-17:
32 | 
33 |   Sync up with Clojure changes. With thanks to Mats-Ola Persson.
34 | 
35 | 2008-10-18:
36 | 
37 |   Clojure is now one year old!
38 |   Update webjure to work with the latest revision.
39 | 
40 |   Removed 'require' as it conflicts with clojure. The module functionality
41 |   from clojure should be used instead.
42 | 
43 |   Organize code to new namespaces: webjure, webjure.sql, webjure.html
44 | 
45 |   
46 | 2008-01-27:
47 | 
48 |   Refactored all demos to use the new functionalities.
49 | 
50 |   ----
51 |   Added (base-url) which determines the application base url from the request.
52 | 
53 | 2008-01-26:
54 | 
55 |   sql.clj:
56 |   Added (update con update-clause ...update-args...).
57 |   Added (with-tx con func) with commit on success and rollback on SQLException.
58 | 
59 |   ----
60 |   Added automagic handler definition macro (defh url request-bindings options ...body...).
61 |   url is the url-pattern to publish the handler to.
62 |   request-bindings is a sequence as defined by request-bind.
63 |   options is a map of options (may be nil), currently only supported is {:type :html} which
64 |   automagically send the last evaluated value of body as an html output (see html-format)
65 |   
66 |   ----
67 |   Added ability to call application init fn when WebjureServlet has been initialized.
68 |   The fn is specified as 'init' parameter in the servlet config using the full name (example: webjure-demos/init).
69 | 
70 |   ----
71 |   Added working version of xmlparse.clj which provides declarative DOM tree parsing and
72 |   value extraction. This is mostly a rewrite of my old JScheme code that did the same (more or less).
73 |   Also a simple atom v1.0 feed parser based on the former (feed.clj). 
74 | 
75 |   ---- 
76 |   Added (session-get attribute initial-value?) which gets the given attribute value from session.
77 |   If the optional initial-value is provided and the attribute has no value in the session,
78 |   the initial-value is stored in the session and returned.
79 | 
80 |   ----
81 |   Added (request-bind [bindings] ...body...) which binds GET/POST parameters to variables.
82 |   bindings = binding 
83 |            | binding bindings
84 | 
85 |   binding = var "name"
86 |           | var {...options...} 
87 |  
88 |   Currently available options are: 
89 |     :name (the request parameter name, required)
90 |     :multiple (if true, the value is returned as a seq)
91 |     :validator (a form which returns a validated value from the request parameter value)
92 |    
93 | 
94 | 2008-01-23
95 | 
96 |   Removed handler parameters. Instead *request* and *response* globals are bound during 
97 |   handler calls.
98 | 


--------------------------------------------------------------------------------
/webjure/src/main/resources/crud/crud-styles.cpt:
--------------------------------------------------------------------------------
 1 | <?xml version="1.0" encoding="utf-8"?>
 2 | <style><![CDATA[
 3 |       tr.header { background-color: lightGray; }
 4 |       tr.header td { padding-right: 24px; }
 5 |       td.sortAscending { 
 6 |          background: url('data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABmJLR0QA/wD/AP+gvaeTAAAA20lEQVR42rWSMQrCQBBF3wZP4gUkF/EAihfYpFNIlcpKSLpEsA6KhRDQwhMIahNsLWy09A5rs9EYWRMifliYGZj5f/6ssLtuD5jzQj9bRwtqwsqbs3UkgLg0rBKtPLC7rqIBrDwoKGg2wIBGqv6CWkrkLwxSs8gmSiSgTpdMlYbIOtKFbma1WwIwHkwAnMJJRdUZnU7bfhb8xAOIb/eraYW3ZwFTwNHMAGwOKbNtZFIsgFDn4YcXm0Oq/MRTfuIpgweBrgfFnyhz2cfz/tvKATDUzKOiQarCaOMZH3A8S96taPbNAAAAAElFTkSuQmCC') center right no-repeat; 
 7 |       }
 8 |       td.sortDescending { 
 9 |          background: url('data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABmJLR0QA/wD/AP+gvaeTAAAA00lEQVR42r2TMQrCQBBF34pHsNRDeBEPoOQCm/RWVlZC7LKCtQQshIApPIGgNmJrYRPL3GFtJqJRdI3oL2fnz//zmVWA5REKR9SkWQFjqY2pgFCchH8nqzcZ2E/y+CmsS5P+RkGLiq7iRAP2cNrb0hDtYl0JmcV6DsDQGwH4gHG5SiVKZjDrX4tDb8Q5z2g2WncD2p2gC8Q3/F4NmAC+KAOQbhOmq+iZYAywX0ZKHMZ1eZiIskm3Cbvj5uXe7U5gbz9TEZg559lbcskBhQMDFDt/hAsegULD0k+hhQAAAABJRU5ErkJggg==') center right no-repeat; 
10 |       }
11 |       tr.data:hover { background-color: Wheat; }
12 |       span.sqlNull { 
13 |          font-size: 65%; 
14 | 	 font-variant: small-caps; 
15 | 	 color: gray; 	
16 | 	 text-align: center;
17 | 	 margin-left: auto;
18 | 	 margin-right: auto;
19 | 	 display: block;
20 |       }
21 |       span.center {
22 |          text-align: center;
23 | 	 margin-left: auto;
24 | 	 margin-right: auto;
25 | 	 display: block;
26 |       }
27 |       tr.paging td { text-align: center; }
28 |       a.listingLink {
29 |          background: url('data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAAAXNSR0IArs4c6QAAAAZiS0dEAP8A/wD/oL2nkwAAAAlwSFlzAAALEwAACxMBAJqcGAAAAAd0SU1FB9sFGgYgIgcAZzMAAAH0SURBVDjLlZMxaBNxFMZ/d0kuufTSNFYTFBuhWK0RFZFGFzscNUNpBYcsgSwOTi4uioMQCBTTpYtLwUFbECFDhlaEIoIOWutaig1IeokWxZpYLsn1QtpzMSVpFJM3Pd6f73vfn/d9AoAaHbXosl6n3woA9sZgMjbRMXjh2eJ+b29+uHPjrvA/8ExmukWtvQvVXmDg4BKxQ7AduAqkgGgnCgRAaVpiB3yBQOCC7JYTG7kNgPS/CGKyLIcMwxh2upw+c8d8I7kkS3JKfjWiiifPDZ6ZezyX0LIFgHQbgdwjD6sR9abopr9S0x0elzesm9t7gigi9loeb1ARLo+PhOq7u4mvnzfbFRgVwxY45vcNjgSlKhXc9ChVKoiiiCzK2Jw2Tl8a4pv2PfRjc+tWG0FvX2+1olf11eU1Z6VeRnF4rHJdNwULq7/viPtsOERuVaOwXtBqRu15C8GD+Xsk46lXS4tLSqlYGlI87mBZr350K66a3SF5rkXGxn/5t4++f7Gi5dbyU8C80LDyZGyCYvmnAJCMp/iyVeD44YFDgAOwgLHgieBDWXbtrX/KTgFPLl6/XfvrGRc+ZJh9+Qig+GckATt5LV8AnjbAbUZKxlOET11hJbt8kLMGvAPuz2SmZ9XoqNlsmP0vdBOmknm+NY3NCeumfgP/PKiD+URMVQAAAABJRU5ErkJggg==') center right no-repeat;
30 | 	 text-decoration: none;
31 | 	 padding-right: 20px;
32 |       }
33 | 
34 |       span.editable span.center {
35 |         display: inline !important;
36 |       }
37 |       span.editable span.sqlNull {
38 |         display: inline !important;
39 |       }
40 | 
41 |       span.editable span.current {
42 |          padding-right: 20px;
43 |       }
44 |       span.editable:hover span.current {
45 |          background: url('data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAAGXRFWHRTb2Z0d2FyZQBBZG9iZSBJbWFnZVJlYWR5ccllPAAAAiRJREFUeNqEU19IU2EU/9275XK7GVHKROslTbMRDheGPuy5YOBEFkG5CKxu9Bw+rIfoxYciqNCHFNsoCIp69DESFKRIKisLE7Nt7k8mybbu3Xfvbve7dm/3bjF/cL7L+bi/c37nnO8wiqIgFouNAuBRHWMtm3OXyy/t9JBlmQ+Hw1XZ0WiU/+zyoS3/2hKEpYckSZqTzWaRyWQ0S6fTSKVSmlEEAgGACPxSTXvUd2bIqoAQojkMw1iyUp+WSOGyy+jc+R2w2QanHj5pcSPRaygwB/ifiZtZfHx+Cx0nT6DVM4sDXLwnQQ7NGAqKxaIlAM2qf+scwMLTERzt6wdZuQBFWIS72Q8xJ/QIhV1NFQHM4HaU8PbxDXgHThnkXL4NyW97YXc24PiVuwmtBFEUK0qgNc8/ulZGbkVipQMl2Y4j/RHM3evb6oGugGVZjey0SXjzYBhdobNlZA9ktV2e03dwfeT2vymYFVC8mozAF7oEKRmxkIkooXPwPhx19Qanoge5tSXsaWxCrdsLogxjYz2H5GojinkB3vOTKKjyHWbV5Qoy71/goD8EaX1ZvdkNrvkifv/Ka2RBqTFUWhTo74Dix6dZtHcfQ+FnEhvxr1h8OQX/1WcQ1bzmIekcSwnq4LG6/AHTEzfh3Lcf9Yd70cXHQNhaMH9fpA7Kib/7shWA7gKdgIvjcG58AQxrq7pY9F/KUUqyEWAsGAxut84V602PPwIMAJxGDk+gQRv5AAAAAElFTkSuQmCC') center right no-repeat;
46 | 	 text-decoration: none;
47 | 	 padding-right: 20px;
48 | 	 
49 |       }
50 |     ]]></style>


--------------------------------------------------------------------------------
/webjure/src/webjure/profiler.clj:
--------------------------------------------------------------------------------
  1 | ;; Server page generation profiling support.
  2 | ;;
  3 | ;; Some client side scripts, styles and templates copied from:
  4 | ;; GAE Mini Profiler (https://github.com/kamens/gae_mini_profiler)
  5 | ;; which is itself heavily inspired by MVC mini profiler (http://code.google.com/p/mvc-mini-profiler/)
  6 | ;;
  7 | 
  8 | (ns webjure.profiler
  9 |   (:refer-clojure)
 10 |   (:use webjure)
 11 |   (:use webjure.cpt))
 12 | 
 13 | (def *profiler* nil)
 14 | 
 15 | (defprotocol Profiler
 16 |   (start-step [this name])
 17 |   (end-step [this name])
 18 |   (report [this])
 19 |   (id [this]))
 20 | 
 21 | ;; Empty profiler implementation to use when *profiler* is nil
 22 | (extend-protocol Profiler
 23 |   nil
 24 |   (start-step [this name] nil)
 25 |   (end-step [this name] nil)
 26 |   (report [this] nil)
 27 |   (id [this] nil)
 28 |   )
 29 | 
 30 | (deftype DefaultProfiler [^{:volatile-mutable true } steps
 31 | 			  ^{:volatile-mutable true} current-step
 32 | 			  ^{:volatile-mutable true} profiler-id
 33 | 			  ]
 34 | 
 35 |   Profiler
 36 |   (start-step [this name]
 37 | 	      (set! current-step {:name name
 38 | 				  :start (System/currentTimeMillis)
 39 | 				  :parent current-step}))
 40 | 
 41 |   (end-step [this name]
 42 | 	    (if (not (= name (:name current-step)))
 43 | 	      (throw (IllegalArgumentException. "Ending an unknown step."))
 44 | 	      (let [finished-step (assoc (dissoc current-step :parent)
 45 | 				    :end (System/currentTimeMillis))
 46 | 		    parent (:parent current-step)]
 47 | 		(if parent
 48 | 		  (set! current-step
 49 | 			(assoc parent :children
 50 | 			       (conj (or (:children parent) []) finished-step)))
 51 | 		  (do (set! steps (conj steps finished-step))
 52 | 		      (set! current-step nil))))))
 53 |   
 54 |   (report [this] steps)
 55 |   
 56 |   (id [this]
 57 |       (or profiler-id
 58 | 	  (set! profiler-id (str "p-" (System/currentTimeMillis) "-" (rand-int Integer/MAX_VALUE))))))
 59 | 
 60 | 
 61 | (defn print-profiler-report
 62 |   ([report] (print-profiler-report report 0))
 63 |   ([report indent]
 64 |      (doseq [{:keys [name start end children]} report]
 65 |        (println (str (apply str (repeat indent " "))
 66 | 		     name
 67 | 		     " "
 68 | 		     (- end start) " ms"))
 69 |        (print-profiler-report children (+ indent 2)))))
 70 | 
 71 | (defn inject-profiler-html []
 72 |   (let [id (id *profiler*)]
 73 |     (if (nil? id)
 74 |       "" ;; Not profiling
 75 |       (str "<link rel=\"stylesheet\" type=\"text/css\" href=\"/_webjure_profiler/profiler.css\" />\n"
 76 | 	   "<script type=\"text/javascript\" src=\"/_webjure_profiler/profiler.js\"></script>\n"
 77 | 	   "<script type=\"text/javascript\">WebjureMiniProfiler.init(\"" id "\", false)</script>"))))
 78 | 
 79 | (defn duration-of [{start :start end :end}]
 80 |   (- end start))
 81 | 
 82 | (defn format-profiler-report
 83 |   ([steps] (format-profiler-report steps 0))
 84 |   ([steps indent]
 85 |      (if (nil? steps)
 86 |        nil
 87 |        (loop [acc []
 88 | 	      [step & steps] steps]
 89 | 	 (if (nil? step)
 90 | 	   acc
 91 | 	   (recur (concat acc [{:name (:name step)
 92 | 				:indent indent
 93 | 				:total-ms (duration-of step)
 94 | 				:own-ms (- (duration-of step)
 95 | 					   (reduce + 0 (map duration-of (:children step))))}]
 96 | 			  (format-profiler-report (:children step) (+ 1 indent)))
 97 | 		  steps))))))
 98 | 
 99 | (define-template profiler-report "src/main/resources/profiler/report.xml")
100 | 
101 | (defh "/_webjure_profiler/request" [id "id"] {}
102 |   (let [duration #(- (:end %) (:start %))
103 | 	{url :url steps :report} (webjure/session-get id)
104 | 	total (reduce + 0 (map duration steps))]
105 |             
106 |     (webjure/set-response-content-type webjure/*response* "text/html")
107 |     (profiler-report
108 |      (response-writer)
109 |      {:total total
110 |       :url url
111 |       :id id
112 |       :report (format-profiler-report steps)
113 |       })))
114 | 
115 |     
116 | (def *profiler-enabled* (ref (fn [] true)))
117 | 
118 | (defmacro with-request-profiling [& body]
119 |   `(binding [*profiler* (if (@*profiler-enabled*)
120 | 			  (DefaultProfiler. [] nil nil)
121 | 			  nil)]
122 |      (let [url# (webjure/request-path)]
123 |        (with-step url#
124 | 	 (do ~@body))
125 |        (when *profiler*
126 | 	 (webjure/session-set (id *profiler*)
127 | 			      {:url url#
128 | 			       :report (report *profiler*)})))))
129 | 
130 | (defmacro with-step [name & body]
131 |   `(let [name# ~name]
132 |      (start-step *profiler* name#)
133 |      (try 
134 |        ~@body
135 |        (finally (end-step *profiler* name#)))))
136 | 
137 | (define-static-resource "src/main/resources/profiler/profiler.js" "text/javascript"
138 |   "/_webjure_profiler/profiler.js")
139 | 
140 | (define-static-resource "src/main/resources/profiler/profiler.css" "text/css"
141 |   "/_webjure_profiler/profiler.css")
142 | 
143 | 


--------------------------------------------------------------------------------
/webjure/src/main/resources/profiler/profiler.css:
--------------------------------------------------------------------------------
  1 | 
  2 | .g-m-p-corner {
  3 |     padding: 4px;
  4 |     cursor: pointer;
  5 |     text-align: right;
  6 | }
  7 | 
  8 | .g-m-p-corner .ms,
  9 | .g-m-p .ms {
 10 |     color: #777;
 11 | }
 12 | 
 13 | .g-m-p-corner .entry.ajax {
 14 |     border-top: 1px dotted #DDD;
 15 | }
 16 | 
 17 | .g-m-p-corner .entry.expanded {
 18 |     font-weight: bold;
 19 | }
 20 | 
 21 | .g-m-p {
 22 |     min-width: 410px;
 23 |     padding: 9px;
 24 |     padding-bottom: 18px;
 25 | }
 26 | 
 27 | .g-m-p, .g-m-p-corner, .g-m-p-shared {
 28 |     font-family: Helvetica, Arial, sans-serif;
 29 |     font-size: 12px;
 30 |     color: #444;
 31 |     line-height: 18px;
 32 | }
 33 | 
 34 | .g-m-p a, .g-m-p-corner a, .g-m-p-shared a {
 35 |     color: #069;
 36 |     text-decoration: none;
 37 | }
 38 | 
 39 | .g-m-p a.uses_script, .g-m-p-corner a.uses_script, .g-m-p-shared a.uses_script {
 40 |     border-bottom: dotted 1px #069
 41 | }
 42 | 
 43 | .g-m-p, .g-m-p-corner {
 44 |     position: absolute;
 45 |     left: 9px;
 46 |     top: 0px;
 47 | 
 48 |     background: #F7F7F7;
 49 | 
 50 |     border-top: 0;
 51 |     border-left: 1px solid #CCC;
 52 |     border-bottom: 1px solid #DDD;
 53 |     border-right: 1px solid #DDD;
 54 | 
 55 |     box-shadow: 2px 2px 10px rgba(0, 0, 0, 0.25);
 56 |     -moz-box-shadow: 2px 2px 10px rgba(0, 0, 0, 0.25);
 57 |     -webkit-box-shadow: 2px 2px 10px rgba(0, 0, 0, 0.25);
 58 | 
 59 |     -webkit-border-bottom-left-radius: 12px;
 60 |     -moz-border-radius-bottomleft: 12px;
 61 |     border-bottom-left-radius: 12px;
 62 | 
 63 |     -webkit-border-bottom-right-radius: 12px;
 64 |     -moz-border-radius-bottomright: 12px;
 65 |     border-bottom-right-radius: 12px;
 66 | 
 67 |     z-index: 1000;
 68 | }
 69 | 
 70 | .g-m-p .title {
 71 |     font-size: 1.25em;
 72 |     text-align: left;
 73 |     font-weight: bold;
 74 |     border-bottom: 1px solid #CCC;
 75 |     padding: 0;
 76 | }
 77 | 
 78 | .g-m-p .date_and_share {
 79 |     text-align: right;
 80 |     margin-bottom: 18px;
 81 | }
 82 | 
 83 | .g-m-p .date_and_share .date {
 84 |     font-style: italic;
 85 |     color: #CCC;
 86 | }
 87 | 
 88 | .g-m-p .appstats-link {
 89 |     float:right;
 90 | }
 91 | 
 92 | .g-m-p .url {
 93 |     font-size: 125%;
 94 | }
 95 | 
 96 | .g-m-p .total {
 97 |     float: right;
 98 | }
 99 | 
100 | .g-m-p .dupe {
101 |     font-weight: bold;
102 |     color: red;
103 | }
104 | 
105 | .g-m-p .summary {
106 |     float:right;
107 | }
108 | 
109 | .g-m-p .details {
110 |     max-width: 800px;
111 |     max-height: 500px;
112 |     margin-bottom: 18px;
113 |     overflow: auto;
114 | }
115 | 
116 | .g-m-p .expand.expanded {
117 |     border-bottom: 1px solid #DDD;
118 | }
119 | 
120 | .g-m-p .expand.expanded a {
121 |     text-decoration: none;
122 |     border-bottom: 0;
123 |     font-weight: bold;
124 | }
125 | 
126 | .g-m-p .details table {
127 |     margin-top: 18px;
128 |     border-spacing: 0;
129 |     font-size: 12px;
130 | }
131 | 
132 | .g-m-p .details table tr:nth-child(odd) {
133 |     background-color: #FFF;
134 | }
135 | 
136 | .g-m-p .details table tr:nth-child(even) {
137 |     background-color: #F7F7F7;
138 | }
139 | 
140 | .g-m-p .details table .callers-label {
141 |     color: #CCC;
142 | }
143 | 
144 | .g-m-p .details th, .g-m-p .details th.header {
145 |     font-size: 12px;
146 |     background-color: #F7F7F7;
147 |     font-weight: bold;
148 |     cursor: pointer;
149 |     float: none;
150 |     position: static;
151 | }
152 | 
153 | .g-m-p .details th.headerSortUp,
154 | .g-m-p .details th.headerSortDown {
155 |     text-decoration: underline;
156 | }
157 | 
158 | .g-m-p .details th,
159 | .g-m-p .details td {
160 |     padding-right: 18px;
161 |     vertical-align: top;
162 | }
163 | 
164 | .g-m-p .details .left {
165 |     text-align: left;
166 | }
167 | 
168 | .g-m-p .details .right {
169 |     text-align: right;
170 | }
171 | 
172 | .g-m-p-shared .shared-teaser-container {
173 |     text-align: center;
174 | }
175 | 
176 | .g-m-p-shared .shared-teaser {
177 |     margin-left: auto;
178 |     margin-right: auto;
179 |     height: 400px;
180 |     width: 600px;
181 |     text-align: center;
182 |     padding: 200px 0;
183 |     font-size: 24px;
184 |     font-weight: bold;
185 | }
186 | 
187 | /* Borrowed from those smart guys @ Fog Creek. Props to Justin & Bobby */
188 | .g-m-p .fancy-scrollbar::-webkit-scrollbar {
189 |   height: 8px;
190 |   width: 8px;
191 | }
192 | .g-m-p .fancy-scrollbar::-webkit-scrollbar-button:start:decrement,
193 | .g-m-p .fancy-scrollbar::-webkit-scrollbar-button:end:increment {
194 |   background: transparent;
195 |   display: none;
196 | }
197 | .g-m-p .fancy-scrollbar::-webkit-scrollbar-track-piece {
198 |   background: transparent;
199 | }
200 | .g-m-p .fancy-scrollbar::-webkit-scrollbar-track-piece:vertical:start {
201 |   -webkit-border-top-left-radius: 4px;
202 |   -webkit-border-top-right-radius: 4px;
203 | }
204 | .g-m-p .fancy-scrollbar::-webkit-scrollbar-track-piece:vertical:end {
205 |   -webkit-border-bottom-left-radius: 4px;
206 |   -webkit-border-bottom-right-radius: 4px;
207 | }
208 | .g-m-p .fancy-scrollbar::-webkit-scrollbar-track-piece:horizontal:start {
209 |   -webkit-border-top-left-radius: 4px;
210 |   -webkit-border-bottom-left-radius: 4px;
211 | }
212 | .g-m-p .fancy-scrollbar::-webkit-scrollbar-track-piece:horizontal:end {
213 |   -webkit-border-top-right-radius: 4px;
214 |   -webkit-border-bottom-right-radius: 4px;
215 | }
216 | .g-m-p .fancy-scrollbar::-webkit-scrollbar-thumb:vertical,
217 | .g-m-p .fancy-scrollbar::-webkit-scrollbar-thumb:horizontal {
218 |   background: #ccc;
219 |   border: 1px solid #aaa;
220 |   -webkit-border-radius: 4px;
221 |   display: block;
222 |   height: 50px;
223 | }


--------------------------------------------------------------------------------
/demos/src/main/clojure/webjure/demos.clj~:
--------------------------------------------------------------------------------
  1 | 
  2 | ;; Demos to be placed here
  3 | 
  4 | (ns webjure-demos
  5 |     (:refer-clojure)
  6 |     (:use webjure)
  7 |     (:use webjure.html)
  8 |     (:use webjure.sql)
  9 |     (:use webjure.xml.feeds))
 10 | 
 11 | 
 12 | (defn dbg [& u]
 13 |   (. (. System err)
 14 |      (println (apply pr-str u))))
 15 | 
 16 | 
 17 | (defh "/index" [] {:output :html}
 18 |   `(:html 
 19 |     (:body 
 20 |      (:h3 "Webjure, a web framework like thing.")
 21 |      (:p "Welcome to webjure, a clojure web framework. Not much is done yet, but feel free "
 22 |          "to look at the demos.")
 23 |      (:ul
 24 |       (:li (:a {:href ~(url "/index")} "This page, a simple sexp markup page"))
 25 |       (:li (:a {:href ~(url "/info" {:some "value" :another "one"})} "Dump request info"))
 26 |       (:li (:a {:href ~(url "/dbtest")} "Database test"))
 27 |       (:li (:a {:href ~(url "/session")} "Session test"))
 28 |       ;;(:li (:a {:href ~(url "/ajaxrepl")} "an AJAX REPL"))
 29 |       (:li (:a {:href ~(url "/clojurenews")} "Clojure news (Atom feed parser test)"))
 30 |       (:li (:a {:href ~(url "/hello/Test")} "Test path binding"))
 31 |       (:li (:a {:href ~(url "/json?foo=bar&quux=baz")} "Return request info as JSON")))
 32 |      
 33 |      (:div {:style "position: relative; left: 50%;"}
 34 |            (:div {:style "text-align: center; width: 300px; position: absolute; left: -150; border: dotted black 2px; background-color: yellow; padding: 10px;"}
 35 |                  (:b "Important notice: ") "Have a nice and RESTful day!"
 36 |                  (:br)
 37 |                  (:div {:style "font-size: small;"} ~(format-date "dd.MM.yyyy hh:mm")))))))
 38 | 
 39 | 
 40 | (defn format-map-as-table [keylabel valuelabel themap]
 41 |   `(:table
 42 |     (:tr (:th ~keylabel) (:th ~valuelabel))
 43 |     ~@(map (fn [key]
 44 | 	       `(:tr (:td ~key) (:td ~(reduce (fn [x y] (str x ", " y)) (get themap key)))))
 45 | 	   (keys themap))))
 46 | 
 47 | (defn format-table [headers values & actions]
 48 |   `(:table
 49 |     (:tr 
 50 |      ~@(map (fn [hdr] `(:th ~hdr)) headers)
 51 |      (:th "Actions"))
 52 |     
 53 |     ~@(map (fn [row] `(:tr 
 54 | 		       ~@(map (fn [v] `(:td ~(str v))) row)
 55 | 		       (:td ~@(map (fn [action]
 56 |                                      `(:a {:href ~((second action) row)}
 57 |                                           ~(first action))) actions))
 58 | 		       ))
 59 | 	   values)))
 60 | 
 61 | (defh "/info*" [] {:output :html}
 62 |   `(:html 
 63 |     (:body
 64 |      (:h3 "Request headers")
 65 |      ~(format-map-as-table "Name" "Values" (request-headers))
 66 |      (:br)
 67 |      
 68 |      (:h3 "Request parameters")
 69 |      ~(format-map-as-table "Name" "Values" (request-parameters))
 70 |      (:br)
 71 |                                              
 72 |      (:h3 "Path info")
 73 |      (:p ~(request-path)))))
 74 | 
 75 | 
 76 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 77 | ;; db test using derby tours
 78 | ;;
 79 | 
 80 | 
 81 | (defn connect-to-db [location]
 82 |   (do (register-driver "org.apache.derby.jdbc.EmbeddedDriver")
 83 |       (connect (str "jdbc:derby:" location))))
 84 | 
 85 | (defn dbtest-ask-location []
 86 |   `(:html
 87 |     (:body
 88 |      (:form {:action ~(url "/dbtest") :method "POST"}
 89 | 	    (:b "Where is the derby tours db located?")
 90 | 	    (:input {:type "text" :name "db" :size "80"})
 91 | 	    "(example: /Users/tadex/software/derby/demo/databases/toursdb)"
 92 | 	    (:br)
 93 | 	    (:input {:type "submit" :value "Go!"})))))
 94 | 
 95 | (defh "/dbtest" [loc {:name "db" :optional true}] {:output :html}
 96 |   (let [db (session-get "db"
 97 |                         (fn [] (if (nil? loc)
 98 |                                  nil
 99 |                                  (connect-to-db loc))))]
100 |     (if (nil? db)
101 |       (dbtest-ask-location)
102 |       `(:html
103 |         (:body
104 |          ~(let [results (query db "SELECT c.COUNTRY, c.COUNTRY_ISO_CODE, c.REGION, (SELECT COUNT(*) FROM cities WHERE country_iso_code=c.country_iso_code) as cities FROM countries c ORDER BY country ASC")
105 |                 columns (:columns (meta results))]            
106 |             (format-table (map first columns) results
107 |                           ["List cities" (fn [row]
108 |                                            (url "/dbtest-cities" {:country (second row)}))])))))))
109 | 
110 | (defh "/dbtest-cities" [country "country"] {:output :html}
111 |   (let [cities (query (session-get "db")
112 |                           "SELECT * FROM cities WHERE country_iso_code=?" country)]    
113 |     `(:html
114 |       (:body
115 |        ~(format-table (map first (:columns (meta cities))) cities)
116 |        (:b ~(str (:rows (meta cities)) " cities.")))
117 |       (:br)
118 |       (:a {:href ~(url "/dbtest")} "&laquo; back to countries"))))
119 | 
120 | 
121 | 
122 | ;;;;;;;;;;;;;
123 | ;; AJAX REPL
124 | ;;
125 | ;; a very simplistic version
126 | ;; there were some problems with using PiperReader/-Writer approach
127 | ;; with thread deadlocking... 
128 | 
129 | 
130 | 
131 | ;; The main page
132 | (defh "/ajaxrepl" [] {:output :html}
133 |   `(:html
134 |     (:head (:title "Webjure AJAX REPL")
135 | 	   (:script {:type "text/javascript"
136 | 		    :language "javascript"
137 | 		    :src ~(url "/resource/repl.js")}))
138 | 
139 |     (:body 
140 |      (:h3 "Webjure AJAX REPL")
141 |      (:div 
142 |       {:id "replout"
143 |       :style "width: 600px; height: 400px; overflow: auto; font-family: monospace; color: silver; background-color: black; white-space: pre;"}
144 |       "")
145 |      
146 |      (:form ;{:onsubmit "return write();"}
147 |       (:textarea {:onkeypress "keyHandler(event)" :id "replin" :style "width: 600px; height: 70px;"} "")))))
148 | 
149 | ;;; A REPL using Refs 
150 | 
151 | (defn repl-session []
152 |   (session-get "repl-messages" (fn [] (binding [*use-context-classloader* true]
153 | 					(agent [])))))
154 |      
155 | (defn repl-write [messages new-msg]
156 |   (let [messages (conj new-msg messages)]
157 |     (prn messages)
158 |     messages))
159 | 
160 | (defn repl-fetch [messages writer]
161 |   (. writer (append "FOO"))
162 |   (. writer (append (reduce str (interleave messages (repeat "\n")))))
163 |   ;; new state is no messages
164 |   [])
165 |   
166 | 
167 | ;; Set the Return new content since last update
168 | ;; if there is no new content, wait for some
169 | (defn ajaxrepl-out []
170 |   (. *response* (setContentType "text/plain"))
171 |   (. (. *response* (getWriter)) (append (reduce str (interleave @(repl-session) (repeat "\n")))))
172 |   (binding [*use-context-classloader* true] 
173 |     (send (repl-session) (fn [msgs] []))))
174 | 
175 | (publish ajaxrepl-out "/ajaxrepl-out")
176 | 
177 | (defn ajaxrepl-eval [str]
178 |   (str (eval (read (new java.io.PushbackReader (new java.io.StringReader str))))))
179 | 
180 | (defn ajaxrepl-in []
181 |   (binding [*use-context-classloader* true]
182 |     (send (repl-session) repl-write (ajaxrepl-eval (slurp-post-data)))))
183 | (publish ajaxrepl-in "/ajaxrepl-in")
184 | 
185 | 		      
186 | ;;; Session test
187 | 
188 | (defh "/session" [] {:output :html}
189 |   `(:html
190 |     (:head (:title "Webjure session test"))
191 |     (:body
192 |      ~(let [count (session-get "count")
193 |             greeting (if (nil? count)
194 |                        "Hello first time user"
195 |                        (str "Hello, this has been called " count " times."))]
196 |         (session-set "count" (if (nil? count) 1 (inc count)))
197 |         greeting))))
198 | 
199 | 
200 | 
201 | ;;;;;;;;;;;;;;;;;;;;;;;;;;
202 | ;; Atom feed parser test
203 | 
204 | (defh "/clojurenews" []
205 |   {:output :html}
206 |   (with-open [url (.openStream (new java.net.URL "http://clojure.blogspot.com/feeds/posts/default"))]
207 |       (let [feed (load-atom1-feed url)]
208 | 	(do (println (str feed))
209 | 	    `(:html 
210 | 	      (:head (:title ~(feed :title)))
211 | 	      (:body 
212 | 	       (:h3 ~(feed :subtitle))
213 | 	       (:ul
214 | 		~@(map (fn [entry]
215 | 			 `(:li (:a {:href ~(((entry :links) "alternate") :url)} ~(entry :title))))
216 | 		       (feed :entries)))
217 | 	       (:hr)
218 | 	       "And this is what we parsed from the XML:"
219 | 	       (:p)
220 | 	       (:textarea {:style "width: 95%; height: 300px;" } 
221 | 			  ~(webjure.json/serialize-str feed))))))))
222 | 
223 | 
224 | ;;;;;;;;;;;;;;;;;;;;
225 | ;; defh regex test
226 | 
227 | (defh #"/hello/(.+?)(/(.+))?$" 
228 |   [first-name 1
229 |    last-name 3]
230 |   {:output :html}
231 | 
232 |   `(:html
233 |     (:body
234 |      (:p "Hello " ~first-name " " ~(or last-name ""))
235 | 
236 |      ~@(if (nil? last-name)
237 | 	 `((:a {:href ~(url (str "/hello/" first-name "/Something"))}
238 | 	       "try with another path component"))))))
239 | 
240 | 
241 | ;;;;;;;;;;;;;;
242 | ;; json test
243 | 
244 | (defh "/json" []
245 |   {:output :json}
246 |   {"headers" (request-headers)
247 |    "parameters" (request-parameters)})
248 | 


--------------------------------------------------------------------------------
/demos/src/main/clojure/webjure/demos.clj:
--------------------------------------------------------------------------------
  1 | 
  2 | ;; Demos to be placed here
  3 | 
  4 | (ns webjure.demos
  5 |     (:refer-clojure)
  6 |     (:use webjure)
  7 |     (:use webjure.html)
  8 |     (:use webjure.sql)
  9 |     (:use webjure.xml.feeds)
 10 |     (:use webjure.wiki)
 11 |     (:use webjure.cpt)
 12 |     (:use webjure.xml)
 13 |     (:use swank.swank)
 14 |     (:use clojure.stacktrace))
 15 | 
 16 | 
 17 | (defn dbg [& u]
 18 |   (. (. System err)
 19 |      (println (apply pr-str u))))
 20 | 
 21 | (defn menu [& entries]
 22 |   (map (fn [[link desc]]
 23 | 	 `(:li (:a {:href ~link} ~desc)))
 24 |        entries))
 25 | 
 26 | (declare page)
 27 | 
 28 | (def *swank-started* (ref false))
 29 | 
 30 | (defh "/start-swank" [port {:name "port" :validator #(if (nil? %) 4005 (Integer/parseInt %))}] 
 31 |   {:output :text}
 32 |   (if @*swank-started*
 33 |     "Swank already started."
 34 |     (dosync
 35 |      (try (start-repl port)
 36 | 	  (ref-set *swank-started* true)
 37 | 	  (str "Swank started on port " port)
 38 | 	  (catch Exception e
 39 | 	    (str "Unable to start swank: " (with-out-str (print-cause-trace e))))))))
 40 | 
 41 | (defh "/index" [] {:output :print}		   
 42 |   (page 
 43 |    {:title "Webjure, a tiny web framework for Clojure"
 44 |     :content (html-format 
 45 | 	      `(span
 46 | 		(:h2 "Welcome to Webjure demos!")
 47 | 		(:p "Here are the demos.")
 48 | 		(:ul ~@(menu 
 49 | 			[(url "/start-swank") "Start swank to use SLIME"]
 50 | 			[(url "/index") "This page, a simple sexp markup page"]
 51 | 			[(url "/info" {:some "value" :another "one"}) "Dump request info"]
 52 | 			[(url "/dbtest") "Database test"]
 53 | 			[(url "/session") "Session test"]
 54 | 			[(url "/clojurenews") "Clojure news (Atom feed parser test)"]
 55 | 			[(url "/hello/Test") "Test path binding"]
 56 | 			[(url "/json?foo=bar&quux=baz") "Return request info as JSON"]
 57 | 			[(url "/docs") "Autogenerated Webjure docs"]))
 58 | 		(:hr)
 59 | 		(:p 
 60 | 		 (:b "Important notice: ") "Have a nice and RESTful day!"
 61 | 		 (:br)
 62 | 		 (:div {:style "font-size: small;"} ~(format-date "dd.MM.yyyy hh:mm")))))
 63 |     }))
 64 |          
 65 | 
 66 | (defn format-map-as-table [keylabel valuelabel themap]
 67 |   `(:table
 68 |     (:tr (:th ~keylabel) (:th ~valuelabel))
 69 |     ~@(map (fn [key]
 70 | 	       `(:tr (:td ~key) (:td ~(reduce (fn [x y] (str x ", " y)) (get themap key)))))
 71 | 	   (keys themap))))
 72 | 
 73 | (defn format-table [headers values & actions]
 74 |   `(:table
 75 |     (:tr 
 76 |      ~@(map (fn [hdr] `(:th ~hdr)) headers)
 77 |      (:th "Actions"))
 78 |     
 79 |     ~@(map (fn [row] `(:tr 
 80 | 		       ~@(map (fn [v] `(:td ~(str v))) row)
 81 | 		       (:td ~@(map (fn [action]
 82 |                                      `(:a {:href ~((second action) row)}
 83 |                                           ~(first action))) actions))
 84 | 		       ))
 85 | 	   values)))
 86 | 
 87 | (defh "/info*" [] {:output :html}
 88 |   `(:html 
 89 |     (:body
 90 |      (:h3 "Request headers")
 91 |      ~(format-map-as-table "Name" "Values" (request-headers))
 92 |      (:br)
 93 |      
 94 |      (:h3 "Request parameters")
 95 |      ~(format-map-as-table "Name" "Values" (request-parameters))
 96 |      (:br)
 97 |                                              
 98 |      (:h3 "Path info")
 99 |      (:p ~(request-path)))))
100 | 
101 | 
102 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
103 | ;; db test using derby tours
104 | ;;
105 | 
106 | 
107 | (defn connect-to-db [location]
108 |   (do (register-driver "org.apache.derby.jdbc.EmbeddedDriver")
109 |       (connect (str "jdbc:derby:" location))))
110 | 
111 | (defn dbtest-ask-location []
112 |   `(:html
113 |     (:body
114 |      (:form {:action ~(url "/dbtest") :method "POST"}
115 | 	    (:b "Where is the derby tours db located?")
116 | 	    (:input {:type "text" :name "db" :size "80"})
117 | 	    "(example: /Users/tadex/software/derby/demo/databases/toursdb)"
118 | 	    (:br)
119 | 	    (:input {:type "submit" :value "Go!"})))))
120 | 
121 | (defh "/dbtest" [loc {:name "db" :optional true}] {:output :html}
122 |   (let [db (session-get "db"
123 |                         (fn [] (if (nil? loc)
124 |                                  nil
125 |                                  (connect-to-db loc))))]
126 |     (if (nil? db)
127 |       (dbtest-ask-location)
128 |       `(:html
129 |         (:body
130 |          ~(let [results (query db "SELECT c.COUNTRY, c.COUNTRY_ISO_CODE, c.REGION, (SELECT COUNT(*) FROM cities WHERE country_iso_code=c.country_iso_code) as cities FROM countries c ORDER BY country ASC")
131 |                 columns (:columns (meta results))]            
132 |             (format-table (map first columns) results
133 |                           ["List cities" (fn [row]
134 |                                            (url "/dbtest-cities" {:country (second row)}))])))))))
135 | 
136 | (defh "/dbtest-cities" [country "country"] {:output :html}
137 |   (let [cities (query (session-get "db")
138 |                           "SELECT * FROM cities WHERE country_iso_code=?" country)]    
139 |     `(:html
140 |       (:body
141 |        ~(format-table (map first (:columns (meta cities))) cities)
142 |        (:b ~(str (:rows (meta cities)) " cities.")))
143 |       (:br)
144 |       (:a {:href ~(url "/dbtest")} "&laquo; back to countries"))))
145 | 
146 | 
147 | ;;; Session test
148 | 
149 | (defh "/session" [] {:output :html}
150 |   `(:html
151 |     (:head (:title "Webjure session test"))
152 |     (:body
153 |      ~(let [count (session-get "count")
154 |             greeting (if (nil? count)
155 |                        "Hello first time user"
156 |                        (str "Hello, this has been called " count " times."))]
157 |         (session-set "count" (if (nil? count) 1 (inc count)))
158 |         greeting))))
159 | 
160 | 
161 | 
162 | ;;;;;;;;;;;;;;;;;;;;;;;;;;
163 | ;; Atom feed parser test
164 | 
165 | (defh "/clojurenews" []
166 |   {:output :html}
167 |   (with-open [url (.openStream (new java.net.URL "http://clojure.blogspot.com/feeds/posts/default"))]
168 |       (let [feed (load-atom1-feed url)]
169 | 	(do (println (str feed))
170 | 	    `(:html 
171 | 	      (:head (:title ~(feed :title)))
172 | 	      (:body 
173 | 	       (:h3 ~(feed :subtitle))
174 | 	       (:ul
175 | 		~@(map (fn [entry]
176 | 			 `(:li (:a {:href ~(((entry :links) "alternate") :url)} ~(entry :title))))
177 | 		       (feed :entries)))
178 | 	       (:hr)
179 | 	       "And this is what we parsed from the XML:"
180 | 	       (:p)
181 | 	       (:textarea {:style "width: 95%; height: 300px;" } 
182 | 			  ~(webjure.json/serialize-str feed))))))))
183 | 
184 | 
185 | ;;;;;;;;;;;;;;;;;;;;
186 | ;; defh regex test
187 | 
188 | (defh #"/hello/(.+?)(/(.+))?$" 
189 |   [first-name 1
190 |    last-name 3]
191 |   {:output :html}
192 | 
193 |   `(:html
194 |     (:body
195 |      (:p "Hello " ~first-name " " ~(or last-name ""))
196 | 
197 |      ~@(if (nil? last-name)
198 | 	 `((:a {:href ~(url (str "/hello/" first-name "/Something"))}
199 | 	       "try with another path component"))))))
200 | 
201 | 
202 | ;;;;;;;;;;;;;;
203 | ;; json test
204 | 
205 | (defh "/json" []
206 |   {:output :json}
207 |   {"headers" (request-headers)
208 |    "parameters" (request-parameters)})
209 | 
210 | (define-template page "page.cpt")
211 | 
212 | (comment
213 | 
214 | (defn page [data]
215 |   `(:html 
216 |     {:xmlns "http://www.w3.org/1999/xhtml"}
217 |     (:head
218 |      (:meta {:http-equiv "content-type" :content "text/html; charset=utf-8"})
219 |      (:title ~(or (:title data) "Webjure demos page"))	    
220 |      (:link {:href ~(url "/resource/default.css") :rel "stylesheet" :type "text/css"}))
221 |     (:body
222 |      (:div {:id "header"}
223 | 	   (:h1 "Webjure")
224 | 	   (:h2 "By Free CSS Templates"))
225 | 
226 |      (:div {:id "menu"}
227 | 	   (:ul 
228 | 	    (:li {:class "first"} (:a {:href ~(url "/index")} "Home"))
229 | 	    (:li (:a {:href "http://github.com/tatut/Webjure"} "On Github"))))
230 | 
231 |      (:div {:id "content"}
232 | 	   (:div {:id "columnA"}
233 | 		 ~@(:content data))
234 | 	   
235 | 	   (:div {:id "columnB"}
236 | 		 (:h2 "Recent Updates")
237 | 		 (:p (:strong "January 11 2010") 
238 | 		     (:br)
239 | 		     "Updated to 0.5-SNAPSHOT, now works with Clojure 1.1 and does AOT compiling."))
240 | 		 
241 | 	   (:div {:style "clear: both;"} "&nbsp;"))
242 |      (:div {:id "footer"}
243 | 	   (:p "Copyright &copy; 2009-2010 Tatu Tarvainen. Designed by " 
244 | 	       (:a {:href "http://www.freecsstemplates.org" :class "link1"} "Free CSS Templates"))))))
245 | 
246 | )
247 | 
248 | ;;;;;;;;;;;;;;;
249 | ;; Generate Webjure documentation in HTML and PDF formats
250 | 
251 | (defn webjure-publics []
252 |   (sort-by #(str (:name %)) (map meta (vals (ns-publics 'webjure)))))
253 | 
254 | 
255 | (define-template docs "docs.cpt")
256 | 
257 | (defh "/docs" [] {:output :print}
258 |   (docs (webjure-publics)))
259 | 
260 | (defn pdf [xsl-fo-str]
261 |   (let [http-response (.getActualResponse *response*)
262 | 	out (.getOutputStream http-response)
263 | 	fop-factory (org.apache.fop.apps.FopFactory/newInstance)
264 | 	fop (.newFop fop-factory org.apache.fop.apps.MimeConstants/MIME_PDF out)
265 | 	transformer (.newTransformer (javax.xml.transform.TransformerFactory/newInstance))]
266 |     (.setContentType http-response "application/pdf")
267 |     (.transform transformer 
268 | 		(javax.xml.transform.stream.StreamSource. 
269 | 		 (java.io.ByteArrayInputStream. (.getBytes xsl-fo-str)))
270 | 		(javax.xml.transform.sax.SAXResult. (.getDefaultHandler fop)))))
271 | 		
272 | 		     
273 | (define-template docs-pdf "docs-pdf.cpt")
274 | 
275 | (defh "/docs/pdf" [] {}
276 |   (pdf (with-out-str (docs-pdf (webjure-publics)))))


--------------------------------------------------------------------------------
/webjure/src/webjure/sql/crud.clj:
--------------------------------------------------------------------------------
  1 | ;; A Quick and Dirty CRUD for SQL tables
  2 | ;;
  3 | ;; Main entry point is the ui macro which is meant to be called from inside a
  4 | ;; Webjure handler.
  5 | ;;
  6 | ;; This core namespace defines the used protocols and
  7 | ;; the main macros for creating CRUD views.
  8 | ;;
  9 | ;; Protocols
 10 | ;; ---------
 11 | ;;
 12 | ;; InlineEdit:
 13 | ;; Protocol for defining a way to allow inline editing of a column
 14 | ;; data inside the listing view.
 15 | ;; Uses AJAX calls to update the values, which the protocol must provide.
 16 | ;; Use by defining an :inline-edit key in the field options.
 17 | ;;
 18 | ;; ListView:
 19 | ;; Generic way to render different data types.
 20 | 
 21 | (ns webjure.sql.crud
 22 |   (:refer-clojure)
 23 |   (:use webjure.sql)
 24 |   (:use webjure)
 25 |   (:use webjure.cpt)
 26 |   (:require webjure.profiler))
 27 | 
 28 | ;; Bound within a handler to the prefix of this CRUD handler
 29 | ;; May be used for generating new URLs 
 30 | (def *current-path-prefix* nil)
 31 | 
 32 | (defn crud-url [path argmap]
 33 |   (str *current-path-prefix*
 34 |        path
 35 |        "?"(reduce str
 36 |                   (butlast  (interleave (map (fn [[k v]]
 37 |                                                (str (name k) "=" v))
 38 |                                              argmap)
 39 |                                         (repeat "&"))))))
 40 | 
 41 | (defprotocol ListView
 42 |   (render-list-view [this]))
 43 | 
 44 | (defprotocol InlineEdit
 45 |   ;; Method to render an HTML/JS inline edit view (and link)
 46 |   (render-inline-edit-view [this field current-value])
 47 | 
 48 |   ;; Invoked by the AJAX handler of new values
 49 |   ;; the response will be JSONified and should be something
 50 |   ;; the UI rendereded by render-inline-edit-view can handle.
 51 |   (update-value [this id field new-value]))
 52 |     
 53 | 
 54 | (defn page-link [here page]
 55 |   (let [{:keys [limit order dir]} here]
 56 |     (str "?start=" (* page limit) "&limit=" limit
 57 | 	 (when order (str "&order=" order))
 58 | 	 (when dir (str "&dir=" dir)))))
 59 | 
 60 | (defn listing-header-sort-attributes [here header]
 61 |   (let [field (get (:fields here) header)]
 62 |     (if  (not (:sortable field))
 63 |       []
 64 |       {"class" (if (= (:order here) (name header))
 65 | 		 (if (= "asc" (:dir here)) "sortAscending" "sortDescending")
 66 | 		 "normal")
 67 |        "onclick" (str "document.location = '"
 68 | 		      (page-link (merge here
 69 | 					{:order (name header)
 70 | 					 :dir (if (= "asc" (:dir here)) "desc" "asc")})
 71 | 				 (/ (:start here) (:limit here)))
 72 | 		      "';")})))
 73 | 
 74 | (define-template generic-listing-template "src/main/resources/crud/generic-listing-template.cpt")
 75 | 
 76 | (extend-protocol ListView
 77 |   Object
 78 |   (render-list-view [obj] (str obj))
 79 | 
 80 |   Boolean
 81 |   (render-list-view [b]
 82 | 		    (str "<span class=\"center\">"
 83 | 			 (if b
 84 | 			   "&#x2612;"   ;; ballot box with x
 85 | 			   "&#x2610;")  ;; ballot box
 86 | 			 "</span>"))
 87 |   nil
 88 |   (render-list-view [n] "<span class=\"sqlNull\">NULL</span>")
 89 |   )
 90 | 
 91 | (def +default-batch-size+ 25)
 92 | 
 93 | (defn determine-query-tables [home-table field-list fields]
 94 |   "Determine all tables that are involved in the query. Returns a mapping
 95 | from table name to it's query alias, eg. {\"firsttable\" \"t1\", \"secondtable\" \"t2\"}."
 96 |   (loop [[f & fs] field-list
 97 | 	 tables {home-table "t1"}
 98 | 	 counter 2]
 99 |     (if (nil? f)
100 |       tables
101 |       (let [{join :join} (fields f)]
102 | 	(if (not join)
103 | 	  (recur fs tables counter)
104 | 	  (recur fs (assoc tables
105 | 		      (:table join) (str "t" counter))
106 | 		 (+ counter 1)))))))
107 | 
108 | (defn determine-from-tables [home-table field-list fields]
109 |   "Create a SQL FROM fragment with joins, eg. \"firsttable t1 LEFT JOIN secondtable t2 ON t1.sec_id=t2.id\". " 
110 |   (let [tables (determine-query-tables home-table field-list fields)]
111 |     (loop [[f & fs] field-list
112 | 	   from (str home-table " t1")]
113 |       (if (nil? f)
114 | 	from
115 | 	(let [{join :join} (fields f)]
116 | 	  (if (not join)
117 | 	    (recur fs from)
118 | 	    (recur fs (let [{:keys [table home-field foreign-field]} join]
119 | 			(str from " LEFT JOIN " table " " (tables table) " ON "
120 | 			     (tables home-table) "." (name home-field) "=" (tables table) "." (name foreign-field))))))))))
121 | 
122 | (defn determine-foreign-keys [tables fields]
123 |   "Determine additional foreign keys we need to fetch. Returns a list of field references."
124 |   (apply vector
125 | 	 (filter #(not (nil? %))
126 | 		 (map (fn [[field-name {join :join}]]
127 | 			(when join
128 | 			  [(:table join) (:foreign-field join)
129 | 			   (str (tables (:table join)) "."  (name (:foreign-field join)))]))
130 | 		      fields))))
131 | 
132 | 
133 | 
134 | (defn string-join
135 |   ([coll] (string-join ", " coll))
136 |   ([sep coll]
137 |      (reduce str
138 | 	     (butlast (interleave coll (repeat sep))))))
139 | 
140 | (defn generate-listing [db table opt]
141 |   `(webjure.profiler/with-step "Generate CRUD listing"
142 |      (with-open [db# (~db)]
143 |        (let [start# (Long/parseLong (or (request-parameter "start") "0"))
144 | 	     limit# (let [lim# (request-parameter "limit")]
145 | 		      (if lim#
146 | 			(Long/parseLong lim#)
147 | 			(or ~(:batch-size opt) +default-batch-size+)))
148 | 	     order# (request-parameter "order")
149 | 	     dir# (request-parameter "dir")
150 | 	     list-fields# ~(:list-fields opt)
151 | 	     primary-key# ~(:primary-key opt)
152 | 	     fields# ~(:fields opt)
153 | 	     tables# ~(determine-query-tables table (:list-fields opt) (:fields opt))
154 | 	     from-tables# ~(determine-from-tables table (:list-fields opt) (:fields opt))
155 | 	     foreign-key-fields# ~(determine-foreign-keys
156 | 				   (determine-query-tables table (:list-fields opt) (:fields opt))
157 | 				   (:fields opt))	   
158 | 	     field-ref# (fn [f#]
159 | 			  (let [{join# :join} (fields# (keyword f#))]
160 | 			    (if (not join#)
161 | 			      (str "t1." f#)
162 | 			      (str (tables# (:table join#)) "." (name (:field join#))))))
163 | 	     ]
164 | 	 (set-response-content-type *response* "text/html; charset=UTF-8")
165 | 	 (println "REQUEST HEADERS: " (request-headers))
166 | 	 (with-open
167 | 	     [out#  (if (.contains (or (first (get (request-headers) "Accept-Encoding")) "")
168 | 				   "gzip")
169 | 		      (do (.setHeader *response* "Content-Encoding" "gzip")
170 | 			  (java.io.OutputStreamWriter. (java.util.zip.GZIPOutputStream. (.getOutputStream *response*)) "UTF-8"))
171 | 		      (response-writer))]
172 | 	   (~(or (:list-template opt) 'webjure.sql.crud/generic-listing-template)
173 | 	    out#
174 | 	    {:list-fields list-fields#
175 | 	     :fields fields#
176 | 	     :start start#
177 | 	     :limit limit#
178 | 	     :order order#
179 | 	     :dir dir#
180 | 	     :rows (let [sql# (str 
181 | 			       "SELECT t1." (name primary-key#) ", "
182 | 			       (string-join
183 | 				(concat (map #(nth % 2) foreign-key-fields#)
184 | 					(map (fn [field-name#]
185 | 					       (let [{join# :join} (fields# field-name#)]
186 | 						 (if join#
187 | 						   (str (tables# (:table join#)) "." (name (:field join#))
188 | 							" as " (name field-name#))
189 | 						   (str "t1." (name field-name#)))))
190 | 					     list-fields#)))
191 | 			       " FROM " from-tables#
192 | 			       (when order#
193 | 				 (str " ORDER BY " (field-ref# order#) " " (if (= "asc" dir#) "ASC" "DESC")))
194 | 			       (when (or (not (zero? start#)) (not (zero? limit#)))
195 | 				 (str " LIMIT " start# ", " limit#)))
196 | 			 drop# (+ 1 (count foreign-key-fields#))
197 | 			 res# (webjure.profiler/with-step "Execute SQL query" (query db# sql#))]
198 | 		     ;; (println "QUERY: " sql#)
199 | 		     (map (fn [row#]
200 | 			    [(drop drop# row#)
201 | 			     (first row#)
202 | 			     (zipmap (map first foreign-key-fields#)
203 | 				     (take (count foreign-key-fields#)
204 | 					   (drop 1 row#)))])
205 | 			  res#))
206 | 	     :total-rows (ffirst (query db# (str "SELECT COUNT( " (name primary-key#) ") FROM " ~table)))}))))))
207 | 	       
208 | 
209 | (defn generate-select [db field table display-field value-field]
210 |   `(str
211 |     "<select name=\"" ~(name field) "\">\n"
212 |     (reduce str
213 | 	    (map (fn [[value# display#]]
214 | 		   (str "  <option value=\"" value# "\">" display# "</option>\n"))
215 | 		 (query ~db ~(str "SELECT " (name value-field) ", " (name display-field)
216 | 				  " FROM " (name table)))))
217 |     "</select>\n"))
218 | 
219 | (defn generate-field-editor [db field-name field-info]
220 |   (let [{label :label join :join} field-info]
221 |     (if join
222 |       (generate-select db (:table join) (:field join) (:foreign-field join))
223 |       (str "<input type=\"text\" name=\"" (name field-name) "\"/>"))))
224 | 
225 | 
226 | (defmacro ui "Generate a CRUD UI for the given table"
227 |   [db table & options]
228 |   (let [opt-pairs (partition 2 options)
229 | 	opt (zipmap (map first opt-pairs)
230 | 		    (map second opt-pairs))]
231 |     `(webjure.profiler/with-request-profiling
232 |        (let [delete# (request-parameter "_delete")
233 | 	     edit# (request-parameter "_edit")
234 | 	     save# (request-parameter "_save")]
235 | 	 (if delete#
236 | 	   (send-output "text/plain" (str "Deleting " delete#))
237 | 	   (if edit#
238 | 	     (send-output "text/plain" (str "Showing edit form for " edit#))
239 | 	     (if save#
240 | 	       (send-output "text/plain" (str "Saving " save#))
241 | 	       ~(generate-listing db table opt))))))))
242 | 
243 | (defmacro define-crud-handler [prefix db table & options]
244 |   (let [opt-pairs (partition 2 options)
245 | 	opt (zipmap (map first opt-pairs)
246 | 		    (map second opt-pairs))]
247 |     `(defh ~(re-pattern (str prefix "(/([^/]+))?$"))
248 |        [pk# 2] {}
249 |        (binding [*current-path-prefix* ~prefix]
250 |          (webjure.profiler/with-request-profiling
251 |            (if pk#
252 |              (do 
253 |                (send-output "text/plain" (str (if (request-parameter "edit")
254 |                                                 "Edit " "View ") pk#)))	   
255 |              ~(generate-listing db table opt)))))))


--------------------------------------------------------------------------------
/webjure/src/webjure/xml.clj:
--------------------------------------------------------------------------------
  1 | ;;; Defines recursive DOM tree parsing functions
  2 | ;;; Author: Tatu Tarvainen
  3 | ;;; Time-stamp: <2008-01-22 10:48:03 tadex>
  4 | ;;;
  5 | ;;; Sort of regular expressions for DOM trees:
  6 | ;;; (<>* "name" ...)             Allows 0 or more child elements with the name "name".
  7 | ;;;                              This is an optimized form of (? (<>+ "name ...))
  8 | ;;;
  9 | ;;; (<>+ "name" ...)             Allows 1 or more child elements with the name "name".
 10 | ;;;
 11 | ;;; (<>? "name" ...)             Allows 0 or 1 child elements with the name "name".
 12 | ;;;                              This is an optimized form of (? (<> "name" ...)).
 13 | ;;;
 14 | ;;; (<> "name" ...)              allows exactly 1 child element with the name "name"
 15 | ;;;
 16 | ;;; (attr "name" ...)            allows only elements that have an attribute named "name"
 17 | ;;;
 18 | ;;; (attr ["name" "value"] ...)  allows only elements that have an attribute named "name"
 19 | ;;;                              with the value "value"
 20 | ;;;
 21 | ;;; (? ...)                      The optional operator. 
 22 | ;;;                              Catches failures of the sub-parsers and continues normally.
 23 | ;;;
 24 | ;;; (|| ...)                     The OR operator. Tries all sub-parsers and returns when the
 25 | ;;;                              first one matches. If no sub-parser matches, the OR fails.
 26 | ;;;
 27 | ;;; (fn [node parse-state] ...)  apply function to each mached node 
 28 | ;;;                             
 29 | ;;; (=> var state ...)           helper macro for (fn [node] ...) that creates a function
 30 | ;;;                              that returns nil at the end (unless the return value is a
 31 | ;;;                              an error dictionary.
 32 | ;;;
 33 | ;;; All parser definition can have any amount of sub-parsers which are
 34 | ;;; run in case of a match. Sub-parsers are invoked in the order they
 35 | ;;; are specified (effectively ANDing them). If a parser has two sub-parsers
 36 | ;;; and the first one fails, the second will not be run.
 37 | 
 38 | ;;; A state object is passed along as the parsing is done
 39 | ;;; the user fn functions can modify state by returning a new one 
 40 | ;;; (default parsing functions just return the same state they got as
 41 | ;;; a parameter).
 42 | ;;; A return value for a handler can be [:error node description] or
 43 | ;;; [:state new-state-obj].
 44 | ;;;
 45 | ;;; The helper macros: (error node ...description...) and (yield new-state-obj)
 46 | ;;; produce the above return values.
 47 | ;;;
 48 | ;;; Helper functions collect and collect-as provide easy ways to capture
 49 | ;;; parsed objects to user state in seq or map.
 50 | ;;;
 51 | ;;; ---- a very simple example ----
 52 | ;;; The following parsing code:
 53 | ;;;   (parse tree [] (<> "foo" (<>* "bar" (collect text))))
 54 | ;;; Run on this tree:
 55 | ;;;   <foo>
 56 | ;;;      <bar>one</bar>
 57 | ;;;      <bar>two</bar>
 58 | ;;;      <bar>three</bar>
 59 | ;;;   </foo>
 60 | ;;; Will return the value:
 61 | ;;;   ["one" "two" "three"]
 62 | 
 63 | 
 64 | (ns webjure.xml
 65 |     (:refer-clojure))
 66 | 
 67 | 
 68 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 69 | ;; DOM utilities and accessors ;;
 70 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 71 | 
 72 | ;; Return the type of the element
 73 | (defn type-of [#^org.w3c.dom.Node node]
 74 |   (let [node-type (. node (getNodeType))]
 75 |     (cond 
 76 |      (= node-type (. org.w3c.dom.Node ELEMENT_NODE)) :element
 77 |      (= node-type (. org.w3c.dom.Node ATTRIBUTE_NODE)) :attribute
 78 |      (= node-type (. org.w3c.dom.Node TEXT_NODE))  :text
 79 |      (= node-type (. org.w3c.dom.Node CDATA_SECTION_NODE)) :cdata-section
 80 |      (= node-type (. org.w3c.dom.Node ENTITY_REFERENCE_NODE)) :entity-reference
 81 |      (= node-type (. org.w3c.dom.Node ENTITY_NODE)) :entity
 82 |      (= node-type (. org.w3c.dom.Node PROCESSING_INSTRUCTION_NODE)) :processing-instruction
 83 |      (= node-type (. org.w3c.dom.Node COMMENT_NODE)) :comment
 84 |      (= node-type (. org.w3c.dom.Node DOCUMENT_NODE)) :document
 85 |      (= node-type (. org.w3c.dom.Node DOCUMENT_TYPE_NODE)) :document-type
 86 |      (= node-type (. org.w3c.dom.Node DOCUMENT_FRAGMENT_NODE)) :document-fragment
 87 |      (= node-type (. org.w3c.dom.Node NOTATION_NODE)) :notation)))
 88 | 
 89 | ;; Get the name of given node
 90 | (defn name-of [#^org.w3c.dom.Node node]
 91 |   (. node (getNodeName)))
 92 | 
 93 | ;; Check if the given node is an element (optionally check 
 94 | ;; the element name also)
 95 | (defn element? 
 96 |   ([node] (= :element (type-of node)))
 97 |   ([node name] (and (= :element (type-of node))
 98 |                    (= name (name-of node)))))
 99 | 
100 | ;; Fetch named attribute of node
101 | (defn attribute [#^org.w3c.dom.Element node name]
102 |   (let [attr-node (. node (getAttributeNode name))]
103 |     (and attr-node (. attr-node (getValue)))))
104 | 
105 | ;; Return all children as a list
106 | (defn children [#^org.w3c.dom.Node parent]
107 |   (let [#^org.w3c.dom.NodeList 
108 | 	all-children (. parent (getChildNodes))
109 |         child-count (. all-children (getLength))]
110 |     (loop [i 0
111 | 	   acc []]
112 |       (if (== i child-count)
113 | 	acc
114 | 	(recur (+ i 1)
115 | 	       (conj acc (. all-children (item i))))))))
116 | 
117 | 
118 | (defn child-elements [#^org.w3c.dom.Element parent]
119 |   (filter element? (children parent)))
120 | 
121 | ;; Fetch text content 
122 | (defn text [#^org.w3c.dom.Element node]
123 |   (reduce str (map (fn [#^org.w3c.dom.CharacterData x] (. x (getData)))
124 |                    (filter (fn [x] (= :text (type-of x))) (children node)))))
125 | 
126 | (defn new-document-builder []
127 |   (. (. javax.xml.parsers.DocumentBuilderFactory (newInstance)) (newDocumentBuilder)))
128 | 
129 | ;;; Load XML DOM from the given source 
130 | (defmulti load-dom class)
131 | (defmethod load-dom String [string] 
132 |   (.parse (new-document-builder)
133 | 	  (org.xml.sax.InputSource. (java.io.StringReader. string))))
134 |   
135 | (defmethod load-dom java.io.File [file]
136 |   (load-dom (java.io.FileInputStream. file)))
137 | 
138 | (defmethod load-dom java.io.InputStream [stream]
139 |   (.parse (new-document-builder) stream))
140 | 
141 | 
142 | 
143 | (defn matches? [spec str]
144 |   ;; PENDING: allow xpath style matching of word inside value 
145 |   (= spec str))
146 | 
147 | ;;; Fetch all child elements with the given name
148 | (defn child-elements-by-name [#^org.w3c.dom.Element parent name]
149 |   (filter 
150 |    (fn [child] (element? child name))
151 |    (children parent)))
152 | 
153 | (defn child-element [#^org.w3c.dom.Element parent name]
154 |   (. (. parent (getElementsByTagName name)) (item 0)))
155 | 
156 | 
157 | (defmacro error [node & items]
158 |   `[:error ~node (reduce str (map str (list ~@items)))])
159 | 
160 | (defn yield [new-state]
161 |   `[:state ~new-state])
162 | 
163 | (defn error-state? [state]
164 |   (= :error (first state)))
165 | 
166 | ;; Run the given sub-parsers on node 
167 | (defn #^{:private true} run-sub-parsers [node current-state parsers]
168 |   (loop [ps parsers
169 |          state current-state]
170 |     (if (or (error-state? state) 
171 |             (empty? ps))
172 |       state
173 |       (recur (rest ps)
174 | 	     ((first ps) node state)))))
175 | 
176 | ;; Run the given sub-parsers on each child
177 | (defn do-children [children current-state parsers]
178 |   (loop [ch children
179 |          state current-state]
180 |     (if (or (error-state? state)
181 |             (empty? ch))
182 |       state
183 |       (recur (rest ch)
184 |              (run-sub-parsers (first ch) state parsers)))))
185 |     
186 | 
187 | (defn parse [tree initial-state & parsers]
188 |   (let [res (run-sub-parsers tree (yield initial-state) parsers)]
189 |     (if (error-state? res)
190 |       res
191 |       (second res))))
192 | 
193 | ;; Parse as a sub-parser, returns a function that takes the
194 | ;; node to parse.
195 | ;; This can be used to change state for sub parsers.
196 | (defn parse* [new-state & parsers]
197 |   (fn [node]
198 |       (let [res (run-sub-parsers node (yield new-state) parsers)]
199 |         (if (error-state? res)
200 |           res
201 |           (second res)))))
202 | 
203 | (def p* parse*) ;; short hand for parse* 
204 | 
205 | ;; Evaluate exprs for side-effects, does not change state
206 | (defmacro => [nodesym statesym & exprs]
207 |   `(fn [~nodesym state#]       
208 |        (let [~statesym (second state#)]
209 | 	 (let [newstate# (do ~@exprs)]
210 | 	   (if (nil? newstate#)
211 | 	     state#
212 | 	     newstate#)))))
213 | 
214 | 
215 | ;; Allow exactly one child with the given name
216 | (defn <> [name & sub-parsers]
217 |   (fn [parent state]      
218 |       (let [children (child-elements-by-name parent name)
219 |             count (count children)]
220 |         (if (== count 1)
221 | 	  (do-children children state sub-parsers)
222 |           (error  parent "Expected exactly one " name 
223 |                   " child element in node " (name-of parent))))))
224 | 
225 |       
226 | ;; Allow zero or more children with the given name
227 | (defn <>* [name & sub-parsers]
228 |   (fn [parent state]
229 |       (do-children (child-elements-by-name parent name) state sub-parsers)))
230 | 
231 | ;; Allow zero or one child with the given name
232 | (defn <>? [name & sub-parsers]
233 |   (fn [parent state]
234 |       (let [children (child-elements-by-name parent name)]
235 |         (if (not (nil? (second children)))
236 |           (error parent "Expected at most one " name " child element in node " (name-of parent))
237 |           (do-children children state sub-parsers)))))
238 | 
239 | ;; Allow one or more children with the given name
240 | (defn <>+ [name & sub-parsers]
241 |   (fn [parent state]
242 |       (let [children (child-elements-by-name parent name)]
243 |         (if (nil? (first children))
244 |           (error parent "Expected one or more " name " child elements in node " (name-of parent))
245 |           (do-children children state sub-parsers)))))
246 | 
247 | 
248 | ;; Require attributes (and optionally value)
249 | ;; attr-spec = attr-name | [attr-name attr-value]
250 | ;; FIXME: attr has some problem with state
251 | (defn attr [attr-spec & sub-parsers]
252 |   ;; FIXME: implement as before, now just requires named attribute
253 |   (fn [parent state] 
254 |       (if (not (element? parent))
255 |         (error parent "Tried to check attribute on a non-element node")
256 |         
257 |         (let [attr-value (if (instance? java.lang.String attr-spec) nil (second attr-spec)) 
258 |               attr-name (or (and attr-value (first attr-spec)) attr-spec)
259 |               attr-node (. #^org.w3c.dom.Element parent (getAttributeNode attr-name))]
260 |           (if (nil? attr-node)
261 |             (error parent "Element " (name-of parent) " does not have required attribute " attr-name)
262 |             
263 |             (if (or (nil? attr-value) (matches? attr-value (. attr-node (getValue))))
264 |               (run-sub-parsers attr-node state sub-parsers)
265 |               (error parent "Element attribute " attr-name " does not match " attr-value)))))))
266 | 
267 |         
268 | 
269 | ;;; Catch failures of the sub-parsers and continue as if
270 | ;;; no error occured.
271 | (defn ? [& sub-parsers]
272 |   (fn [node]
273 |       ;; PENDING: Should we catch each sub-parsers separately?
274 |       ;; We could wrap then in fns that catch exceptions
275 |       (try (run-sub-parsers node sub-parsers)
276 |            (catch java.lang.RuntimeException x true))))
277 | 
278 | 
279 | ;;; The OR operator
280 | (defn || [& sub-parsers]
281 |   (fn [node state]
282 |       (loop [sp sub-parsers]
283 |         (if (empty? sp)
284 |           ;; No sub-parser succeeded, throw an exception
285 |           (error node "OR operator failed for node " (name-of node))
286 | 
287 |           (if (not (try ((first sp) node) true
288 |                         (catch java.lang.RuntimeException ex false)))
289 |             (recur (rest sp)))))))
290 | 
291 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
292 | ;; Parsing actions helpers
293 | ;;
294 | 
295 | 
296 | ;; Collect the value obtained by applying fun to the node
297 | ;; as a keyed map value. Yields a new state with the new
298 | ;; key/value mapped. The old state must be a map.
299 | ;; If the fun is omitted, identity is used (collecting the node).
300 | (defmacro collect-as 
301 |   ([key] (collect-as key identity))
302 |   ([key fun]
303 |    `(=> elt# st#
304 | 	(yield (assoc st# ~key (~fun elt#))))))
305 |       
306 | ;; Collect a new sequence value obtained by applying fun to the
307 | ;; node. Yields a new state with the new value conj'ed to the
308 | ;; previous state (which must be a seq).
309 | ;; If the fun is omitted, identity is used (collecting the node).
310 | (defmacro collect 
311 |   ([] (collect identity))
312 |   ([fun] `(=> elt# st#
313 | 	      (yield (conj st# (~fun elt#))))))
314 |   
315 | 
316 | ;; Modify state by applying a function to the previous state and the element
317 | (defmacro modify [fun]
318 |   `(=> elt# st#
319 |        (yield (~fun st# elt#))))
320 | 
321 | (defmacro modify-key [key fun]
322 |   `(=> elt# st# 
323 |        (yield (assoc st#
324 | 		     ~key (~fun (st# ~key) elt#)))))


--------------------------------------------------------------------------------
/webjure/src/webjure/cpt.clj:
--------------------------------------------------------------------------------
  1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2 | ;; CPT - Clojure Page Templates
  3 | ;;
  4 | ;; A *FAST* of a JPT/ZPT alike templating system in Clojure.
  5 | ;; Compiles XML template files into byte code via the Clojure compiler.
  6 | ;;
  7 | 
  8 | (ns webjure.cpt
  9 |   (:use webjure.xml)
 10 |   (:refer-clojure))
 11 | 
 12 | ;; (set! *warn-on-reflection* true)
 13 | 
 14 | (defmacro output [& things]
 15 |   `(do
 16 |      ~@(map (fn [t]
 17 | 	      (if (string? t)
 18 | 		`(.write ~'output ~t)
 19 | 		`(.write ~'output (str ~t)))) things)))
 20 | 
 21 | (comment
 22 |   (defn output "Apply str to things and print the result" [& things]
 23 |     (print (apply str things))))
 24 | 
 25 | 
 26 | (defn- load-template-xml [path]
 27 |   (let [xml-string (slurp path)]
 28 |     (.getDocumentElement
 29 |      (load-dom 
 30 |       (if (.startsWith xml-string "<?xml")
 31 | 	xml-string
 32 | 	(str "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n" xml-string))))))
 33 |  
 34 | (def +cpt-ns+  "http://webjure.org/namespaces/cpt")
 35 | 
 36 | (defn- cpt-attribute? [{name :name}]
 37 |   (or (= name "xmlns:cpt")
 38 |       (.startsWith name "cpt:")))
 39 | 
 40 | (defn- attr-seq 
 41 |   ([elt] (attr-seq (.getAttributes elt) 0))
 42 |   ([node-map index]
 43 |      (if (>= index (.getLength node-map))
 44 |        nil
 45 |        (cons (let [attr (.item node-map index)]
 46 | 	       {:name (.getName attr)
 47 | 		:value (.getValue attr)
 48 | 		:ns (.getNamespaceURI attr)})
 49 | 	     (attr-seq node-map (+ index 1))))))
 50 | 
 51 | (defmulti handle-node (fn [_ elt] (type-of elt)))
 52 | 
 53 | (defn- string-reader [str]
 54 |   (java.io.PushbackReader. (java.io.StringReader. str)))
 55 | 
 56 | (defn- read-many 
 57 |   ([str] (read-many (string-reader str) []))
 58 |   ([rdr acc]
 59 |      (let [item (read rdr false :eof)]
 60 |        (if (= item :eof)
 61 | 	 acc
 62 | 	 (read-many rdr (conj acc item))))))
 63 | 
 64 | (defn- read-first "Read the first form in the given input string. Returns the read item and the remaining string."
 65 |   [string]
 66 |   (let [rdr (string-reader string)
 67 | 	item (read rdr)]
 68 |     (loop [acc ""
 69 | 	   ch (.read rdr)]
 70 |       (if (= -1 ch)
 71 | 	[item acc]
 72 | 	(recur (str acc (char ch))
 73 | 	       (.read rdr))))))
 74 |   
 75 | 
 76 | (defn- get-and-remove-attribute [elt attr]
 77 |   (let [value (.getAttribute elt attr)]
 78 |     (.removeAttribute elt attr)
 79 |     (if (empty? value)
 80 |       nil
 81 |       value)))
 82 | 
 83 | (defmacro ^{:private true} define-attribute-handler [name attribute ctx-var attr-var elt-var & body]
 84 |   `(defn ~name [~ctx-var ~elt-var]     
 85 |       (let [~attr-var (get-and-remove-attribute ~elt-var ~attribute)]
 86 |         (if (not (nil? ~attr-var))
 87 | 	  (do ~@body)
 88 | 	  nil))))
 89 | 
 90 | (declare handle-element)
 91 | 
 92 | (define-attribute-handler handle-let "cpt:let" ctx value elt
 93 |   `(let [~@(read-many value)]
 94 |      ~(handle-element ctx elt)))
 95 | 
 96 | (define-attribute-handler handle-when "cpt:when" ctx value elt
 97 |   `(when ~(read-string value)
 98 |      ~(handle-element ctx elt)))
 99 | 
100 | (define-attribute-handler handle-repeat "cpt:repeat" ctx value elt
101 |   (let [[var items] (read-many value)
102 | 	var-idx (symbol (str var "-idx"))]
103 |     `(let [items# ~items
104 | 	   item-count# (count items#)]
105 |        (loop [[item# & items#] items#
106 | 	      i# 0
107 | 	      ~var-idx 0]
108 |        (when (< i# item-count#)
109 | 	 (let [~var item#]
110 | 	   ~(handle-element ctx (.cloneNode elt true))
111 | 	   (recur items# (+ i# 1) (+ 1 ~var-idx))))))))
112 | 
113 | (define-attribute-handler handle-replace "cpt:replace" ctx value elt
114 |   `(output ~@(read-many value)))
115 | 
116 | (define-attribute-handler handle-include "cpt:include" ctx value elt
117 |   (let [base-path (.getParentFile (:template-file ctx))
118 | 	included-template (java.io.File. base-path value)
119 | 	include (load-template-xml (.getAbsolutePath included-template))
120 | 	ctx (assoc ctx :template-file included-template)]
121 |     (handle-node ctx include)))
122 | 
123 | (defn escape-xml "Escape XML entities: &, < and >." [evil]
124 |   (let [^String s (str evil)]
125 |     (.replace (.replace (.replace s "&" "&amp;")
126 | 			"<" "&lt;")
127 | 	      ">" "&gt;")))
128 | 
129 | (defn handle-text "Expands code to output text with $ form references." 
130 |   ([text] (handle-text text []))
131 |   ([text acc]     
132 |      (if (empty? text)
133 |        `(output ~@acc)
134 |        (let [dollar-pos (.indexOf text "$")]
135 | 	 (if (= -1 dollar-pos)
136 | 	   ;; No expansions, output whole text
137 | 	   `(output ~@acc ~text)
138 | 	   ;; Expansion found
139 | 	   (let [before (.substring text 0 dollar-pos)
140 | 		 text (.substring text (+ 1 dollar-pos))
141 | 		 escape? (not (.startsWith text "@"))
142 | 		 text (if escape? text (.substring text 1))
143 | 		 [item after] (read-first text)]
144 | 	     (handle-text after (concat acc [before (if escape?
145 | 						      `(escape-xml ~item)
146 | 						      item)]))))))))
147 | 
148 | ;; This is bound to a (ref {}) during template processing
149 | (def *magic-resources* nil)
150 | 
151 | (defn sha1 [data]
152 |   (let [md (java.security.MessageDigest/getInstance "SHA-256")]    
153 |     (format "%064x" (BigInteger. 1 (.digest md (.getBytes data "UTF-8"))))))
154 | 
155 | (defn handle-magic-resource [ctx elt]
156 |   (let [tag (.getTagName elt)
157 | 	[first-child & other-children] (children elt)]
158 | 
159 |     ;; Only consider a magic resource if this element
160 |     ;; has exactly one child which is a CDATA section
161 |     (when (and first-child
162 | 	       (empty? other-children)
163 | 	       (= :cdata-section (type-of first-child)))
164 | 
165 |       (let [txt (.getWholeText first-child)
166 | 	    hash (sha1 txt)]
167 | 	(when (> (count txt) 512) ;; don't magic resource things under half a kb
168 | 	  (cond
169 | 	   (= tag "style") (do
170 | 			     (dosync
171 | 			      (alter *magic-resources*
172 | 				     assoc (str hash ".css") {:content-type "text/css"
173 | 							      :data txt}))
174 | 			     `(output ~(str "<link rel=\"stylesheet\" type=\"text/css\" href=\"/static/"
175 | 					    hash ".css\" />")))
176 | 	   (= tag "script") `(do (output "<script>alert('script thief was here!');</script>"))))))))
177 | 	 
178 | (defn handle-element [ctx elt]
179 |   (.normalize elt) ;; ensure Text nodes are intact
180 |   (or (handle-let ctx elt)
181 |       (handle-when ctx elt)
182 |       (handle-repeat ctx elt)
183 |       (handle-replace ctx elt)
184 |       (handle-include ctx elt)
185 |       (handle-magic-resource ctx elt)
186 |       
187 |       ;; Normal handling, after most specials have been taken care of
188 |       (let [tag (.getTagName elt)
189 | 	    attrs (filter #(not (cpt-attribute? %)) (attr-seq elt))
190 | 	    children (children elt)
191 | 	    omit? (= tag "cpt:block")]	
192 | 	(if (and (empty? attrs) (empty? children))
193 | 	  (if omit? nil `(output ~(str "<" tag "/>")))
194 | 	  (if omit?
195 | 	    `(do ~@(map #(handle-node ctx %) children))
196 | 	    `(do (output ~(str "<" tag))
197 | 		 ~@(let [cpt-attributes (first (filter #(= "cpt:attributes" (:name %)) (attr-seq elt)))]
198 | 		     (when cpt-attributes
199 | 		       `[ (doseq [[n# v#] ~(read-string (:value cpt-attributes))]
200 | 			    (output " " n#)
201 | 			    (when v#
202 | 			      (output "=\"" v# "\""))) ]))
203 | 	       
204 | 		 ~@(map (fn [{name :name, value :value}]
205 | 			  `(do 
206 | 			     (output ~(str " " name "=\""))
207 | 			     ~(handle-text value)
208 | 			     (output "\"")))
209 | 			attrs)
210 | 		 (output ">")
211 | 		 ~@(map #(handle-node ctx %) children)
212 | 		 (output ~(str "</" tag ">"))))))))
213 |       
214 | (defmethod handle-node :element [ctx elt]
215 |   (handle-element ctx elt))
216 | 
217 | (defmethod handle-node :default [ctx node]
218 |   true)
219 | 
220 | (defmethod handle-node :text [ctx node]
221 |   ;; NOTE: If the document is not in the normalized form, text may be split into
222 |   ;; multiple adjacent text nodes. We may need to preprocess and join them... 
223 |   (handle-text (.getWholeText node)))
224 | 
225 | 
226 | (defn output-form? [form]
227 |   (and (coll? form)
228 |        (= 'webjure.cpt/output (first form))))
229 | 
230 | (defmacro ^{:private true} define-form-reduction [name initial-test-fn reduce-test-fn reduce-fn]
231 |   `(defn ^{:private true} ~name [form#]
232 |      (if (not (~initial-test-fn form#))
233 |        form#
234 |        (loop [acc# []
235 | 	      [current# & items#] form#]
236 | 	 (if (nil? current#)
237 | 	   (apply list acc#)
238 | 	   (if (not (~reduce-test-fn current#))
239 | 	     (recur (conj acc# (~name current#)) items#)
240 | 	     ;; current item is reduceable
241 | 	     (if (~reduce-test-fn (last acc#))
242 | 	       ;; previous item is reduceable, combine with that
243 | 	       (recur (conj (vec (butlast acc#))
244 | 			    (~reduce-fn (last acc#) current#))
245 | 		      items#)
246 | 	       (recur (conj acc# current#) items#))))))))
247 | 
248 | ;; Define reduction to reduce adjacent string literals
249 | ;; eg. (output "foo" "bar") => (output "foobar")
250 | (define-form-reduction optimize-output-form 
251 |   output-form? string? str)
252 |   
253 | ;; Define reduction to reduce adjacent output calls to a single call
254 | ;; eg. (do (output "foo") (output "bar")) => (do (output "foo" "bar"))
255 | ;; Calls optimize-output-form on the resulting output calls to further
256 | ;; optimize them.
257 | (define-form-reduction optimize-adjacent-output-forms 
258 |   #(and (not (vector? %)) (coll? %))
259 |   output-form?
260 |   (fn [left right]
261 |     (optimize-output-form `(output ~@(rest left) ~@(rest right)))))
262 | 
263 | (defn- do-form? [form]
264 |   (and (coll? form) (= 'do (first form))))
265 | 
266 | (defn flatten-nested-do "Flatten code in nested do structures. Turns (do a b (do c d)) into (do a b c d)" 
267 |   [form]
268 |   (if (or (vector? form) (not (coll? form)))
269 |     form ;; not a list form, just return this
270 |     (if (not (do-form? form))
271 |       ;; not a (do ...) form, apply optimization recursively
272 |       (map flatten-nested-do form)
273 |       (loop [acc []
274 | 	     [item & items] (rest form)]
275 | 	(if (nil? item)
276 | 	  `(do ~@acc)
277 | 	  (let [optimized-item (flatten-nested-do item)]
278 | 	    (if (do-form? optimized-item)
279 | 	      (recur (concat acc (vec (rest optimized-item)))
280 | 		     items)
281 | 	      (recur (conj (vec acc) optimized-item)
282 | 		     items))))))))
283 |     
284 | (defn optimize [form]
285 |   (optimize-adjacent-output-forms (flatten-nested-do form)))
286 | 
287 | 	
288 | (def *template-path* nil)
289 | 
290 | (defn- template-path []
291 |   (or *template-path* (System/getProperty "webjure.cpt.path")))
292 | 
293 | (def *reload-templates* (ref false))
294 | 
295 | (defn set-reload-templates! [reload?]
296 |   "Set wether or not to reload templates. This affects only templates defined after setting the value."
297 |   (dosync
298 |    (ref-set *reload-templates* reload?)))
299 | 
300 | (defn- generate-template-defn [name file ctx]
301 |   (binding [*magic-resources* (ref {})]
302 |     (let [code    `(do
303 | 		     (defn ~name 
304 | 		       ([~'here] (~name *out* ~'here))
305 | 		       ([~'^java.io.Writer output ~'here]
306 | 			  ~@(optimize (handle-node ctx (load-template-xml (.getCanonicalPath file))))))
307 | 		     ~@(map (fn [[name {ct :content-type data :data}]]
308 | 			      `(webjure/defh ~(str "/static/" name) [] {}
309 | 				 (doto webjure/*response*
310 | 				   (.setDateHeader "Date" (System/currentTimeMillis))
311 | 				   (.setDateHeader "Last-Modified" (- (System/currentTimeMillis)
312 | 								      ~(* 1000 60 60 24)))
313 | 				   (.setDateHeader "Expires" (+ (System/currentTimeMillis)
314 | 								~(* 1000 60 60 24 350)))
315 | 				   (.setHeader "Cache-Control" "public")
316 | 				   (.setHeader "Vary" "Accept-Encoding"))
317 | 				 (webjure/send-output ~ct ~data)))
318 | 			    @*magic-resources*))]
319 |      ;; (println "magic resources after processing: " (str @*magic-resources*))
320 |       code)))
321 |        
322 | 
323 | (defn generate-reloading-template-defn [name file ctx]
324 |   `(defn ~name 
325 |      ([~'here] (~name *out* ~'here))
326 |      ([~'^java.io.Writer output ~'here]
327 | 	(println ~(str "RELOADING TEMPLATE " (.getCanonicalPath file)))
328 | 	(binding [*ns* (find-ns '~(ns-name *ns*))]
329 | 	  ((eval '(template ~(.getCanonicalPath file))) ~'output ~'here)))))
330 | 
331 |   
332 | (defmacro define-template 
333 |   "Define a template as a function at compile time."
334 |   [name file]  
335 |   (let [file (java.io.File. (template-path) file)
336 | 	ctx {:template-file file}]
337 |     (if (not (.canRead file))
338 |       (throw (IllegalArgumentException. (str "Unable to define template \"" (.getCanonicalPath file) "\". The specified file cannot be read. (Maybe you need to define \"webjure.cpt.path\" system property)")))
339 |       (if @*reload-templates*
340 | 	(generate-reloading-template-defn name file ctx)
341 | 	(generate-template-defn name file ctx)))))
342 | 
343 | (defmacro template [file]
344 |   "Compile a template into a function. (fn [here] ...)"
345 |   (let [ctx {:template-file (java.io.File. file)}]
346 |     `(fn [~'output ~'here]
347 |        ~@(optimize (handle-node ctx (load-template-xml file))))))


--------------------------------------------------------------------------------
/webjure/src/webjure.clj:
--------------------------------------------------------------------------------
  1 | 
  2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3 | ;; Webjure - a web framework for Clojure
  4 | ;;
  5 | ;; Author: Tatu Tarvainen
  6 | ;;
  7 | 
  8 | (ns webjure
  9 |     (:refer-clojure)
 10 |     (:require (webjure html json)))
 11 | 
 12 | ;;;;;;;;;;;;;;;;;;;;;;
 13 | ;; Global vars 
 14 | 
 15 | (def +version+ "Webjure 0.8")
 16 | 
 17 | ;; The *request* and *response* vars are bound to the servlet/portlet request and
 18 | ;; response objects fo the request currently being handled.
 19 | (def *request*) 
 20 | (def *response*) 
 21 | 
 22 | (def #^{:doc "The matched handler info is bound here during dispatch."}
 23 |      *matched-handler* nil)
 24 | 
 25 | 
 26 | ;;;;;;;;;;;;;;;;;;;;;
 27 | ;; String utilities
 28 | 
 29 | (defn starts-with? [#^String str #^String prefix]
 30 |   (. str (startsWith prefix)))
 31 | 
 32 | (defn ends-with? [#^String str #^String suffix]
 33 |   (. str (endsWith suffix)))
 34 | 
 35 | (defn strlen [#^String str]
 36 |   (. str (length)))
 37 | 
 38 | (defn substr 
 39 |   ([#^String s start] (. s (substring start)))
 40 |   ([#^String s start end] (. s (substring start end))))
 41 | 
 42 | (defn append [#^java.lang.Appendable out & #^String stuff]
 43 |   (doseq [thing stuff]
 44 |       (. out (append (str thing)))))
 45 | 
 46 | (defn 
 47 |   #^{:doc "URL encode a string."}
 48 |   urlencode 
 49 |   ([#^String s] (urlencode s "UTF-8"))
 50 |   ([#^String s #^String encoding] 
 51 |      (. java.net.URLEncoder (encode s encoding))))
 52 | 
 53 | (defn 
 54 |   #^{:doc "Decode an URL encoded string."}
 55 |   urldecode
 56 |   ([#^String s] (urldecode s "UTF-8"))
 57 |   ([#^String s #^String encoding]
 58 |      (. java.net.URLDecoder (decode s encoding))))
 59 |      
 60 | 
 61 | ;;;;;;;;;;;;;;;;;;;;;
 62 | ;; Handler dispatch
 63 | 
 64 | ;; List of handlers as [fn url-pattern]
 65 | (def *handlers* (ref (list)))
 66 | 
 67 | ;; This is called to register a handler
 68 | (defn 
 69 |   #^{:doc "Publish a handler function for the given URL pattern. The pattern may be a string or a regular expression pattern."}
 70 |   publish [fn url-pattern]
 71 |   (if (not (instance? clojure.lang.IFn fn))
 72 |     (throw (new java.lang.IllegalArgumentException "First argument must be function")))
 73 |   (dosync 
 74 |    (ref-set *handlers*
 75 | 	    (conj (filter 
 76 | 		   #(not (= url-pattern (second %))) ; filter out previous handlers with the same pattern
 77 | 		   @*handlers*)
 78 | 		  [fn url-pattern]))))
 79 | 
 80 | (defn 
 81 |   #^{:private true :doc "Check if handler matches the input URL. Returns a match object (map) or nil."}
 82 |   handler-matches? [[handler-fn url-pattern] pattern]
 83 |   (cond
 84 |    (instance? java.util.regex.Pattern url-pattern)
 85 |    (let [m (re-find url-pattern pattern)]
 86 |      (if m
 87 |        {:handler handler-fn
 88 |         :priority 0
 89 |         :groups m}
 90 | 	nil))
 91 |     
 92 |    (or (and (ends-with? url-pattern "*")
 93 | 	    (starts-with? pattern (substr url-pattern 0 (- (strlen url-pattern) 1)))
 94 | 	    true)
 95 |        (and (= pattern url-pattern)))
 96 |    {:handler handler-fn :priority (strlen url-pattern)}))
 97 | 
 98 | 
 99 | (defn 
100 |   #^{:private true}
101 |   find-handler [url-pattern]
102 |   (let [matching-handlers (filter #(not (nil? %))
103 | 				  (map (fn [handler] 
104 | 					   (handler-matches? handler url-pattern)) @*handlers*))
105 | 	shortest-match    (first (sort-by :priority matching-handlers))]
106 |     shortest-match))
107 | 
108 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
109 | ;; Access to servlet info
110 | ;; Getters for request / response 
111 | 
112 | 
113 | ;; Servlets use a lot of old Enumerations, which need to be turned into sequences
114 | (defn 
115 |   #^{:doc "Convert a Java Enumeration into a Clojure sequence."}
116 |   enumeration->list [#^java.util.Enumeration en]
117 |   (loop [acc (list)]
118 |     (if (not (. en (hasMoreElements)))
119 |       (reverse acc)
120 |       (recur (conj acc (. en (nextElement)))))))
121 | 
122 | (defprotocol Request
123 |   "Webjure request abstraction"
124 |   (get-request-path [x])
125 |   (get-request-headers [x])
126 |   (get-request-param [x name])
127 |   (get-request-param-values [x name])
128 |   (get-request-params [x])
129 |   (get-request-base-url [x])
130 |   (get-request-input-stream [x])
131 |   (create-url [x mode-or-path args])
132 |   (get-request-session-attribute [x attribute])
133 |   (set-request-session-attribute [x attribute value])
134 |   (remove-request-session-attribute [x attribute]))
135 | 
136 | (defprotocol Response
137 |   "Webjure response abstraction"
138 |   (get-response-writer [x])
139 |   (send-response-error [x error-code error-message])
140 |   (set-response-content-type [x type])
141 |   (send-response-redirect [x to]))
142 | 
143 | ;; Implement the Request abstraction for HTTP Servlets 
144 | (extend-protocol Request
145 |   javax.servlet.http.HttpServletRequest
146 |   (get-request-path [req] (.getPathInfo req))
147 |   (get-request-headers
148 |    [req]
149 |    (let [names (enumeration->list (.getHeaderNames req))]
150 |      (zipmap names
151 | 	     (map #(enumeration->list (.getHeaders req %)) names))))
152 |   (get-request-param
153 |    [req name]
154 |    (.getParameter req name))
155 |   (get-request-param-values
156 |    [req name]
157 |    (seq (.getParameterValues req name)))
158 |   (get-request-params
159 |    [req]
160 |    (let [params (seq (.getParameterMap req))]
161 |      (zipmap (map first params)
162 | 	     (map #(seq (second %)) params))))
163 |   (get-request-base-url
164 |    [req]
165 |    (str (.getScheme req)
166 | 	"://"
167 | 	(.getServerName req)
168 | 	(let [port (.getServerPort req)]
169 | 	  (if (not (or (== port 80) (== port 443)))
170 | 	    (str ":" port)
171 | 	    ""))
172 | 	(.getContextPath req)))
173 |   (get-request-input-stream
174 |    [req]
175 |    (.getInputStream req))
176 |   (create-url
177 |    [req path args]
178 |    (str
179 |     (get-request-base-url req)
180 |     path
181 |     "?" 
182 |     (reduce str
183 | 	    (interleave (map (fn [key]
184 | 			       (str (urlencode (if (keyword? key)
185 | 						 (substr (str key) 1)
186 | 						 key))
187 | 				    "=" (urldecode (get args key))))
188 | 			     (keys args))
189 | 			(repeat "&")))))
190 |   (get-request-session-attribute
191 |    [req attribute]
192 |    (.getAttribute (.getSession req) attribute))
193 |   (set-request-session-attribute
194 |    [req attribute value]
195 |    (.setAttribute (.getSession req) attribute value))
196 |   (remove-request-session-attribute
197 |    [req attribute]
198 |    (.removeAttribute (.getSession req) attribute))
199 |   )
200 | 
201 | (extend-protocol Response
202 |   javax.servlet.http.HttpServletResponse
203 |   (get-response-writer [res] (.getWriter res))
204 |   (send-response-error [res error-code error-message] (.sendError res error-code error-message))
205 |   (set-response-content-type [res type]
206 | 			     (.setContentType res type))
207 |   (send-response-redirect [res to]
208 | 			  (.sendRedirect res to)))
209 | 
210 | 		      
211 | (defn 
212 |   #^{:doc "Returns the request path information (servlet only)"}
213 |   request-path 
214 |   ([] (request-path *request*))
215 |   ([request] (get-request-path request)))
216 | 
217 | (defn 
218 |   #^{:doc "Get a Writer object for this response."}
219 |   response-writer 
220 |   ([] (response-writer *response*))
221 |   ([response] (. response (getWriter))))
222 | 
223 | (defn request-headers 
224 |   ([] (request-headers *request*))
225 |   ([request] (get-request-headers request)))
226 | 
227 | 
228 | ;; Dynamically calculate and return the app baseurl
229 | ;; based on the current request
230 | (defn base-url 
231 |   ([] (base-url *request*))
232 |   ([request]
233 |      (get-request-base-url request)))
234 | 
235 | ;; FIXME: implement Request abstraction fro PortletRequest 
236 | (defn 
237 |   ^{:private true}
238 |   create-portlet-url [^javax.portlet.PortletRequest request mode args] 
239 |   (let [url (if (= :action mode)
240 |               (. *response* (createActionURL))
241 |               (. *response* (createRenderURL)))]
242 |     (doseq [key (keys args)]
243 |       (. url (setParameter key (get args key))))
244 |     (. url (toString))))
245 | 
246 | ;; Generate an HREF link.
247 | ;; For portlets the mode-or-path must be :action or :render
248 | ;; and for servlets it must be a string path element
249 | (defn url "Generate an HREF URL given a path (or mode for portlets) and GET parameters."
250 |   ([mode-or-path] (url mode-or-path {}))
251 |   ([mode-or-path args]
252 |      (create-url *request* mode-or-path args)))
253 | 
254 | 
255 | (defn request-parameter "Get the value of a single valued request parameter."
256 |   [^String name]
257 |   (get-request-param *request* name))
258 | 
259 | 
260 | (defn   
261 |   multi-request-parameter "Get the values of a multi valued request parameter as a sequence."
262 |   [^String name]
263 |   (get-request-param-values *request* name))
264 | 
265 | 
266 | ;; Return mapping {"param name" [values], ...}
267 | ;; of request parameters
268 | (defn request-parameters "Return a mapping of parameter names to sequences of values."
269 |   ([] (request-parameters *request*))
270 |   ([request] 
271 |      (get-request-params request)))
272 | 
273 |        
274 |        
275 | (defn generate-request-binding [sym accessor]
276 |   (cond 
277 |    (instance? String accessor)
278 |    `[~sym (request-parameter ~accessor)]
279 | 
280 |    (instance? Number accessor)
281 |    `[~sym (nth (*matched-handler* :groups) ~accessor)]
282 | 
283 |    :default
284 |    (let [multi (:multiple accessor)
285 | 	 name (:name accessor)
286 | 	 group (:group accessor)
287 | 	 validator (or (:validator accessor) 'identity)]
288 |      `[~sym ~(if group
289 | 	       `(~validator (nth (*matched-handler* :groups) ~group))
290 | 	       (if multi
291 | 		 `(map ~validator (multi-request-parameter ~name))
292 | 		 `(~validator (request-parameter ~name))))])))
293 | 
294 | ;; Bind request parameters (GET/POST) to variables
295 | ;; A binding is a symbol and an access definition.
296 | ;; The access definition can be a string or a map containing
297 | ;; options. If the definition is a string the named parameter
298 | ;; is just returned as a string.
299 | ;; For option map access definitions, the following option
300 | ;; keys can be used: :name (the request param name, required),
301 | ;; :multiple (if true the value is a seq of values, defaults to no) and
302 | ;; :validator (a form that returns the validated value of the parameter value)
303 | ;; 
304 | (defmacro request-bind [bindings & body]
305 |   `(let [~@(loop [forms nil
306 |                   splits (split-at 2 bindings)]
307 | 	     (let [binding (first splits)]
308 | 	       (if (empty? binding)
309 | 		 forms
310 | 		 (recur 
311 | 		  (concat forms (apply generate-request-binding binding))
312 | 		  (split-at 2 (second splits))))))] 
313 |      ~@body))
314 | 
315 |   
316 | ;; Fetch the value of a session attribute
317 | ;; if initial-value is specified and the given
318 | ;; attribute does not exist in the session, 
319 | ;; the initial-value stored in the session and
320 | ;; returned. If initial-value is an IFn then
321 | ;; it is invoked to produce the value to store.
322 | (defn session-get "Get a stored value from the client session by key. Initial value (which may be a function that generates a value) will be used if specified and no value is stored in the session."
323 |   ([attribute] (get-request-session-attribute *request* attribute))
324 |   ([attribute initial-value]
325 |      (let [val (get-request-session-attribute *request* attribute)]
326 |        (if (nil? val)
327 | 	 (let [new-value (if (fn? initial-value)
328 | 			   (initial-value)
329 | 			   initial-value)]
330 | 	   (set-request-session-attribute *request* attribute new-value)
331 | 	   new-value)
332 | 	 val))))
333 | 
334 | (defn session-set "Store a value by key in the client session." 
335 |   [name value]
336 |   (set-request-session-attribute *request* name value))
337 | 
338 | (defn session-remove "Remove a value by key in the client session."
339 |   [name]
340 |   (remove-request-session-attribute *request* name))
341 | 
342 | (defn send-error 
343 |   ([code message] (send-error *response* code message))
344 |   ([response code message]     
345 |      (send-response-error response code message)))
346 | 
347 | 
348 | ;; The main dispatch function. This is called from WebjureServlet
349 | (defn dispatch [^String method 
350 | 		request 
351 | 		response]
352 |   (binding [*request* request
353 | 	    *response* response]
354 |     (binding [*matched-handler* (find-handler (request-path *request*))]
355 |       (if (= nil *matched-handler*)
356 | 	;; No handler found, give a 404
357 | 	;; PENDING: Add 404-handler support (a special dispatch url, like :default)
358 | 	(send-error 404 (str "No matching handler found for path: " (request-path request)))
359 | 	
360 | 	;; Run the handler
361 | 	((*matched-handler* :handler))))))
362 | 
363 | 
364 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
365 | ;; Useful code for webjure apps
366 | 
367 | (defn send-output "Send string output to client with given content-type."
368 |   ([content-type content] (send-output *response* content-type content))
369 |   ([response ^String content-type ^String content]
370 |    (set-response-content-type response content-type)
371 |    (.append (get-response-writer response) content)))
372 | 
373 | (defn slurp-post-data "Read POST data and return it as a  string."
374 |   ([] (slurp-post-data *request*))
375 |   ([request]
376 |      (let [sb (new StringBuilder)]
377 |        (with-open [in (new java.io.BufferedReader 
378 | 			   (new java.io.InputStreamReader 
379 | 				(get-request-input-stream request)))]
380 | 	 (loop [ch (.read in)]
381 | 	   (if (< ch 0)
382 | 	     (.toString sb)
383 | 	     (do
384 | 	       (.append sb (char ch))
385 | 	       (recur (.read in)))))))))
386 | 
387 | 
388 | 
389 | (defn format-date "Format date using a SimpleDateFormat pattern."
390 |   ([^String fmt ^java.util.Date date] (.format (java.text.SimpleDateFormat. fmt) date))
391 |   ([^String fmt] (.format (java.text.SimpleDateFormat. fmt) (java.util.Date.))))
392 | 
393 | 
394 | ;; Define a handler function
395 | ;; options is a map of automagic behaviour.
396 | ;; currently supported is {:output <type>} (<type> can be :html)
397 | ;; that automatically sends the return value as a response 
398 | (defmacro defh [url request-bindings options & body]
399 |   `(publish (fn []
400 |               (request-bind ~request-bindings
401 |                             ~@(cond
402 | 			       ;; Output anything that is printed
403 | 			       (= :print (options :output))
404 | 			       `((set-response-content-type *response* (or ~(options :content-type) "text/html"))
405 | 				 (binding [*out* (response-writer)]
406 | 				   ~@body))
407 | 
408 | 			       ;; Output CSV 
409 | 			       (= :csv (options :output))
410 | 			       `((set-response-content-type *response* (or ~(options :content-type) "text/csv"))
411 | 				 (webjure.csv/csv-format (do ~@body)))
412 | 				       
413 | 				   
414 | 			       ;; Output text/plain
415 | 			       (= :text (options :output))
416 | 			       `((send-output "text/plain" (do ~@body)))
417 | 			       
418 | 			       ;; Output HTML with optional doctype declaration
419 | 			       (= :html (options :output))
420 | 			       `((let [out# (response-writer)
421 | 				       doctype# ~(:doctype options)]
422 | 				   (set-response-content-type *response* "text/html")
423 | 				   (if doctype#
424 | 				     (append out# (str doctype# "\n")))
425 | 				   (webjure.html/html-format out# (do ~@body))))
426 | 
427 | 			       ;; Output JSON 
428 | 			       (= :json (options :output))
429 | 			       `((set-response-content-type *response* "application/json")
430 | 				 (webjure.json/serialize (response-writer)
431 | 							 (do ~@body)))
432 | 
433 | 			       :default body)))
434 | 	    ~url))
435 | 
436 |   
437 | (defmacro define-static-resource [file content-type url-path]
438 |   (let [content (slurp file)]
439 |     `(defh ~url-path [] {}
440 |        (send-output ~content-type ~content))))
441 | 


--------------------------------------------------------------------------------