├── .gitignore
├── .travis.yml
├── README.markdown
├── caveman-middleware-dbimanager.asd
├── caveman2-db.asd
├── caveman2-test.asd
├── caveman2.asd
└── v2
    ├── skeleton
        ├── .gitignore
        ├── README.markdown
        ├── app.lisp
        ├── db
        │   └── schema.sql
        ├── skeleton-test.asd
        ├── skeleton.asd
        ├── src
        │   ├── config.lisp
        │   ├── db.lisp
        │   ├── main.lisp
        │   ├── view.lisp
        │   └── web.lisp
        ├── static
        │   └── css
        │   │   └── main.css
        ├── templates
        │   ├── _errors
        │   │   └── 404.html
        │   ├── index.html
        │   └── layouts
        │   │   └── default.html
        └── tests
        │   └── skeleton.lisp
    ├── src
        ├── app.lisp
        ├── caveman.lisp
        ├── db.lisp
        ├── exception.lisp
        ├── helper.lisp
        ├── middleware
        │   └── dbimanager.lisp
        ├── nested-parameter.lisp
        ├── route.lisp
        └── skeleton.lisp
    └── t
        ├── caveman.lisp
        ├── nested-parameter.lisp
        └── route.lisp


/.gitignore:
--------------------------------------------------------------------------------
 1 | *.fasl
 2 | *.dx32fsl
 3 | *.dx64fsl
 4 | *.lx32fsl
 5 | *.lx64fsl
 6 | *.x86f
 7 | *~
 8 | .#*
 9 | v1/t/tmp
10 | v2/t/tmp
11 | 


--------------------------------------------------------------------------------
/.travis.yml:
--------------------------------------------------------------------------------
 1 | language: common-lisp
 2 | sudo: false
 3 | 
 4 | env:
 5 |   global:
 6 |     - PATH=~/.roswell/bin:$PATH
 7 |     - ROSWELL_BRANCH=release
 8 |     - ROSWELL_INSTALL_DIR=$HOME/.roswell
 9 |   matrix:
10 |     - LISP=sbcl-bin
11 |     - LISP=ccl-bin
12 | 
13 | install:
14 |   # Install Roswell
15 |   - curl -L https://raw.githubusercontent.com/roswell/roswell/$ROSWELL_BRANCH/scripts/install-for-ci.sh | sh
16 |   - ros install prove
17 |   - ros install fukamachi/cl-project
18 | 
19 | script:
20 |   - ros -s caveman2-test
21 |   - run-prove caveman2-test.asd
22 | 


--------------------------------------------------------------------------------
/README.markdown:
--------------------------------------------------------------------------------
  1 | # Caveman2 - Lightweight web application framework
  2 | 
  3 | [![Build Status](https://travis-ci.org/fukamachi/caveman.svg?branch=master)](https://travis-ci.org/fukamachi/caveman)
  4 | 
  5 | ## Usage
  6 | 
  7 | ```common-lisp
  8 | (defparameter *web* (make-instance '<app>))
  9 | 
 10 | @route GET "/"
 11 | (defun index ()
 12 |   (render #P"index.tmpl"))
 13 | 
 14 | @route GET "/hello"
 15 | (defun say-hello (&key (|name| "Guest"))
 16 |   (format nil "Hello, ~A" |name|))
 17 | ```
 18 | 
 19 | ## About Caveman2
 20 | 
 21 | ### What's different from Caveman "1"?
 22 | 
 23 | Everything. Caveman2 was written from scratch.
 24 | 
 25 | These are noteworthy points.
 26 | 
 27 | * Is based on [ningle](http://8arrow.org/ningle/)
 28 | * Has database integration
 29 | * Uses new, separate configuration system ([Envy](https://github.com/fukamachi/envy))
 30 | * Has new routing macro
 31 | 
 32 | ### The reason I wrote it from scratch:
 33 | 
 34 | One of the most frequently asked questions was "Which should I use: ningle or Caveman? What are the differences?" I think these were asked so frequently because Caveman and ningle were too similar. Both of them are called "micro", and had no database support.
 35 | 
 36 | With Caveman2, Caveman is no longer a "micro" web application framework. It supports CL-DBI, and has database connection management by default. Caveman has started growing up.
 37 | 
 38 | ## Design Goal
 39 | 
 40 | Caveman is intended to be a collection of common parts of web applications. With Caveman2, I use three rules to make decisions:
 41 | 
 42 | * Be extensible.
 43 | * Be practical.
 44 | * Don't force anything.
 45 | 
 46 | ## Quickstart
 47 | 
 48 | You came here because you're interested in living like a caveman, right? This isn't Disneyland, but we can start here. Let's get into a cave!
 49 | 
 50 | ### Installation
 51 | 
 52 | Caveman2 is now available on [Quicklisp](https://www.quicklisp.org/beta/).
 53 | 
 54 | ```common-lisp
 55 | (ql:quickload :caveman2)
 56 | ```
 57 | 
 58 | ### Generating a project skeleton
 59 | 
 60 | ```common-lisp
 61 | (caveman2:make-project #P"/path/to/myapp/"
 62 |                        :author "<Your full name>")
 63 | ;-> writing /path/to/myapp/.gitignore
 64 | ;   writing /path/to/myapp/README.markdown
 65 | ;   writing /path/to/myapp/app.lisp
 66 | ;   writing /path/to/myapp/db/schema.sql
 67 | ;   writing /path/to/myapp/shlyfile.lisp
 68 | ;   writing /path/to/myapp/myapp-test.asd
 69 | ;   writing /path/to/myapp/myapp.asd
 70 | ;   writing /path/to/myapp/src/config.lisp
 71 | ;   writing /path/to/myapp/src/db.lisp
 72 | ;   writing /path/to/myapp/src/main.lisp
 73 | ;   writing /path/to/myapp/src/view.lisp
 74 | ;   writing /path/to/myapp/src/web.lisp
 75 | ;   writing /path/to/myapp/static/css/main.css
 76 | ;   writing /path/to/myapp/t/myapp.lisp
 77 | ;   writing /path/to/myapp/templates/_errors/404.html
 78 | ;   writing /path/to/myapp/templates/index.tmpl
 79 | ;   writing /path/to/myapp/templates/layout/default.tmpl
 80 | ```
 81 | 
 82 | ### Start a server
 83 | This is an example that assumes that the name of your application is "myapp".
 84 | Before starting the server, you must first load your app.
 85 | 
 86 | ```common-lisp
 87 | (ql:quickload :myapp)
 88 | ```
 89 | 
 90 | Your application has functions named `start` and `stop` to start/stop your web application. 
 91 | 
 92 | ```common-lisp
 93 | (myapp:start :port 8080)
 94 | ```
 95 | 
 96 | As Caveman is based on Clack/Lack, you can choose which server to run on -- Hunchentoot, Woo or Wookie, etc.
 97 | 
 98 | ```common-lisp
 99 | (myapp:start :server :hunchentoot :port 8080)
100 | (myapp:start :server :fcgi :port 8080)
101 | ```
102 | 
103 | I recommend you use Hunchentoot on a local machine, and use Woo in a production environment.
104 | 
105 | You can also start your application by using [clackup command](https://github.com/fukamachi/clack/blob/master/roswell/clackup.ros).
106 | 
107 |     $ ros install clack
108 |     $ which clackup
109 |     /Users/nitro_idiot/.roswell/bin/clackup
110 | 
111 |     $ APP_ENV=development clackup --server :fcgi --port 8080 app.lisp
112 | 
113 | ### Routing
114 | 
115 | Caveman2 provides 2 ways to define a route -- `@route` and `defroute`. You can use either.
116 | 
117 | `@route` is an annotation macro, defined by using [cl-annot](https://github.com/arielnetworks/cl-annot). It takes a method, a URL-string, and a function.
118 | 
119 | ```common-lisp
120 | @route GET "/"
121 | (defun index ()
122 |   ...)
123 | 
124 | ;; A route with no name.
125 | @route GET "/welcome"
126 | (lambda (&key (|name| "Guest"))
127 |   (format nil "Welcome, ~A" |name|))
128 | ```
129 | 
130 | This is similar to Caveman1's `@url` except for its argument list. You don't have to specify an argument when it is not required.
131 | 
132 | `defroute` is just a macro. It provides the same functionality as `@route`.
133 | 
134 | ```common-lisp
135 | (defroute index "/" ()
136 |   ...)
137 | 
138 | ;; A route with no name.
139 | (defroute "/welcome" (&key (|name| "Guest"))
140 |   (format nil "Welcome, ~A" |name|))
141 | ```
142 | 
143 | Since Caveman bases on ningle, Caveman also has the [Sinatra](http://www.sinatrarb.com/)-like routing system.
144 | 
145 | ```common-lisp
146 | ;; GET request (default)
147 | @route GET "/" (lambda () ...)
148 | (defroute ("/" :method :GET) () ...)
149 | 
150 | ;; POST request
151 | @route POST "/" (lambda () ...)
152 | (defroute ("/" :method :POST) () ...)
153 | 
154 | ;; PUT request
155 | @route PUT "/" (lambda () ...)
156 | (defroute ("/" :method :PUT) () ...)
157 | 
158 | ;; DELETE request
159 | @route DELETE "/" (lambda () ...)
160 | (defroute ("/" :method :DELETE) () ...)
161 | 
162 | ;; OPTIONS request
163 | @route OPTIONS "/" (lambda () ...)
164 | (defroute ("/" :method :OPTIONS) () ...)
165 | 
166 | ;; For all methods
167 | @route ANY "/" (lambda () ...)
168 | (defroute ("/" :method :ANY) () ...)
169 | ```
170 | 
171 | Route patterns may contain "keywords" to put the value into the argument.
172 | 
173 | ```common-lisp
174 | (defroute "/hello/:name" (&key name)
175 |   (format nil "Hello, ~A" name))
176 | ```
177 | 
178 | The above controller will be invoked when you access "/hello/Eitaro" or "/hello/Tomohiro", and `name` will be "Eitaro" or "Tomohiro", as appropriate.
179 | 
180 | `(&key name)` is almost same as a lambda list of Common Lisp, except it always allows other keys.
181 | 
182 | ```common-lisp
183 | (defroute "/hello/:name" (&rest params &key name)
184 |   ;; ...
185 |   )
186 | ```
187 | 
188 | Route patterns may also contain "wildcard" parameters. They are accessible by using `splat`.
189 | 
190 | ```common-lisp
191 | (defroute "/say/*/to/*" (&key splat)
192 |   ; matches /say/hello/to/world
193 |   (format nil "~A" splat))
194 | ;=> (hello world)
195 | 
196 | (defroute "/download/*.*" (&key splat)
197 |   ; matches /download/path/to/file.xml
198 |   (format nil "~A" splat)) 
199 | ;=> (path/to/file xml)
200 | ```
201 | 
202 | If you'd like to write use a regular expression in a URL rule, `:regexp t` should work.
203 | 
204 | ```common-lisp
205 | (defroute ("/hello/([\\w]+)" :regexp t) (&key captures)
206 |   (format nil "Hello, ~A!" (first captures)))
207 | ```
208 | 
209 | Normally, routes are tested for a match in the order they are defined, and only the first route matched is invoked, with the following routes being ignored. However, a route can continue testing for matches in the list, by including `next-route`.
210 | 
211 | ```common-lisp
212 | (defroute "/guess/:who" (&key who)
213 |   (if (string= who "Eitaro")
214 |       "You got me!"
215 |       (next-route)))
216 | 
217 | (defroute "/guess/*" ()
218 |   "You missed!")
219 | ```
220 | 
221 | You can return following formats as the result of `defroute`.
222 | 
223 | * String
224 | * Pathname
225 | * Clack's response list (containing Status, Headers and Body)
226 | 
227 | ### Redirection
228 | 
229 | Redirect to another route with`(redirect "url")`. A second optional argument is the status code, 302 by default.
230 | 
231 | ### Reverse URLs
232 | 
233 | When you defined routes with names, you can find the URL from a name with `(url-for route-name &rest params)`.
234 | 
235 | The function will throw an error if no route is found.
236 | 
237 | ### More helper functions
238 | 
239 | See also:
240 | 
241 | - `add-query-parameters base-url params`
242 | 
243 | 
244 | ### Structured query/post parameters
245 | 
246 | Parameter keys containing square brackets ("[" & "]") will be parsed as structured parameters. You can access the parsed parameters as `_parsed` in routers.
247 | 
248 | ```html
249 | <form action="/edit">
250 |   <input type="name" name="person[name]" />
251 |   <input type="name" name="person[email]" />
252 |   <input type="name" name="person[birth][year]" />
253 |   <input type="name" name="person[birth][month]" />
254 |   <input type="name" name="person[birth][day]" />
255 | </form>
256 | ```
257 | 
258 | ```common-lisp
259 | (defroute "/edit" (&key _parsed)
260 |   (format nil "~S" (cdr (assoc "person" _parsed :test #'string=))))
261 | ;=> "((\"name\" . \"Eitaro\") (\"email\" . \"e.arrows@gmail.com\") (\"birth\" . ((\"year\" . 2000) (\"month\" . 1) (\"day\" . 1))))"
262 | 
263 | ;; With assoc-utils
264 | (ql:quickload :assoc-utils)
265 | (import 'assoc-utils:aget)
266 | (defroute "/edit" (&key _parsed)
267 |   (format nil "~S" (aget _parsed "person")))
268 | ```
269 | 
270 | Blank keys mean they have multiple values.
271 | 
272 | ```html
273 | <form action="/add">
274 |   <input type="text" name="items[][name]" />
275 |   <input type="text" name="items[][price]" />
276 | 
277 |   <input type="text" name="items[][name]" />
278 |   <input type="text" name="items[][price]" />
279 | 
280 |   <input type="submit" value="Add" />
281 | </form>
282 | ```
283 | 
284 | ```common-lisp
285 | (defroute "/add" (&key _parsed)
286 |   (format nil "~S" (assoc "items" _parsed :test #'string=)))
287 | ;=> "(((\"name\" . \"WiiU\") (\"price\" . \"30000\")) ((\"name\" . \"PS4\") (\"price\" . \"69000\")))"
288 | ```
289 | 
290 | ### Templates
291 | 
292 | Caveman uses [Djula](http://mmontone.github.io/djula/djula/) as its default templating engine.
293 | 
294 | ```html
295 | {% extends "layouts/default.html" %}
296 | {% block title %}Users | MyApp{% endblock %}
297 | {% block content %}
298 | <div id="main">
299 |   <ul>
300 |   {% for user in users %}
301 |     <li><a href="{{ user.url }}">{{ user.name }}</a></li>
302 |   {% endfor %}
303 |   </ul>
304 | </div>
305 | {% endblock %}
306 | ```
307 | 
308 | ```common-lisp
309 | (import 'myapp.view:render)
310 | 
311 | (render #P"users.html"
312 |         '(:users ((:url "/id/1"
313 |                    :name "nitro_idiot")
314 |                   (:url "/id/2"
315 |                    :name "meymao"))
316 |           :has-next-page T))
317 | ```
318 | 
319 | If you want to get something from a database or execute a function using [Djula](http://mmontone.github.io/djula/) you must explicity call `list` when passing the arguments to render so that the code executes.
320 | 
321 | ```common-lisp
322 | (import 'myapp.view:render)
323 | 
324 | (render #P"users.html"
325 |         (list :users (get-users-from-db)))
326 | ```
327 | 
328 | ### JSON API
329 | 
330 | This is an example of a JSON API.
331 | 
332 | ```common-lisp
333 | (defroute "/user.json" (&key |id|)
334 |   (let ((person (find-person-from-db |id|)))
335 |     ;; person => (:|name| "Eitaro Fukamachi" :|email| "e.arrows@gmail.com")
336 |     (render-json person)))
337 | 
338 | ;=> {"name":"Eitaro Fukamachi","email":"e.arrows@gmail.com"}
339 | ```
340 | 
341 | `render-json` is a part of a skeleton project. You can find its code in "src/view.lisp".
342 | 
343 | ### Static file
344 | 
345 | Images, CSS, JS, favicon.ico and robot.txt in "static/" directory will be served by default.
346 | 
347 | ```
348 | /images/logo.png => {PROJECT_ROOT}/static/images/logo.png
349 | /css/main.css    => {PROJECT_ROOT}/static/css/main.css
350 | /js/app/index.js => {PROJECT_ROOT}/static/js/app/index.js
351 | /robot.txt       => {PROJECT_ROOT}/static/robot.txt
352 | /favicon.ico     => {PROJECT_ROOT}/static/favicon.ico
353 | ```
354 | 
355 | You can change these rules by rewriting "PROJECT_ROOT/app.lisp". See [Clack.Middleware.Static](http://quickdocs.org/clack/api#package-CLACK.MIDDLEWARE.STATIC) for detail.
356 | 
357 | ### Configuration
358 | 
359 | Caveman adopts [Envy](https://github.com/fukamachi/envy) as a configuration switcher. This allows definition of  multiple configurations and switching between them according to an environment variable.
360 | 
361 | This is a typical example:
362 | 
363 | ```common-lisp
364 | (defpackage :myapp.config
365 |   (:use :cl
366 |         :envy))
367 | (in-package :myapp.config)
368 | 
369 | (setf (config-env-var) "APP_ENV")
370 | 
371 | (defconfig :common
372 |   `(:application-root ,(asdf:component-pathname (asdf:find-system :myapp))))
373 | 
374 | (defconfig |development|
375 |   `(:debug T
376 |     :databases
377 |     ((:maindb :sqlite3 :database-name ,(merge-pathnames #P"test.db"
378 |                                                         *application-root*)))))
379 | 
380 | (defconfig |production|
381 |   '(:databases
382 |     ((:maindb :mysql :database-name "myapp" :username "whoami" :password "1234")
383 |      (:workerdb :mysql :database-name "jobs" :username "whoami" :password "1234"))))
384 | 
385 | (defconfig |staging|
386 |   `(:debug T
387 |     ,@|production|))
388 | ```
389 | 
390 | Every configuration is a property list. You can choose the configuration which to use by setting `APP_ENV`.
391 | 
392 | To get a value from the current configuration, call `myapp.config:config` with the key you want.
393 | 
394 | ```common-lisp
395 | (import 'myapp.config:config)
396 | 
397 | (setf (osicat:environment-variable "APP_ENV") "development")
398 | (config :debug)
399 | ;=> T
400 | ```
401 | 
402 | ### Database
403 | 
404 | When you add `:databases` to the configuration, Caveman enables database support. `:databases` is an association list of database settings.
405 | 
406 | ```common-lisp
407 | (defconfig |production|
408 |   '(:databases
409 |     ((:maindb :mysql :database-name "myapp" :username "whoami" :password "1234")
410 |      (:workerdb :mysql :database-name "jobs" :username "whoami" :password "1234"))))
411 | ```
412 | 
413 | `db` in a package `myapp.db` is a function for connecting to each databases configured the above. Here is an example.
414 | 
415 | ```common-lisp
416 | (use-package '(:myapp.db :sxql :datafly))
417 | 
418 | (defun search-adults ()
419 |   (with-connection (db)
420 |     (retrieve-all
421 |       (select :*
422 |         (from :person)
423 |         (where (:>= :age 20))))))
424 | ```
425 | 
426 | The connection is alive during the Lisp session, and will be reused in every HTTP request.
427 | 
428 | `retrieve-all` and the query language came from [datafly](https://github.com/fukamachi/datafly) and [SxQL](https://github.com/fukamachi/sxql). See those sets of documentation for more information.
429 | 
430 | ### Set HTTP headers or HTTP status
431 | 
432 | There are several special variables available during a HTTP request. `*request*` and `*response*` represent a request and a response. If you are familiar with [Clack](http://clacklisp.org/), these are instances of subclasses of [Clack.Request](http://quickdocs.org/clack/api#package-CLACK.REQUEST) and [Clack.Response](http://quickdocs.org/clack/api#package-CLACK.RESPONSE).
433 | 
434 | ```common-lisp
435 | (use-package :caveman2)
436 | 
437 | ;; Get a value of Referer header.
438 | (http-referer *request*)
439 | 
440 | ;; Set Content-Type header.
441 | (setf (getf (response-headers *response*) :content-type) "application/json")
442 | 
443 | ;; Set HTTP status.
444 | (setf (status *response*) 304)
445 | ```
446 | 
447 | If you would like to set Content-Type "application/json" for all "*.json" requests, `next-route` can be used.
448 | 
449 | ```common-lisp
450 | (defroute "/*.json" ()
451 |   (setf (getf (response-headers *response*) :content-type) "application/json")
452 |   (next-route))
453 | 
454 | (defroute "/user.json" () ...)
455 | (defroute "/search.json" () ...)
456 | (defroute ("/new.json" :method :POST) () ...)
457 | ```
458 | 
459 | ### Using session
460 | 
461 | Session data is for memorizing user-specific data. `*session*` is a hash table that stores session data.
462 | 
463 | This example increments `:counter` in the session, and displays it for each visitor.
464 | 
465 | ```common-lisp
466 | (defroute "/counter" ()
467 |   (format nil "You came here ~A times."
468 |           (incf (gethash :counter *session* 0))))
469 | ```
470 | 
471 | Caveman2 stores session data in-memory by default. To change this, specify `:store` to `:session` in "PROJECT_ROOT/app.lisp".
472 | 
473 | This example uses RDBMS to store session data.
474 | 
475 | ```diff
476 |       '(:backtrace
477 |         :output (getf (config) :error-log))
478 |       nil)
479 | - :session
480 | + (:session
481 | +  :store (make-dbi-store :connector (lambda ()
482 | +                                      (apply #'dbi:connect
483 | +                                             (myapp.db:connection-settings)))))
484 |   (if (productionp)
485 |       nil
486 |       (lambda (app)
487 | ```
488 | 
489 | NOTE: Don't forget to add `:lack-session-store-dbi` as `:depends-on` of your app. It is not a part of Clack/Lack.
490 | 
491 | See the source code of Lack.Session.Store.DBi for more information.
492 | 
493 | - [Lack.Session.Store.Dbi](https://github.com/fukamachi/lack/blob/master/src/middleware/session/store/dbi.lisp)
494 | 
495 | ### Throw an HTTP status code
496 | 
497 | ```common-lisp
498 | (import 'caveman2:throw-code)
499 | 
500 | (defroute ("/auth" :method :POST) (&key |name| |password|)
501 |   (unless (authorize |name| |password|)
502 |     (throw-code 403)))
503 | ```
504 | 
505 | ### Specify error pages
506 | 
507 | To specify error pages for 404, 500 or such, define a method `on-exception` of your app.
508 | 
509 | ```common-lisp
510 | (defmethod on-exception ((app <web>) (code (eql 404)))
511 |   (declare (ignore app code))
512 |   (merge-pathnames #P"_errors/404.html"
513 |                    *template-directory*))
514 | ```
515 | 
516 | 
517 | ### Hot Deployment
518 | 
519 | Though Caveman doesn't have a feature for hot deployment, [Server::Starter](http://search.cpan.org/~kazuho/Server-Starter-0.15/lib/Server/Starter.pm) -- a Perl module -- makes it easy.
520 | 
521 |     $ APP_ENV=production start_server --port 8080 -- clackup --server :fcgi app.lisp
522 | 
523 | NOTE: Server::Starter requires the server to support binding on a specific fd, which means only `:fcgi` and `:woo` are the ones work with `start_server` command.
524 | 
525 | To restart the server, send HUP signal (`kill -HUP <pid>`) to the `start_server` process.
526 | 
527 | ### Error Log
528 | 
529 | Caveman outputs error backtraces to a file which is specified at `:error-log` in your configuration.
530 | 
531 | ```common-lisp
532 | (defconfig |default|
533 |   `(:error-log #P"/var/log/apps/myapp_error.log"
534 |     :databases
535 |     ((:maindb :sqlite3 :database-name ,(merge-pathnames #P"myapp.db"
536 |                                                         *application-root*)))))
537 | ```
538 | 
539 | ## Use another templating library
540 | 
541 | ### CL-WHO
542 | 
543 | ```common-lisp
544 | (import 'cl-who:with-html-output-to-string)
545 | 
546 | (defroute "/" ()
547 |   (with-html-output-to-string (output nil :prologue t)
548 |     (:html
549 |       (:head (:title "Welcome to Caveman!"))
550 |       (:body "Blah blah blah."))))
551 | ;=> "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">
552 | ;   <html><head><title>Welcome to Caveman!</title></head><body>Blah blah blah.</body></html>"
553 | ```
554 | 
555 | * [CL-WHO Website](http://weitz.de/cl-who/)
556 | 
557 | ### CL-Markup
558 | 
559 | ```common-lisp
560 | (import 'cl-markup:xhtml)
561 | 
562 | (defroute "/" ()
563 |   (xhtml
564 |     (:head (:title "Welcome to Caveman!"))
565 |     (:body "Blah blah blah.")))
566 | ;=> "<?xml version=\"1.0\" encoding=\"UTF-8\"?><!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\"><html><head><title>Welcome to Caveman!</title></head><body>Blah blah blah.</body></html>"
567 | ```
568 | 
569 | * [CL-Markup repository](https://github.com/arielnetworks/cl-markup)
570 | 
571 | ### cl-closure-template
572 | 
573 | ```html
574 | {namespace myapp.view}
575 | 
576 | {template renderIndex}
577 | <!DOCTYPE html>
578 | <html>
579 | <head>
580 |   <title>"Welcome to Caveman!</title>
581 | </head>
582 | <body>
583 |   Blah blah blah.
584 | </body>
585 | </html>
586 | {/template}
587 | ```
588 | 
589 | ```common-lisp
590 | (import 'myapp.config:*template-directory*)
591 | 
592 | (closure-template:compile-cl-templates (merge-pathnames #P"index.tmpl"
593 |                                                         *template-directory*))
594 | 
595 | (defroute "/" ()
596 |   (myapp.view:render-index))
597 | ```
598 | 
599 | * [cl-closure-template](http://quickdocs.org/cl-closure-template/)
600 | * [Closure Templates Documentation](https://developers.google.com/closure/templates/docs/overview)
601 | 
602 | <!-- Commenting out because these are old.
603 | 
604 | ## Use another database library
605 | 
606 | ### CLSQL
607 | 
608 | You can use Lack.Middleware.Clsql to use CLSQL in Clack compliant application.
609 | 
610 | In Caveman, add the middleware to `builder` in "PROJECT_ROOT/app.lisp".
611 | 
612 | ```common-lisp
613 | (ql:quickload :clack-middleware-clsql)
614 | (import 'clack.middleware.clsql:<clack-middleware-clsql>)
615 | 
616 | (builder
617 |  (<clack-middleware-clsql>
618 |   :database-type :mysql
619 |   :connection-spec '("localhost" "db" "fukamachi" "password"))
620 |  *web*)
621 | ```
622 | 
623 | * [Clack.Middleware.Clsql](http://quickdocs.org/clack/api#system-clack-middleware-clsql)
624 | * [CLSQL: Common Lisp SQL Interface](http://clsql.b9.com/)
625 | 
626 | ### Postmodern
627 | 
628 | You can use Clack.Middleware.Postmodern to use Postmodern in Clack compliant application.
629 | 
630 | In Caveman, add the middleware to `builder` in "PROJECT_ROOT/app.lisp".
631 | 
632 | 
633 | ```common-lisp
634 | (ql:quickload :clack-middleware-postmodern)
635 | (import 'clack.middleware.postmodern:<clack-middleware-postmodern>)
636 | 
637 | (builder
638 |  (<clack-middleware-postmodern>
639 |   :database "database-name"
640 |   :user "database-user"
641 |   :password "database-password"
642 |   :host "remote-address")
643 |  *web*)
644 | ```
645 | 
646 | * [Clack.Middleware.Postmodern](http://quickdocs.org/clack/api#system-clack-middleware-postmodern)
647 | * [Postmodern](http://marijnhaverbeke.nl/postmodern/)
648 | 
649 | -->
650 | 
651 | ## See Also
652 | 
653 | * [Clack](http://clacklisp.org/) - Web application environment.
654 | * [Lack](https://github.com/fukamachi/lack) - The core of Clack.
655 | * [ningle](http://8arrow.org/ningle/) - Super micro web application framework that Caveman is based on.
656 | * [Djula](http://mmontone.github.io/djula/) - HTML Templating engine.
657 | * [CL-DBI](http://8arrow.org/cl-dbi/) - Database-independent interface library.
658 | * [SxQL](http://8arrow.org/sxql/) - SQL builder library.
659 | * [Envy](https://github.com/fukamachi/envy) - Configuration switcher.
660 | * [Roswell](https://github.com/snmsts/roswell) - Common Lisp implementation manager.
661 | 
662 | ## Author
663 | 
664 | * Eitaro Fukamachi (e.arrows@gmail.com)
665 | 
666 | # License
667 | 
668 | Licensed under the LLGPL License.
669 | 


--------------------------------------------------------------------------------
/caveman-middleware-dbimanager.asd:
--------------------------------------------------------------------------------
1 | (defsystem "caveman-middleware-dbimanager"
2 |   :version "0.1"
3 |   :author "Eitaro Fukamachi"
4 |   :license "LLGPL"
5 |   :depends-on ("dbi")
6 |   :components ((:file "v2/src/middleware/dbimanager"))
7 |   :description "Clack Middleware for managing CL-DBI connections")
8 | 


--------------------------------------------------------------------------------
/caveman2-db.asd:
--------------------------------------------------------------------------------
 1 | (defsystem "caveman2-db"
 2 |   :version "0.1"
 3 |   :author "Eitaro Fukamachi"
 4 |   :license "LLGPL"
 5 |   :depends-on ("caveman-middleware-dbimanager"
 6 |                "dbi"
 7 |                "sxql")
 8 |   :components ((:file "v2/src/db"))
 9 |   :description "Simple CL-DBI wrapper")
10 | 


--------------------------------------------------------------------------------
/caveman2-test.asd:
--------------------------------------------------------------------------------
 1 | #|
 2 |   This file is a part of caveman project.
 3 |   Copyright (c) Eitaro Fukamachi (e.arrows@gmail.com)
 4 | |#
 5 | 
 6 | (defsystem "caveman2-test"
 7 |   :defsystem-depends-on ("prove-asdf")
 8 |   :author "Eitaro Fukamachi"
 9 |   :license "LLGPL"
10 |   :depends-on ("caveman2"
11 |                "lack-component"
12 |                "uiop"
13 |                "usocket"
14 |                "dexador"
15 |                "prove"
16 |                "trivial-types")
17 |   :components ((:module "v2/t"
18 |                 :serial t
19 |                 :components
20 |                 ((:test-file "caveman")
21 |                  (:test-file "route")
22 |                  (:test-file "nested-parameter"))))
23 |   :perform (test-op (op c) (symbol-call :prove-asdf :run-test-system c)))
24 | 


--------------------------------------------------------------------------------
/caveman2.asd:
--------------------------------------------------------------------------------
 1 | #|
 2 |   This file is a part of caveman project.
 3 |   Copyright (c) Eitaro Fukamachi (e.arrows@gmail.com)
 4 | |#
 5 | 
 6 | #|
 7 |   Lightweight web application framework
 8 | 
 9 |   Author: Eitaro Fukamachi (e.arrows@gmail.com)
10 | |#
11 | 
12 | (defsystem "caveman2"
13 |   :version "2.4.0"
14 |   :author "Eitaro Fukamachi"
15 |   :license "LLGPL"
16 |   :depends-on ("ningle"
17 |                "lack-request"
18 |                "lack-response"
19 |                "cl-project"
20 |                "dbi"
21 |                "cl-syntax-annot"
22 |                "myway"
23 |                "quri")
24 |   :components ((:module "v2/src"
25 |                 :components
26 |                 ((:file "caveman" :depends-on ("app" "route" "helper" "skeleton"))
27 |                  (:file "app" :depends-on ("exception"))
28 |                  (:file "route" :depends-on ("app" "nested-parameter"))
29 |                  (:file "nested-parameter")
30 |                  (:file "helper" :depends-on ("app"))
31 |                  (:file "exception")
32 |                  (:file "skeleton"))))
33 |   :description "Lightweight web application framework"
34 |   :long-description
35 |   #.(read-file-string
36 |      (subpathname *load-pathname* "README.markdown"))
37 |   :in-order-to ((test-op (test-op "caveman2-test"))))
38 | 


--------------------------------------------------------------------------------
/v2/skeleton/.gitignore:
--------------------------------------------------------------------------------
1 | *.fasl
2 | *.dx32fsl
3 | *.dx64fsl
4 | *.lx32fsl
5 | *.lx64fsl
6 | *.x86f
7 | *~
8 | .#*


--------------------------------------------------------------------------------
/v2/skeleton/README.markdown:
--------------------------------------------------------------------------------
 1 | # <%= (getf env :name) %>
 2 | 
 3 | <% @if description %><% @var description %><% @endif %>
 4 | 
 5 | ## Usage
 6 | 
 7 | ## Installation
 8 | <% @if author %>
 9 | ## Author
10 | 
11 | * <% @var author %><% @if email %> (<% @var email %>)<% @endif %>
12 | 
13 | ## Copyright
14 | 
15 | Copyright (c) <%= (local-time:timestamp-year (local-time:now)) %> <% @var author %><% @if email %> (<% @var email %>)<% @endif %>
16 | <% @endif %><% @if license %>
17 | # License
18 | 
19 | Licensed under the <% @var license %> License.
20 | <% @endif %>
21 | 


--------------------------------------------------------------------------------
/v2/skeleton/app.lisp:
--------------------------------------------------------------------------------
 1 | (ql:quickload :<% @var name %>)
 2 | 
 3 | (defpackage <% @var name %>.app
 4 |   (:use :cl)
 5 |   (:import-from :lack.builder
 6 |                 :builder)
 7 |   (:import-from :ppcre
 8 |                 :scan
 9 |                 :regex-replace)
10 |   (:import-from :<% @var name %>.web
11 |                 :*web*)
12 |   (:import-from :<% @var name %>.config
13 |                 :config
14 |                 :productionp
15 |                 :*static-directory*))
16 | (in-package :<% @var name %>.app)
17 | 
18 | (builder
19 |  (:static
20 |   :path (lambda (path)
21 |           (if (ppcre:scan "^(?:/images/|/css/|/js/|/robot\\.txt$|/favicon\\.ico$)" path)
22 |               path
23 |               nil))
24 |   :root *static-directory*)
25 |  (if (productionp)
26 |      nil
27 |      :accesslog)
28 |  (if (getf (config) :error-log)
29 |      `(:backtrace
30 |        :output ,(getf (config) :error-log))
31 |      nil)
32 |  :session
33 |  (if (productionp)
34 |      nil
35 |      (lambda (app)
36 |        (lambda (env)
37 |          (let ((datafly:*trace-sql* t))
38 |            (funcall app env)))))
39 |  *web*)
40 | 


--------------------------------------------------------------------------------
/v2/skeleton/db/schema.sql:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/fukamachi/caveman/a644adbc188cb6b929825098cea9092813156bfe/v2/skeleton/db/schema.sql


--------------------------------------------------------------------------------
/v2/skeleton/skeleton-test.asd:
--------------------------------------------------------------------------------
 1 | (defsystem "<% @var name %>-test"
 2 |   :defsystem-depends-on ("prove-asdf")
 3 |   :author "<% @var author %>"
 4 |   :license "<% @var license %>"
 5 |   :depends-on ("<% @var name %>"
 6 |                "prove")
 7 |   :components ((:module "tests"
 8 |                 :components
 9 |                 ((:test-file "<% @var name %>"))))
10 |   :description "Test system for <% @var name %>"
11 |   :perform (test-op (op c) (symbol-call :prove-asdf :run-test-system c)))
12 | 


--------------------------------------------------------------------------------
/v2/skeleton/skeleton.asd:
--------------------------------------------------------------------------------
 1 | (defsystem "<% @var name %>"
 2 |   :version "0.1.0"
 3 |   :author "<% @var author %>"
 4 |   :license "<% @var license %>"
 5 |   :depends-on ("clack"
 6 |                "lack"
 7 |                "caveman2"
 8 |                "envy"
 9 |                "cl-ppcre"
10 |                "uiop"
11 | 
12 |                ;; for @route annotation
13 |                "cl-syntax-annot"
14 | 
15 |                ;; HTML Template
16 |                "djula"
17 | 
18 |                ;; for DB
19 |                "datafly"
20 |                "sxql")
21 |   :components ((:module "src"
22 |                 :components
23 |                 ((:file "main" :depends-on ("config" "view" "db"))
24 |                  (:file "web" :depends-on ("view"))
25 |                  (:file "view" :depends-on ("config"))
26 |                  (:file "db" :depends-on ("config"))
27 |                  (:file "config"))))
28 |   :description "<% @var description %>"
29 |   :in-order-to ((test-op (test-op "<% @var name %>-test"))))
30 | 


--------------------------------------------------------------------------------
/v2/skeleton/src/config.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :cl-user)
 2 | (defpackage <% @var name %>.config
 3 |   (:use :cl)
 4 |   (:import-from :envy
 5 |                 :config-env-var
 6 |                 :defconfig)
 7 |   (:export :config
 8 |            :*application-root*
 9 |            :*static-directory*
10 |            :*template-directory*
11 |            :appenv
12 |            :developmentp
13 |            :productionp))
14 | (in-package :<% @var name %>.config)
15 | 
16 | (setf (config-env-var) "APP_ENV")
17 | 
18 | (defparameter *application-root*   (asdf:system-source-directory :<% @var name %>))
19 | (defparameter *static-directory*   (merge-pathnames #P"static/" *application-root*))
20 | (defparameter *template-directory* (merge-pathnames #P"templates/" *application-root*))
21 | 
22 | (defconfig :common
23 |   `(:databases ((:maindb :sqlite3 :database-name ":memory:"))))
24 | 
25 | (defconfig |development|
26 |   '())
27 | 
28 | (defconfig |production|
29 |   '())
30 | 
31 | (defconfig |test|
32 |   '())
33 | 
34 | (defun config (&optional key)
35 |   (envy:config #.(package-name *package*) key))
36 | 
37 | (defun appenv ()
38 |   (uiop:getenv (config-env-var #.(package-name *package*))))
39 | 
40 | (defun developmentp ()
41 |   (string= (appenv) "development"))
42 | 
43 | (defun productionp ()
44 |   (string= (appenv) "production"))
45 | 


--------------------------------------------------------------------------------
/v2/skeleton/src/db.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :cl-user)
 2 | (defpackage <% @var name %>.db
 3 |   (:use :cl)
 4 |   (:import-from :<% @var name %>.config
 5 |                 :config)
 6 |   (:import-from :datafly
 7 |                 :*connection*)
 8 |   (:import-from :cl-dbi
 9 |                 :connect-cached)
10 |   (:export :connection-settings
11 |            :db
12 |            :with-connection))
13 | (in-package :<% @var name %>.db)
14 | 
15 | (defun connection-settings (&optional (db :maindb))
16 |   (cdr (assoc db (config :databases))))
17 | 
18 | (defun db (&optional (db :maindb))
19 |   (apply #'connect-cached (connection-settings db)))
20 | 
21 | (defmacro with-connection (conn &body body)
22 |   `(let ((*connection* ,conn))
23 |      ,@body))
24 | 


--------------------------------------------------------------------------------
/v2/skeleton/src/main.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :cl-user)
 2 | (defpackage <% @var name %>
 3 |   (:use :cl)
 4 |   (:import-from :<% @var name %>.config
 5 |                 :config)
 6 |   (:import-from :clack
 7 |                 :clackup)
 8 |   (:export :start
 9 |            :stop))
10 | (in-package :<% @var name %>)
11 | 
12 | (defvar *appfile-path*
13 |   (asdf:system-relative-pathname :<% @var name %> #P"app.lisp"))
14 | 
15 | (defvar *handler* nil)
16 | 
17 | (defun start (&rest args &key server port debug &allow-other-keys)
18 |   (declare (ignore server port debug))
19 |   (when *handler*
20 |     (restart-case (error "Server is already running.")
21 |       (restart-server ()
22 |         :report "Restart the server"
23 |         (stop))))
24 |   (setf *handler*
25 |         (apply #'clackup *appfile-path* args)))
26 | 
27 | (defun stop ()
28 |   (prog1
29 |       (clack:stop *handler*)
30 |     (setf *handler* nil)))
31 | 


--------------------------------------------------------------------------------
/v2/skeleton/src/view.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :cl-user)
 2 | (defpackage <% @var name %>.view
 3 |   (:use :cl)
 4 |   (:import-from :<% @var name %>.config
 5 |                 :*template-directory*)
 6 |   (:import-from :caveman2
 7 |                 :*response*
 8 |                 :response-headers)
 9 |   (:import-from :djula
10 |                 :add-template-directory
11 |                 :compile-template*
12 |                 :render-template*
13 |                 :*template-package*)
14 |   (:import-from :datafly
15 |                 :encode-json)
16 |   (:export :render
17 |            :render-json))
18 | (in-package :<% @var name %>.view)
19 | 
20 | (djula:add-template-directory *template-directory*)
21 | 
22 | (defparameter *template-registry* (make-hash-table :test 'equal))
23 | 
24 | (defun render (template-path &optional env)
25 |   (let ((template (gethash template-path *template-registry*)))
26 |     (unless template
27 |       (setf template (djula:compile-template* (princ-to-string template-path)))
28 |       (setf (gethash template-path *template-registry*) template))
29 |     (apply #'djula:render-template*
30 |            template nil
31 |            env)))
32 | 
33 | (defun render-json (object)
34 |   (setf (getf (response-headers *response*) :content-type) "application/json")
35 |   (encode-json object))
36 | 
37 | 
38 | ;;
39 | ;; Execute package definition
40 | 
41 | (defpackage <% @var name %>.djula
42 |   (:use :cl)
43 |   (:import-from :<% @var name %>.config
44 |                 :config
45 |                 :appenv
46 |                 :developmentp
47 |                 :productionp)
48 |   (:import-from :caveman2
49 |                 :url-for))
50 | 
51 | (setf djula:*template-package* (find-package :<% @var name %>.djula))
52 | 


--------------------------------------------------------------------------------
/v2/skeleton/src/web.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :cl-user)
 2 | (defpackage <% @var name %>.web
 3 |   (:use :cl
 4 |         :caveman2
 5 |         :<% @var name %>.config
 6 |         :<% @var name %>.view
 7 |         :<% @var name %>.db
 8 |         :datafly
 9 |         :sxql)
10 |   (:export :*web*))
11 | (in-package :<% @var name %>.web)
12 | 
13 | ;; for @route annotation
14 | (syntax:use-syntax :annot)
15 | 
16 | ;;
17 | ;; Application
18 | 
19 | (defclass <web> (<app>) ())
20 | (defvar *web* (make-instance '<web>))
21 | (clear-routing-rules *web*)
22 | 
23 | ;;
24 | ;; Routing rules
25 | 
26 | (defroute "/" ()
27 |   (render #P"index.html"))
28 | 
29 | ;;
30 | ;; Error pages
31 | 
32 | (defmethod on-exception ((app <web>) (code (eql 404)))
33 |   (declare (ignore app))
34 |   (merge-pathnames #P"_errors/404.html"
35 |                    *template-directory*))
36 | 


--------------------------------------------------------------------------------
/v2/skeleton/static/css/main.css:
--------------------------------------------------------------------------------
 1 | @charset "UTF-8";
 2 | 
 3 | body {
 4 |   font-family: 'Myriad Pro', Calibri, Helvetica, Arial, sans-serif;
 5 | }
 6 | 
 7 | a:link {
 8 |   color: #005585;
 9 |   text-decoration: none;
10 | }
11 | a:visited {
12 |   color: #485270;
13 | }
14 | a:hover {
15 |   color: #b83800;
16 |   text-decoration: underline;
17 | }
18 | 
19 | #main {
20 |   text-align: center;
21 | }
22 | 


--------------------------------------------------------------------------------
/v2/skeleton/templates/_errors/404.html:
--------------------------------------------------------------------------------
 1 | <!DOCTYPE html>
 2 | <html>
 3 | <head>
 4 |   <meta charset="utf-8">
 5 |   <title>404 NOT FOUND</title>
 6 |   <style type="text/css">
 7 | html {
 8 |   height: 100%;
 9 | }
10 | 
11 | body {
12 |   height: 100%;
13 |   font-family: 'Myriad Pro', Calibri, Helvetica, Arial, sans-serif;
14 |   background-color: #DFDFDF;
15 | }
16 | 
17 | #main {
18 |   display: table;
19 |   width: 100%;
20 |   height: 100%;
21 | }
22 | 
23 | .error {
24 |   display: table-cell;
25 |   text-align: center;
26 |   vertical-align: middle;
27 | }
28 | 
29 | .error .code {
30 |   font-size: 1600%;
31 |   font-weight: bold;
32 | }
33 | 
34 | .error .message {
35 |   font-size: 400%;
36 | }
37 |   </style>
38 | </head>
39 | <body>
40 |   <div id="main">
41 |     <div class="error">
42 |       <div class="code">404</div>
43 |       <div class="message">NOT FOUND</div>
44 |     </div>
45 |   </div>
46 | </body>
47 | </html>
48 | 


--------------------------------------------------------------------------------
/v2/skeleton/templates/index.html:
--------------------------------------------------------------------------------
1 | {% extends "layouts/default.html" %}
2 | {% block title %}Welcome to Caveman2{% endblock %}
3 | {% block content %}
4 | <div id="main">
5 |   Welcome to <a href="http://8arrow.org/caveman/">Caveman2</a>!
6 | </div>
7 | {% endblock %}
8 | 


--------------------------------------------------------------------------------
/v2/skeleton/templates/layouts/default.html:
--------------------------------------------------------------------------------
 1 | <!DOCTYPE html>
 2 | <html>
 3 | <head>
 4 |   <meta charset="utf-8">
 5 |   <title>{% block title %}{% endblock %}</title>
 6 |   <link rel="stylesheet" type="text/css" media="screen" href="/css/main.css">
 7 | </head>
 8 | <body>
 9 |   {% block content %}{% endblock %}
10 | </body>
11 | </html>
12 | 


--------------------------------------------------------------------------------
/v2/skeleton/tests/skeleton.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :cl-user)
 2 | (defpackage <% @var name %>-test
 3 |   (:use :cl
 4 |         :<% @var name %>
 5 |         :prove))
 6 | (in-package :<% @var name %>-test)
 7 | 
 8 | (plan nil)
 9 | 
10 | ;; blah blah blah.
11 | 
12 | (finalize)
13 | 


--------------------------------------------------------------------------------
/v2/src/app.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :cl-user)
 2 | (defpackage caveman2.app
 3 |   (:use :cl)
 4 |   (:import-from :caveman2.exception
 5 |                 :http-exception
 6 |                 :caveman-exception
 7 |                 :exception-code
 8 |                 :throw-code
 9 |                 :caveman-redirection
10 |                 :redirection-to
11 |                 :redirection-code)
12 |   (:import-from :lack.component
13 |                 :call)
14 |   (:import-from :lack.response
15 |                 :response-status
16 |                 :response-headers)
17 |   (:import-from :ningle
18 |                 :next-route
19 |                 :clear-routing-rules
20 |                 :*context*
21 |                 :*request*
22 |                 :*response*
23 |                 :*session*
24 |                 :context
25 |                 :make-request
26 |                 :make-response)
27 |   (:import-from :ningle.app
28 |                 :not-found)
29 |   (:export :<app>
30 |            :next-route
31 |            :clear-routing-rules
32 |            :*current-app*
33 |            :*context*
34 |            :*request*
35 |            :*response*
36 |            :*session*
37 |            :context
38 |            :make-request
39 |            :make-response
40 |            :on-exception
41 |            :find-package-app))
42 | (in-package :caveman2.app)
43 | 
44 | (defparameter *current-app* nil)
45 | 
46 | (defclass <app> (ningle:<app>) ())
47 | 
48 | (defvar *package-app-map* (make-hash-table :test 'eq))
49 | 
50 | (defmethod initialize-instance :after ((app <app>) &key)
51 |   (setf (gethash *package* *package-app-map*) app))
52 | 
53 | (defun find-package-app (package)
54 |   (gethash package *package-app-map*))
55 | 
56 | (defmethod call ((this <app>) env)
57 |   (declare (ignore env))
58 |   (let ((*current-app* this))
59 |     (handler-case (call-next-method)
60 |       (http-exception (c)
61 |         (let ((code (exception-code c)))
62 |           (setf (response-status *response*) code)
63 |           (or (on-exception this c)
64 |               (princ-to-string c))))
65 |       (caveman-exception (c)
66 |         (let ((code (exception-code c)))
67 |           (setf (response-status *response*) code)
68 |           (or (on-exception this code)
69 |               (princ-to-string c))))
70 |       (caveman-redirection (c)
71 |         (let ((to (redirection-to c))
72 |               (code (redirection-code c)))
73 |           (setf (getf (response-headers *response*) :location) to)
74 |           (setf (response-status *response*) code)
75 |           to)))))
76 | 
77 | (defmethod not-found ((this <app>))
78 |   (throw-code 404))
79 | 
80 | (defmethod make-response ((app <app>) &optional status headers body)
81 |   (declare (ignore status headers body))
82 |   (let ((res (call-next-method)))
83 |     (unless (getf (response-headers res) :content-type)
84 |       (setf (getf (response-headers res) :content-type) "text/html"))
85 |     (unless (getf (response-headers res) :X-Content-Type-Options)
86 |       (setf (getf (response-headers res) :X-Content-Type-Options) "nosniff"))
87 |     (unless (getf (response-headers res) :X-Frame-Options)
88 |       (setf (getf (response-headers res) :X-Frame-Options) "DENY"))
89 |     (unless (getf (response-headers res) :Cache-Control)
90 |       (setf (getf (response-headers res) :Cache-Control) "private"))
91 |     res))
92 | 
93 | (defgeneric on-exception (app code)
94 |   (:method ((app <app>) code)
95 |     nil)
96 |   (:method ((app <app>) (c http-exception))
97 |     ;; for backward-compatibility
98 |     (on-exception app (exception-code c))))
99 | 


--------------------------------------------------------------------------------
/v2/src/caveman.lisp:
--------------------------------------------------------------------------------
  1 | (in-package :cl-user)
  2 | (defpackage caveman2
  3 |   (:use :cl)
  4 |   (:import-from :caveman2.route
  5 |                 :defroute
  6 |                 :route)
  7 |   (:import-from :caveman2.skeleton
  8 |                 :make-project)
  9 |   (:import-from :caveman2.app
 10 |                 :<app>
 11 |                 :next-route
 12 |                 :clear-routing-rules
 13 |                 :*context*
 14 |                 :*request*
 15 |                 :*response*
 16 |                 :*session*
 17 |                 :context
 18 |                 :make-request
 19 |                 :make-response
 20 |                 :on-exception)
 21 |   (:import-from :caveman2.helper
 22 |                 :url-for)
 23 |   (:import-from :caveman2.exception
 24 |                 :*exception-class*
 25 |                 :http-exception
 26 |                 :exception-code
 27 |                 :throw-code
 28 |                 :redirect)
 29 |   (:import-from :lack.request
 30 |                 :request-env
 31 |                 :request-method
 32 |                 :request-script-name
 33 |                 :request-path-info
 34 |                 :request-server-name
 35 |                 :request-server-port
 36 |                 :request-server-protocol
 37 |                 :request-uri
 38 |                 :request-remote-addr
 39 |                 :request-remote-port
 40 |                 :request-query-string
 41 |                 :request-raw-body
 42 |                 :request-content-length
 43 |                 :request-content-type
 44 |                 :request-headers
 45 |                 :request-cookies
 46 |                 :request-body-parameters
 47 |                 :request-query-parameters
 48 |                 :request-parameters)
 49 |   (:import-from :lack.response
 50 |                 :response-status
 51 |                 :response-headers
 52 |                 :response-body
 53 |                 :response-set-cookies)
 54 |   (:export :defroute
 55 |            :route
 56 |            :<app>
 57 |            :next-route
 58 |            :clear-routing-rules
 59 |            :redirect
 60 |            :url-for
 61 |            :*context*
 62 |            :*request*
 63 |            :*response*
 64 |            :*session*
 65 |            :context
 66 |            :make-request
 67 |            :make-response
 68 |            :make-project
 69 |            :*exception-class*
 70 |            :http-exception
 71 |            :exception-code
 72 |            :on-exception
 73 |            :throw-code
 74 | 
 75 |            ;; from Lack.Request
 76 |            :request-env
 77 |            :request-method
 78 |            :request-script-name
 79 |            :request-path-info
 80 |            :request-server-name
 81 |            :request-server-port
 82 |            :request-server-protocol
 83 |            :request-uri
 84 |            :request-remote-addr
 85 |            :request-remote-port
 86 |            :request-query-string
 87 |            :request-raw-body
 88 |            :request-content-length
 89 |            :request-content-type
 90 |            :request-headers
 91 |            :request-cookies
 92 |            :request-body-parameters
 93 |            :request-query-parameters
 94 |            :request-parameters
 95 | 
 96 |            ;; from Clack.Response
 97 |            :response-status
 98 |            :response-headers
 99 |            :response-body
100 |            :response-set-cookies))
101 | (in-package :caveman2)
102 | 


--------------------------------------------------------------------------------
/v2/src/db.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :cl-user)
 2 | (defpackage caveman2.db
 3 |   (:use :cl)
 4 |   (:import-from :caveman.middleware.dbimanager
 5 |                 :connect-db)
 6 |   (:import-from :dbi
 7 |                 :prepare
 8 |                 :execute
 9 |                 :fetch-all
10 |                 :fetch)
11 |   (:import-from :sxql
12 |                 :from
13 |                 :where
14 |                 :order-by
15 |                 :group-by
16 |                 :limit
17 |                 :offset
18 |                 :set=
19 |                 :left-join
20 |                 :union-queries
21 |                 :union-all-queries
22 |                 :yield
23 |                 :*quote-character*)
24 |   (:export :connect-db
25 |            :select-all
26 |            :select-one
27 |            :insert-into
28 |            :update
29 |            :delete-from
30 |            :from
31 |            :where
32 |            :order-by
33 |            :group-by
34 |            :limit
35 |            :offset
36 |            :set=
37 |            :left-join
38 |            :union-queries
39 |            :union-all-queries))
40 | (in-package :caveman2.db)
41 | 
42 | (defmacro aprogn (&rest expressions)
43 |   `(let* (,@(mapcar
44 |               (lambda (expression) `(it ,expression))
45 |               expressions))
46 |      it))
47 | 
48 | (defun connection-quote-character (conn)
49 |   (let ((package (package-name (symbol-package (type-of conn)))))
50 |     (cond
51 |       ((string= package #.(string :dbd.mysql)) #\`)
52 |       ((string= package #.(string :dbd.postgres)) #\")
53 |       ((string= package #.(string :dbd.sqlite3)) #\"))))
54 | 
55 | (defmacro execute-sxql (db fn field &body clauses)
56 |   (let ((sql (gensym "SQL"))
57 |         (bind (gensym "BIND")))
58 |     `(let ((*quote-character* (or *quote-character*
59 |                                   (connection-quote-character ,db))))
60 |        (multiple-value-bind (,sql ,bind)
61 |            (yield (,fn ,field ,@clauses))
62 |          (aprogn
63 |            (dbi:prepare ,db ,sql)
64 |            (apply #'dbi:execute it ,bind))))))
65 | 
66 | (defmacro do-sxql (db fn field &body clauses)
67 |   (let ((sql (gensym "SQL"))
68 |         (bind (gensym "BIND")))
69 |     `(let ((*quote-character* (or *quote-character*
70 |                                   (connection-quote-character ,db))))
71 |        (multiple-value-bind (,sql ,bind)
72 |            (yield (,fn ,field ,@clauses))
73 |          (apply #'dbi:do-sql ,db ,sql ,bind)))))
74 | 
75 | (defmacro select-all (db field &body clauses)
76 |   `(dbi:fetch-all (execute-sxql ,db sxql:select ,field ,@clauses)))
77 | 
78 | (defmacro select-one (db field &body clauses)
79 |   `(dbi:fetch (execute-sxql ,db sxql:select ,field ,@clauses)))
80 | 
81 | (defmacro insert-into (db table &body clauses)
82 |   `(do-sxql ,db sxql:insert-into ,table ,@clauses))
83 | 
84 | (defmacro update (db table &body clauses)
85 |   `(do-sxql ,db sxql:update ,table ,@clauses))
86 | 
87 | (defmacro delete-from (db table &body clauses)
88 |   `(do-sxql ,db sxql:delete-from ,table ,@clauses))
89 | 


--------------------------------------------------------------------------------
/v2/src/exception.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :cl-user)
 2 | (defpackage caveman2.exception
 3 |   (:use :cl)
 4 |   (:export :*exception-class*
 5 |            :caveman-exception
 6 |            :http-exception
 7 |            :throw-code
 8 |            :exception-code
 9 |            :caveman-redirection
10 |            :redirection-to
11 |            :redirection-code
12 |            :redirect))
13 | (in-package :caveman2.exception)
14 | 
15 | (defparameter *http-status*
16 |   (loop with status = (make-hash-table :test #'eql)
17 |         for (code . reason) in '((100 . "Continue")
18 |                                  (101 . "Switching Protocols")
19 |                                  (200 . "OK")
20 |                                  (201 . "Created")
21 |                                  (202 . "Accepted")
22 |                                  (203 . "Non-Authoritative Information")
23 |                                  (204 . "No Content")
24 |                                  (205 . "Reset Content")
25 |                                  (206 . "Partial Content")
26 |                                  (207 . "Multi-Status")
27 |                                  (300 . "Multiple Choices")
28 |                                  (301 . "Moved Permanently")
29 |                                  (302 . "Moved Temporarily")
30 |                                  (303 . "See Other")
31 |                                  (304 . "Not Modified")
32 |                                  (305 . "Use Proxy")
33 |                                  (307 . "Temporary Redirect")
34 |                                  (400 . "Bad Request")
35 |                                  (401 . "Authorization Required")
36 |                                  (402 . "Payment Required")
37 |                                  (403 . "Forbidden")
38 |                                  (404 . "Not Found")
39 |                                  (405 . "Method Not Allowed")
40 |                                  (406 . "Not Acceptable")
41 |                                  (407 . "Proxy Authentication Required")
42 |                                  (408 . "Request Time-out")
43 |                                  (409 . "Conflict")
44 |                                  (410 . "Gone")
45 |                                  (411 . "Length Required")
46 |                                  (412 . "Precondition Failed")
47 |                                  (413 . "Request Entity Too Large")
48 |                                  (414 . "Request-URI Too Large")
49 |                                  (415 . "Unsupported Media Type")
50 |                                  (416 . "Requested range not satisfiable")
51 |                                  (417 . "Expectation Failed")
52 |                                  (424 . "Failed Dependency")
53 |                                  (500 . "Internal Server Error")
54 |                                  (501 . "Not Implemented")
55 |                                  (502 . "Bad Gateway")
56 |                                  (503 . "Service Unavailable")
57 |                                  (504 . "Gateway Time-out")
58 |                                  (505 . "Version not supported"))
59 |         do (setf (gethash code status) reason)
60 |         finally (return status)))
61 | 
62 | (defun http-status-reason (code)
63 |   (gethash code *http-status*))
64 | 
65 | (defvar *exception-class* 'http-exception)
66 | 
67 | (define-condition caveman-exception (error)
68 |   ((code :initarg :code :type integer :initform 500
69 |          :reader exception-code))
70 |   (:documentation "Simple HTTP exception class")
71 |   (:report
72 |    (lambda (condition stream)
73 |      (let ((code (exception-code condition)))
74 |        (format stream
75 |                "~D~:[~;~:* ~A~]"
76 |                code
77 |                (http-status-reason code))))))
78 | 
79 | (define-condition http-exception (caveman-exception)
80 |   ()
81 |   (:documentation "Customizable HTTP exception class"))
82 | 
83 | (defun throw-code (code &rest args)
84 |   (apply #'error *exception-class* :code code args))
85 | 
86 | (define-condition caveman-redirection (error)
87 |   ((to :initarg :to :type string
88 |        :reader redirection-to)
89 |    (code :initarg :code :type integer :initform 302
90 |          :reader redirection-code)))
91 | 
92 | (defun redirect (url &optional (code 302))
93 |   (error 'caveman-redirection :to url :code code))
94 | 


--------------------------------------------------------------------------------
/v2/src/helper.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :cl-user)
 2 | (defpackage caveman2.helper
 3 |   (:use :cl)
 4 |   (:import-from :caveman2.app
 5 |                 :*current-app*
 6 |                 :*response*)
 7 |   (:import-from :lack.response
 8 |                 :response-headers
 9 |                 :response-status)
10 |   (:import-from :ningle.app
11 |                 :mapper)
12 |   (:import-from :myway
13 |                 :mapper-routes
14 |                 :route-name
15 |                 #+nil :url-for)
16 |   (:import-from :quri
17 |                 :url-encode)
18 |   (:export :url-for))
19 | (in-package :caveman2.helper)
20 | 
21 | (defun redirect (url &optional (status 302))
22 |   (setf (getf (response-headers *response*) :location) url)
23 |   (setf (response-status *response*) status)
24 |   url)
25 | 
26 | (defun add-query-parameters (base-url params)
27 |   "Add a query parameters string of PARAMS to BASE-URL."
28 |   (unless params
29 |     (return-from add-query-parameters base-url))
30 |   (loop for (name value) on params by #'cddr
31 |         collect (format nil "~A=~A"
32 |                         (url-encode (princ-to-string name))
33 |                         (url-encode (princ-to-string value)))
34 |         into parts
35 |         finally
36 |      (return
37 |        (let ((params-string (format nil "~{~A~^&~}" parts)))
38 |          (format nil "~A~A~A"
39 |                  base-url
40 |                  (if (find #\? base-url) "&" "?")
41 |                  params-string)))))
42 | 
43 | (defun url-for (route-name &rest params)
44 |   (let ((route (find-if #'(lambda (route)
45 |                             (string-equal (route-name route) route-name))
46 |                         (mapper-routes (mapper *current-app*)))))
47 |     (if route
48 |         (multiple-value-bind (base-url rest-params)
49 |             (myway:url-for route params)
50 |           (add-query-parameters base-url rest-params))
51 |         (error "No route found for ~S" route-name))))
52 | 


--------------------------------------------------------------------------------
/v2/src/middleware/dbimanager.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :cl-user)
 2 | (defpackage caveman.middleware.dbimanager
 3 |   (:use :cl)
 4 |   (:import-from :dbi
 5 |                 :connect
 6 |                 :disconnect
 7 |                 :ping)
 8 |   (:export :*lack-middleware-dbimanager*
 9 |            :connect-db))
10 | (in-package :caveman.middleware.dbimanager)
11 | 
12 | (defvar *dbi-manager*)
13 | (setf (documentation '*dbi-manager* 'variable)
14 |       "An instance of `dbi-manager' for the current HTTP request.
15 | This variable is only bound during the HTTP request.")
16 | 
17 | (defclass dbi-manager ()
18 |   ((database-settings :type list
19 |                       :initarg :database-settings)
20 |    (connections :initform (make-hash-table :test 'eql)))
21 |   (:documentation "Class for managing CL-DBI connections."))
22 | 
23 | (defparameter *lack-middleware-dbimanager*
24 |   (lambda (app &key database-settings)
25 |     (let ((dbi-manager (make-instance 'dbi-manager
26 |                                       :database-settings database-settings)))
27 |       (lambda (env)
28 |         (let ((*dbi-manager* dbi-manager))
29 |           (funcall app env))))))
30 | 
31 | (defmethod get-connection ((manager dbi-manager) &optional database-name)
32 |   "Return a connected DBI connection for a database for `database-name'.
33 | If `database-name' is NIL, the first one in database settings will be adopted."
34 |   (unless database-name
35 |     (setf database-name (car (default-database-setting manager))))
36 | 
37 |   (unless database-name
38 |     (error "No database settings in the dbi-manager."))
39 | 
40 |   (symbol-macrolet ((conn (gethash database-name (slot-value manager 'connections))))
41 |     (cond
42 |       ((not conn)
43 |        (setf conn
44 |              (apply #'dbi:connect
45 |                     (cdr (database-setting manager database-name))))
46 |        conn)
47 |       ((not (dbi:ping conn))
48 |        (dbi:disconnect conn)
49 |        (setf conn nil)
50 |        (get-connection manager database-name))
51 |       (T conn))))
52 | 
53 | (defun connect-db (&optional database-name)
54 |   "Return a connected DBI connection for database for `database-name'.
55 | This is meant to be used in an actual application."
56 |   (get-connection *dbi-manager* database-name))
57 | 
58 | (defmethod default-database-setting ((manager dbi-manager))
59 |   (first (slot-value manager 'database-settings)))
60 | 
61 | (defmethod database-setting ((manager dbi-manager) database-name)
62 |   (assoc database-name (slot-value manager 'database-settings)))
63 | 


--------------------------------------------------------------------------------
/v2/src/nested-parameter.lisp:
--------------------------------------------------------------------------------
  1 | (in-package :cl-user)
  2 | (defpackage caveman2.nested-parameter
  3 |   (:use :cl)
  4 |   (:export :parse-parameters))
  5 | (in-package :caveman2.nested-parameter)
  6 | 
  7 | (defun parse-parameters (params-alist)
  8 |   (let ((params (make-hash-table :test 'equal)))
  9 |     (labels ((process (key val)
 10 |                (declare (optimize speed))
 11 |                (let ((keys (if (and (stringp key)
 12 |                                     (char= (aref key (1- (length key))) #\]))
 13 |                                (parse-key key)
 14 |                                (list key))))
 15 |                  (if (cdr keys)
 16 |                      (build-val keys val params)
 17 |                      (setf (gethash (car keys) params) val)))))
 18 |       (loop for (key . val) in params-alist
 19 |             do (process key val)))
 20 |     (expand-to-alist params)))
 21 | 
 22 | (defun build-val (nested-keys val current)
 23 |   (etypecase current
 24 |     (hash-table (%build-val-for-hash nested-keys val current))
 25 |     (array (%build-val-for-array nested-keys val current))))
 26 | 
 27 | (declaim (inline %build-val-for-hash))
 28 | (defun %build-val-for-hash (nested-keys val current)
 29 |   (let ((key (pop nested-keys)))
 30 |     (cond
 31 |       ((null nested-keys)
 32 |        (setf (gethash key current) val))
 33 |       (T (unless (nth-value 1 (gethash key current))
 34 |            (setf (gethash key current)
 35 |                  (if (string= (car nested-keys) "")
 36 |                      (make-array 0 :adjustable t :fill-pointer t)
 37 |                      (make-hash-table :test 'equal))))
 38 |          (build-val nested-keys val
 39 |                     (gethash key current))))))
 40 | 
 41 | (declaim (inline %build-val-for-array))
 42 | (defun %build-val-for-array (nested-keys val current)
 43 |   (pop nested-keys)
 44 |   (cond
 45 |     ((null nested-keys)
 46 |      (vector-push-extend val current))
 47 |     (T
 48 |      (if (string= (car nested-keys) "")
 49 |          (let ((next (make-array 0 :adjustable t :fill-pointer t)))
 50 |            (vector-push-extend next current)
 51 |            (build-val nested-keys val next))
 52 |          (progn
 53 |            (when (= (length current) 0)
 54 |              (vector-push-extend (make-hash-table :test 'equal)
 55 |                                  current))
 56 |            (let ((next (aref current (1- (length current)))))
 57 |              (when (nth-value 1 (gethash (car nested-keys) next))
 58 |                (setf next (make-hash-table :test 'equal))
 59 |                (vector-push-extend next current))
 60 |              (build-val nested-keys val next)))))))
 61 | 
 62 | (defun parse-key (key)
 63 |   (loop with pos = 0
 64 |         for (nested-key new-pos) = (multiple-value-list (peek-key key pos))
 65 |         while nested-key
 66 |         do (setf pos new-pos)
 67 |         collect nested-key))
 68 | 
 69 | (declaim (inline peek-key))
 70 | (declaim (ftype (function (string integer) t) peek-key))
 71 | (defun peek-key (string start)
 72 |   (declare (optimize speed))
 73 |   (if (= start (length string))
 74 |       nil
 75 |       (let ((begin (position #\[ string :start start)))
 76 |         (if begin
 77 |             (if (= begin start)
 78 |                 (let ((end (position #\] string :start (1+ begin))))
 79 |                   (if end
 80 |                       (values (subseq string (1+ begin) end)
 81 |                               (1+ end))
 82 |                       nil))
 83 |                 (let ((end (position #\] string :start (1+ begin))))
 84 |                   (if end
 85 |                       (values (subseq string start begin)
 86 |                               begin)
 87 |                       (values string
 88 |                               (length string)))))
 89 |             (values (subseq string start)
 90 |                     (length string))))))
 91 | 
 92 | (defun expand-to-alist (obj)
 93 |   (typecase obj
 94 |     (hash-table (loop for k being the hash-keys in obj using (hash-value v)
 95 |                       collect (cons k (expand-to-alist v))))
 96 |     ((and array
 97 |           (not string))
 98 |      (loop for a across obj
 99 |            collect (expand-to-alist a)))
100 |     (T obj)))
101 | 


--------------------------------------------------------------------------------
/v2/src/route.lisp:
--------------------------------------------------------------------------------
  1 | (in-package :cl-user)
  2 | (defpackage caveman2.route
  3 |   (:use :cl
  4 |         :cl-annot)
  5 |   (:import-from :caveman2.app
  6 |                 :find-package-app)
  7 |   (:import-from :caveman2.nested-parameter
  8 |                 :parse-parameters)
  9 |   (:import-from :cl-annot.util
 10 |                 :progn-form-last
 11 |                 :progn-form-replace-last
 12 |                 :definition-form-symbol
 13 |                 :definition-form-type)
 14 |   (:export :defroute
 15 |            :route
 16 |            :*parsed-parameters-symbol-name*))
 17 | (in-package :caveman2.route)
 18 | 
 19 | (defun add-app-if-omitted (routing-rule)
 20 |   (if (or (and (listp routing-rule)
 21 |                (stringp (car routing-rule)))
 22 |           (stringp routing-rule))
 23 |       `(cons (find-package-app ,*package*) ,(if (listp routing-rule)
 24 |                                                 `(list ,@routing-rule)
 25 |                                                 `(list ,routing-rule)))
 26 |       (if (listp routing-rule)
 27 |           `(list ,@routing-rule)
 28 |           `(list ,routing-rule))))
 29 | 
 30 | ;; Add &allow-other-keys if &key exists.
 31 | (defun make-lambda-list (lambda-list)
 32 |   (if (and lambda-list
 33 |            (member 'cl:&key lambda-list :test #'eq)
 34 |            (not (eq (car (last lambda-list)) 'cl:&allow-other-keys)))
 35 |       (append lambda-list '(cl:&allow-other-keys))
 36 |       lambda-list))
 37 | 
 38 | (defun parse-key-arguments (lambda-list)
 39 |   (loop for (arg . rest-args) on lambda-list
 40 |         if (eq arg 'cl:&key)
 41 |           do (return
 42 |                (loop for arg in rest-args
 43 |                      until (and (symbolp arg)
 44 |                                 (eq (symbol-package arg) (find-package :common-lisp))
 45 |                                 (char= (aref (symbol-name arg) 0) #\&))
 46 |                      collect arg))))
 47 | 
 48 | (defun params-form (params-symb lambda-list)
 49 |   (let ((pair (gensym "PAIR")))
 50 |     `(nconc ,@(loop for arg in (parse-key-arguments lambda-list)
 51 |                     collect (destructuring-bind (arg &optional default specified)
 52 |                                 (if (consp arg) arg (list arg))
 53 |                               (declare (ignore default specified))
 54 |                               `(let ((,pair (assoc ,(if (or (string= arg :captures)
 55 |                                                             (string= arg :splat))
 56 |                                                         (intern (symbol-name arg) :keyword)
 57 |                                                         (symbol-name arg))
 58 |                                                    ,params-symb
 59 |                                                    :test #'string=)))
 60 |                                  (if ,pair
 61 |                                      (list ,(intern (symbol-name arg) :keyword) (cdr ,pair))
 62 |                                      nil)))))))
 63 | 
 64 | (defparameter *parsed-parameters-symbol-name* #.(string :_parsed))
 65 | 
 66 | (defun need-parsed-parameters (lambda-list)
 67 |   (member-if (lambda (p)
 68 |                (and (symbolp p)
 69 |                     (string= *parsed-parameters-symbol-name* p)))
 70 |              lambda-list))
 71 | 
 72 | (defmacro defroute (&rest args)
 73 |   (let ((params (gensym "PARAMS")))
 74 |     (typecase (car args)
 75 |       (symbol
 76 |        (destructuring-bind (name routing-rule lambda-list &rest body) args
 77 |          `(prog1
 78 |               ,(multiple-value-bind (body declarations documentation)
 79 |                    (alexandria:parse-body body :documentation t)
 80 |                  `(defun ,name (,params)
 81 |                     (declare (ignorable ,params))
 82 |                     ,@(if documentation (list documentation))
 83 |                     ,@(if lambda-list
 84 |                           `((destructuring-bind ,(make-lambda-list lambda-list)
 85 |                                 ,(if (need-parsed-parameters lambda-list)
 86 |                                   `(append (list
 87 |                                             ,(intern *parsed-parameters-symbol-name* :keyword)
 88 |                                             (parse-parameters ,params))
 89 |                                            ,(params-form params lambda-list))
 90 |                                   (params-form params lambda-list))
 91 |                               ,@declarations
 92 |                               ,@body))
 93 |                          body)))
 94 |             (setf (apply #'ningle:route
 95 |                          (append
 96 |                           ,(add-app-if-omitted routing-rule)
 97 |                           (list :identifier ',name)))
 98 |                   (function ,name)))))
 99 |       (list  (destructuring-bind (routing-rule lambda-list &rest body) args
100 |                (multiple-value-bind (body declarations documentation)
101 |                     (alexandria:parse-body body :documentation t)
102 |                   `(setf (apply #'ningle:route
103 |                                 ,(add-app-if-omitted routing-rule))
104 |                          (lambda (,params)
105 |                            (declare (ignorable ,params))
106 |                            ,@(if documentation (list documentation))
107 |                            ,@(if lambda-list
108 |                                  `((destructuring-bind ,(make-lambda-list lambda-list)
109 |                                        ,(if (need-parsed-parameters lambda-list)
110 |                                             `(append (list
111 |                                                       ,(intern *parsed-parameters-symbol-name* :keyword)
112 |                                                       (parse-parameters ,params))
113 |                                                      ,(params-form params lambda-list))
114 |                                             (params-form params lambda-list))
115 |                                      ,@declarations
116 |                                      ,@body))
117 |                                  body))))))
118 |       (T `(defroute (,(car args)) ,@(cdr args))))))
119 | 
120 | (defun canonicalize-method (method)
121 |   (etypecase method
122 |     (list (mapcar #'canonicalize-method method))
123 |     (keyword method)
124 |     (symbol (intern (symbol-name method) :keyword))))
125 | 
126 | (defannotation route (method routing-rule form)
127 |     (:arity 3)
128 |   (let* ((params (gensym "PARAMS"))
129 |          (last-form (progn-form-last form))
130 |          (type (definition-form-type last-form))
131 |          (symbol (definition-form-symbol last-form))
132 |          lambda-list)
133 |     (ecase type
134 |       (cl:lambda
135 |           (setf lambda-list (second last-form))
136 |           `(setf (apply #'ningle:route
137 |                   (append
138 |                    ,(add-app-if-omitted routing-rule)
139 |                    (list :method ',(canonicalize-method method))))
140 |             (lambda (,params)
141 |               (declare (ignorable ,params))
142 |               ,(if lambda-list
143 |                    `(apply ,form ,(if (need-parsed-parameters lambda-list)
144 |                                       `(append (list
145 |                                                 ,(intern *parsed-parameters-symbol-name* :keyword)
146 |                                                 (parse-parameters ,params))
147 |                                                ,(params-form params lambda-list))
148 |                                       (params-form params lambda-list)))
149 |                    `(funcall ,form)))))
150 |       (cl:defun
151 |           (setf lambda-list (third last-form))
152 |           `(progn
153 |              (setf (apply #'ningle:route
154 |                           (append
155 |                            ,(add-app-if-omitted routing-rule)
156 |                            (list :method ',(canonicalize-method method)
157 |                                  :identifier ',symbol)))
158 |                    (lambda (,params)
159 |                      (declare (ignorable ,params))
160 |                      ,(if lambda-list
161 |                           `(apply (function ,symbol)
162 |                                   ,(if (need-parsed-parameters lambda-list)
163 |                                        `(append (list
164 |                                                  ,(intern *parsed-parameters-symbol-name* :keyword)
165 |                                                  (parse-parameters ,params))
166 |                                                 ,(params-form params lambda-list))
167 |                                        (params-form params lambda-list)))
168 |                           `(funcall (function ,symbol)))))
169 |              ,(progn-form-replace-last
170 |                (list* (first last-form) (second last-form)
171 |                       (make-lambda-list lambda-list)
172 |                       (cdddr last-form))
173 |                form))))))
174 | 


--------------------------------------------------------------------------------
/v2/src/skeleton.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :cl-user)
 2 | (defpackage :caveman2.skeleton
 3 |   (:use :cl)
 4 |   (:export :make-project))
 5 | (in-package :caveman2.skeleton)
 6 | 
 7 | (defvar *skeleton-directory*
 8 |   (asdf:system-relative-pathname :caveman2 #p"v2/skeleton/"))
 9 | 
10 | (defun make-project (path &rest params &key name description author email license &allow-other-keys)
11 |   (declare (ignore name description author email license))
12 |   (let ((cl-project:*skeleton-directory* *skeleton-directory*))
13 |     (apply #'cl-project:make-project path params)))
14 | 


--------------------------------------------------------------------------------
/v2/t/caveman.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :cl-user)
 2 | (defpackage caveman2-test
 3 |   (:use :cl
 4 |         :caveman2
 5 |         :prove
 6 |         :usocket))
 7 | (in-package :caveman2-test)
 8 | 
 9 | (plan 4)
10 | 
11 | (defun port-available-p (port)
12 |   (handler-case (let ((socket (usocket:socket-listen "127.0.0.1" port :reuse-address t)))
13 |                   (usocket:socket-close socket))
14 |     (usocket:address-in-use-error (e) (declare (ignore e)) nil)))
15 | 
16 | (defun find-port-not-in-use (&key (from-port 50000) (to-port 60000))
17 |   (loop for port from (+ from-port (random (- to-port from-port))) upto to-port
18 |         if (port-available-p port)
19 |           return port))
20 | 
21 | (defparameter *app-name*
22 |   (loop for name = (symbol-name (gensym "myapp"))
23 |         while (asdf:find-system name nil)
24 |         finally (return name)))
25 | 
26 | (defparameter *tmp-root*
27 |   (asdf:system-relative-pathname :caveman2 "v2/t/tmp/"))
28 | 
29 | (defparameter *project-root*
30 |   (merge-pathnames (format nil "~A/" *app-name*) *tmp-root*))
31 | 
32 | (when (probe-file *tmp-root*)
33 |   (uiop:delete-directory-tree *tmp-root* :validate t :if-does-not-exist :ignore))
34 | (ensure-directories-exist *tmp-root*)
35 | 
36 | (caveman2:make-project *project-root*)
37 | #+quicklisp (ql:quickload *app-name*)
38 | #-quicklisp (asdf:load-system *app-name*)
39 | 
40 | #+thread-support
41 | (let* ((port (find-port-not-in-use)))
42 |   (ok (funcall (intern #.(string :start) (string-upcase *app-name*)) :port port))
43 |   (sleep 0.5)
44 |   (multiple-value-bind (body status)
45 |       (dex:get (format nil "http://127.0.0.1:~D" port))
46 |     (is status 200)
47 |     (like body "Welcome to Caveman2"))
48 |   (ok (funcall (intern #.(string :stop) (string-upcase *app-name*)))))
49 | #-thread-support
50 | (skip 4 "because your Lisp doesn't support threads")
51 | 
52 | (finalize)
53 | 
54 | (asdf:clear-system *app-name*)
55 | 


--------------------------------------------------------------------------------
/v2/t/nested-parameter.lisp:
--------------------------------------------------------------------------------
  1 | (in-package :cl-user)
  2 | (defpackage caveman2-nested-parameter-test
  3 |   (:use :cl
  4 |         :prove)
  5 |   (:import-from :caveman2.nested-parameter
  6 |                 :parse-parameters
  7 |                 :parse-key)
  8 |   (:import-from :trivial-types
  9 |                 :property-list-p
 10 |                 :association-list-p))
 11 | (in-package :caveman2-nested-parameter-test)
 12 | 
 13 | (plan 15)
 14 | 
 15 | (diag "parse-key")
 16 | 
 17 | (is (parse-key "name") '("name"))
 18 | (is (parse-key "my name") '("my name"))
 19 | (is (parse-key "person[]") '("person" ""))
 20 | (is (parse-key "person[][name]") '("person" "" "name"))
 21 | (is (parse-key "person[") '("person["))
 22 | (is (parse-key "person]") '("person]"))
 23 | 
 24 | (diag "parse-parameters")
 25 | 
 26 | (defun equal-content-p (a b)
 27 |   (when (equal a b)
 28 |     (return-from equal-content-p t))
 29 |   (cond
 30 |     ((and (property-list-p a)
 31 |           (property-list-p b))
 32 |      (every
 33 |       (lambda (a-key)
 34 |         (let ((a-val (getf a a-key)))
 35 |           (if (consp a-val)
 36 |               (if (listp b)
 37 |                   (equal-content-p a-val (getf b a-key))
 38 |                   nil)
 39 |               (equal a-val (getf b a-key)))))
 40 |       (remove-duplicates
 41 |        (loop for k in (append a b) by #'cddr
 42 |              collect k)
 43 |        :test #'equal)))
 44 |     ((and (association-list-p a)
 45 |           (association-list-p b)
 46 |           (not (listp (caar a))))
 47 |      (loop for (a-key . a-val) in (sort (copy-list a) #'string< :key #'car)
 48 |            for (b-key . b-val) in (sort (copy-list b) #'string< :key #'car)
 49 |            unless (and (equal-content-p a-key b-key)
 50 |                        (equal-content-p a-val b-val))
 51 |              do (return-from equal-content-p nil))
 52 |      t)
 53 |     ((and (listp a)
 54 |           (listp b))
 55 |      (every (lambda (a-val b-val)
 56 |               (equal-content-p a-val b-val))
 57 |             a b))
 58 |     (T (equal a b))))
 59 | 
 60 | (defun is-params (params expected &optional desc)
 61 |   (let ((parsed (parse-parameters params)))
 62 |     (if (equal-content-p parsed expected)
 63 |         (ok t desc)
 64 |         (is parsed expected desc))))
 65 | 
 66 | (is (parse-parameters nil)
 67 |     nil
 68 |     "NIL")
 69 | 
 70 | (is-params '(("name" . "Eitaro") ("age" . 26))
 71 |            '(("name" . "Eitaro") ("age" . 26))
 72 |            "Not-nested case")
 73 | 
 74 | (is-params '(("friend_id[]" . 1) ("friend_id[]" . 2) ("age" . 26) ("me[name]" . "Eitaro"))
 75 |            '(("friend_id" . (1 2)) ("age" . 26) ("me" . (("name" . "Eitaro"))))
 76 |            "Normal case")
 77 | 
 78 | (is-params '(("me[name]" . "Eitaro") ("me[birthday][year]" . 1987) ("me[birthday][month]" . 13))
 79 |            '(("me" . (("name" . "Eitaro") ("birthday" . (("year" . 1987) ("month" . 13))))))
 80 |            "Nested case")
 81 | 
 82 | (is-params '(("Check[date]" . "2013/11/05")
 83 |              ("Check[place]" . "Walmart")
 84 |              ("submit" . "Save")
 85 |              ("Check[spendings][][name]" . "cabbage")
 86 |              ("Check[spendings][][amount]" . "2.4")
 87 |              ("Check[spendings][][unit]" . "1")
 88 |              ("Check[spendings][][price]" . "25")
 89 |              ("Check[spendings][][tags]" . "vegetables, food")
 90 |              ("Check[spendings][][name]" . "screwdriver")
 91 |              ("Check[spendings][][amount]" . "1")
 92 |              ("Check[spendings][][unit]" . "3")
 93 |              ("Check[spendings][][price]" . "10")
 94 |              ("Check[spendings][][tags]" . "tools, equipment"))
 95 |            '(("Check" . (("date" . "2013/11/05")
 96 |                          ("place" . "Walmart")
 97 |                          ("spendings" . ((("name" . "cabbage")
 98 |                                           ("amount" . "2.4")
 99 |                                           ("unit" . "1")
100 |                                           ("price" . "25")
101 |                                           ("tags" . "vegetables, food"))
102 |                                          (("name" . "screwdriver")
103 |                                           ("amount" . "1")
104 |                                           ("unit" . "3")
105 |                                           ("price" . "10")
106 |                                           ("tags" . "tools, equipment"))))))
107 |              ("submit" . "Save"))
108 |            "Multiple records")
109 | 
110 | (is-params '(("name[" . "Eitaro") ("age" . 26))
111 |            '(("name[" . "Eitaro") ("age" . 26))
112 |            "Invalid key name")
113 | (is-params '(("name]" . "Eitaro") ("age" . 26))
114 |            '(("name]" . "Eitaro") ("age" . 26))
115 |           "Invalid key name")
116 | 
117 | (is-params '(("my name[family]" . "Eitaro") ("age" . 26))
118 |            '(("my name" . (("family" . "Eitaro"))) ("age" . 26))
119 |            "Key name contains a space")
120 | 
121 | (is-params '(("item [game] type" . "Hardware"))
122 |            '(("item [game] type" . "Hardware")))
123 | 
124 | (finalize)
125 | 


--------------------------------------------------------------------------------
/v2/t/route.lisp:
--------------------------------------------------------------------------------
  1 | (in-package :cl-user)
  2 | (defpackage caveman2-test.route
  3 |   (:use :cl
  4 |         :caveman2
  5 |         :prove)
  6 |   (:import-from :lack.component
  7 |                 :call))
  8 | (in-package :caveman2-test.route)
  9 | 
 10 | (plan 22)
 11 | 
 12 | (defvar *app*)
 13 | 
 14 | (setf *app* (make-instance '<app>))
 15 | (defroute "/" () "Welcome")
 16 | (is (third (call *app* `(:path-info "/"
 17 |                          :query-string ""
 18 |                          :raw-body (flex:make-in-memory-input-stream #())
 19 |                          :request-method :get
 20 |                          :headers ,(make-hash-table))))
 21 |     '("Welcome"))
 22 | 
 23 | (setf *app* (make-instance '<app>))
 24 | (defroute ("/") () "Welcome again")
 25 | (is (third (call *app* `(:path-info "/"
 26 |                          :query-string ""
 27 |                          :raw-body (flex:make-in-memory-input-stream #())
 28 |                          :request-method :get
 29 |                          :headers ,(make-hash-table))))
 30 |     '("Welcome again"))
 31 | 
 32 | (setf *app* (make-instance '<app>))
 33 | (defroute ("/" :method :post) () "Can you still get me?")
 34 | (is (first (call *app* `(:path-info "/"
 35 |                          :query-string ""
 36 |                          :raw-body (flex:make-in-memory-input-stream #())
 37 |                          :request-method :get
 38 |                          :headers ,(make-hash-table))))
 39 |     404
 40 |     ":method :post")
 41 | (is (third (call *app* `(:path-info "/"
 42 |                          :query-string ""
 43 |                          :raw-body (flex:make-in-memory-input-stream #())
 44 |                          :request-method :post
 45 |                          :headers ,(make-hash-table))))
 46 |     '("Can you still get me?")
 47 |     ":method :post")
 48 | 
 49 | (setf *app* (make-instance '<app>))
 50 | (defroute (*app* "/") () "Hello")
 51 | (is (third (call *app* `(:path-info "/"
 52 |                          :query-string ""
 53 |                          :raw-body (flex:make-in-memory-input-stream #())
 54 |                          :request-method :get
 55 |                          :headers ,(make-hash-table))))
 56 |     '("Hello")
 57 |     "Specify an app")
 58 | 
 59 | (setf *app* (make-instance '<app>))
 60 | (defroute index "/" () "Hello")
 61 | (is (third (call *app* `(:path-info "/"
 62 |                          :query-string ""
 63 |                          :raw-body (flex:make-in-memory-input-stream #())
 64 |                          :request-method :get
 65 |                          :headers ,(make-hash-table))))
 66 |     '("Hello")
 67 |     "Named route")
 68 | (defroute index ("/new" :method :post) () "okay")
 69 | (is (third (call *app* `(:path-info "/new"
 70 |                          :query-string ""
 71 |                          :raw-body (flex:make-in-memory-input-stream #())
 72 |                          :request-method :post
 73 |                          :headers ,(make-hash-table))))
 74 |     '("okay")
 75 |     "Named route")
 76 | 
 77 | (defroute hello ("/hello/([\\w]+)$" :regexp t) (&key captures)
 78 |   (format nil "Hello, ~A!" (first captures)))
 79 | (is (third (call *app* `(:path-info "/hello/Eitaro"
 80 |                          :query-string ""
 81 |                          :raw-body (flex:make-in-memory-input-stream #())
 82 |                          :request-method :get
 83 |                          :headers ,(make-hash-table))))
 84 |     '("Hello, Eitaro!")
 85 |     "Regular expression")
 86 | (is (first (call *app* `(:path-info "/hello/Eitaro&Fukamachi"
 87 |                          :query-string ""
 88 |                          :raw-body (flex:make-in-memory-input-stream #())
 89 |                          :request-method :get
 90 |                          :headers ,(make-hash-table))))
 91 |     404
 92 |     "Regular expression")
 93 | (is (first (call *app* `(:path-info "/hello/"
 94 |                          :query-string ""
 95 |                          :raw-body (flex:make-in-memory-input-stream #())
 96 |                          :request-method :get
 97 |                          :headers ,(make-hash-table))))
 98 |     404
 99 |     "Regular expression")
100 | 
101 | (setf *app* (make-instance '<app>))
102 | (defroute index (*app* "/" :method :get) () "Hello")
103 | (is (third (call *app* `(:path-info "/"
104 |                          :query-string ""
105 |                          :raw-body (flex:make-in-memory-input-stream #())
106 |                          :request-method :get
107 |                          :headers ,(make-hash-table))))
108 |     '("Hello")
109 |     "Full")
110 | (defroute index (*app* "/" :method :get) () "Hello again")
111 | (is (third (call *app* `(:path-info "/"
112 |                          :query-string ""
113 |                          :raw-body (flex:make-in-memory-input-stream #())
114 |                          :request-method :get
115 |                          :headers ,(make-hash-table))))
116 |     '("Hello again")
117 |     "Full")
118 | 
119 | (syntax:use-syntax :annot)
120 | 
121 | (setf *app* (make-instance '<app>))
122 | 
123 | @route GET "/"
124 | (defun index ()
125 |   "Welcome")
126 | @route (GET POST) "/new"
127 | (defun new ()
128 |   "Create something")
129 | @route GET "/myname"
130 | (lambda (&key |name|)
131 |   (if |name|
132 |       (format nil "My name is ~A." |name|)
133 |       "I have no name yet."))
134 | @route GET "/hello"
135 | @route GET "/hello/:name"
136 | (defun say-hello (&key (name "Guest"))
137 |   (format nil "Hello, ~A" name))
138 | 
139 | (is (third (call *app* `(:path-info "/"
140 |                          :query-string ""
141 |                          :raw-body (flex:make-in-memory-input-stream #())
142 |                          :request-method :get
143 |                          :headers ,(make-hash-table))))
144 |     '("Welcome")
145 |     "@route")
146 | (is (third (call *app* `(:path-info "/new"
147 |                          :query-string ""
148 |                          :raw-body (flex:make-in-memory-input-stream #())
149 |                          :request-method :get
150 |                          :headers ,(make-hash-table))))
151 |     '("Create something")
152 |     "@route")
153 | (is (third (call *app* `(:path-info "/new"
154 |                          :query-string ""
155 |                          :raw-body (flex:make-in-memory-input-stream #())
156 |                          :request-method :post
157 |                          :headers ,(make-hash-table))))
158 |     '("Create something")
159 |     "@route")
160 | (is (third (call *app* `(:path-info "/myname"
161 |                          :query-string ""
162 |                          :raw-body (flex:make-in-memory-input-stream #())
163 |                          :request-method :get
164 |                          :headers ,(make-hash-table))))
165 |     '("I have no name yet.")
166 |     "@route")
167 | (is (third (call *app* `(:path-info "/myname"
168 |                          :query-string "name=Eitaro"
169 |                          :raw-body (flex:make-in-memory-input-stream #())
170 |                          :request-method :get
171 |                          :headers ,(make-hash-table))))
172 |     '("My name is Eitaro.")
173 |     "@route")
174 | (is (third (call *app* `(:path-info "/hello"
175 |                          :query-string ""
176 |                          :raw-body (flex:make-in-memory-input-stream #())
177 |                          :request-method :get
178 |                          :headers ,(make-hash-table))))
179 |     '("Hello, Guest")
180 |     "@route")
181 | (is (third (call *app* `(:path-info "/hello/Eitaro"
182 |                          :query-string ""
183 |                          :raw-body (flex:make-in-memory-input-stream #())
184 |                          :request-method :get
185 |                          :headers ,(make-hash-table))))
186 |     '("Hello, Eitaro")
187 |     "@route")
188 | (is (third (call *app* `(:path-info "/hello/Eitaro"
189 |                          :query-string "id=12345"
190 |                          :raw-body (flex:make-in-memory-input-stream #())
191 |                          :request-method :get
192 |                          :headers ,(make-hash-table))))
193 |     '("Hello, Eitaro")
194 |     "@route")
195 | 
196 | (defroute add-item (*app* "/post" :method :post) (&key _parsed)
197 |   (with-output-to-string (s)
198 |     (loop for item in (cdr (assoc "items" _parsed :test #'string=))
199 |           do (format s "~&name:~S / price:~S~%"
200 |                      (cdr (assoc "name" item :test #'string=))
201 |                      (cdr (assoc "price" item :test #'string=))))))
202 | 
203 | (is (third (call *app* `(:path-info "/post"
204 |                          :query-string "items[][name]=WiiU&items[][price]=30000&items[][name]=PS4&items[][price]=69000"
205 |                          :raw-body (flex:make-in-memory-input-stream #())
206 |                          :request-method :post
207 |                          :headers ,(make-hash-table))))
208 |     '("name:\"WiiU\" / price:\"30000\"
209 | name:\"PS4\" / price:\"69000\"
210 | ")
211 |     "@route")
212 | 
213 | (is (third (call *app* `(:path-info "/post"
214 |                          :query-string "_PARSED=&items[][name]=WiiU&items[][price]=30000&items[][name]=PS4&items[][price]=69000"
215 |                          :raw-body (flex:make-in-memory-input-stream #())
216 |                          :request-method :post
217 |                          :headers ,(make-hash-table))))
218 |     '("name:\"WiiU\" / price:\"30000\"
219 | name:\"PS4\" / price:\"69000\"
220 | ")
221 |     "@route")
222 | 
223 | (finalize)
224 | 


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