Browse Source
There was snippets of code in the code I liked. I'm going to keep it around for a bit to see if I can work some of it in to the new code. I'm most interested in the deployment code.stable
Craig Oates
2 years ago
31 changed files with 1041 additions and 0 deletions
@ -0,0 +1,16 @@ |
|||||||
|
LISP ?= sbcl
|
||||||
|
|
||||||
|
all: test |
||||||
|
|
||||||
|
run: |
||||||
|
rlwrap $(LISP) --load run.lisp
|
||||||
|
|
||||||
|
build: |
||||||
|
$(LISP) --non-interactive \
|
||||||
|
--load ritherdon-archive.asd \
|
||||||
|
--eval '(ql:quickload :ritherdon-archive)' \
|
||||||
|
--eval '(asdf:make :ritherdon-archive)'
|
||||||
|
|
||||||
|
test: |
||||||
|
$(LISP) --non-interactive \
|
||||||
|
--load run-tests.lisp
|
@ -0,0 +1,101 @@ |
|||||||
|
# ritherdon-archive |
||||||
|
|
||||||
|
Archive of Ritherdon and Nicola Ellis. |
||||||
|
|
||||||
|
# Usage |
||||||
|
|
||||||
|
Run from sources: |
||||||
|
|
||||||
|
make run |
||||||
|
# aka sbcl --load run.lisp |
||||||
|
|
||||||
|
choose your lisp: |
||||||
|
|
||||||
|
LISP=ccl make run |
||||||
|
|
||||||
|
or build and run the binary: |
||||||
|
|
||||||
|
``` |
||||||
|
$ make build |
||||||
|
$ ./ritherdon-archive [name] |
||||||
|
Hello [name] from ritherdon-archive |
||||||
|
``` |
||||||
|
|
||||||
|
## Init config file |
||||||
|
|
||||||
|
Create a config file: |
||||||
|
|
||||||
|
cp config-example.lisp config.lisp |
||||||
|
|
||||||
|
You can override global variables (for example, the port, which can be |
||||||
|
handy if you run the app from sources, without building a binary and |
||||||
|
using the `--port` flag. |
||||||
|
|
||||||
|
The config file is `load`ed before the web server starts (see the `(main)`). |
||||||
|
|
||||||
|
|
||||||
|
## Roswell integration |
||||||
|
|
||||||
|
Roswell is an implementation manager and [script launcher](https://github.com/roswell/roswell/wiki/Roswell-as-a-Scripting-Environment). |
||||||
|
|
||||||
|
A POC script is in the roswell/ directory. |
||||||
|
|
||||||
|
Your users can install the script with `craig/ritherdon-archive`. |
||||||
|
|
||||||
|
# Dev |
||||||
|
|
||||||
|
Load the .asd, quickload it then |
||||||
|
|
||||||
|
``` |
||||||
|
CL-USER> (ritherdon-archive/web:start-app) |
||||||
|
``` |
||||||
|
|
||||||
|
See also: |
||||||
|
|
||||||
|
- `web::load-config &key port load-init-p` |
||||||
|
|
||||||
|
|
||||||
|
## Tests |
||||||
|
|
||||||
|
Tests are defined with [Fiveam](https://common-lisp.net/project/fiveam/docs/). |
||||||
|
|
||||||
|
Run them from the terminal with `make test`. You should see a failing test. |
||||||
|
|
||||||
|
```bash |
||||||
|
$ make test |
||||||
|
Running test suite TESTMAIN |
||||||
|
Running test TEST1 f |
||||||
|
Did 1 check. |
||||||
|
Pass: 0 ( 0%) |
||||||
|
Skip: 0 ( 0%) |
||||||
|
Fail: 1 (100%) |
||||||
|
|
||||||
|
Failure Details: |
||||||
|
-------------------------------- |
||||||
|
TEST1 in TESTMAIN []: |
||||||
|
|
||||||
|
3 |
||||||
|
|
||||||
|
evaluated to |
||||||
|
|
||||||
|
3 |
||||||
|
|
||||||
|
which is not |
||||||
|
|
||||||
|
= |
||||||
|
|
||||||
|
to |
||||||
|
|
||||||
|
2 |
||||||
|
|
||||||
|
Makefile:15: recipe for target 'test' failed |
||||||
|
|
||||||
|
$ echo $? |
||||||
|
2 |
||||||
|
``` |
||||||
|
|
||||||
|
On Slime, load the test package and run `run!`. |
||||||
|
|
||||||
|
--- |
||||||
|
|
||||||
|
Licence: BSD |
@ -0,0 +1,9 @@ |
|||||||
|
* Ritherdon Archive |
||||||
|
|
||||||
|
An archive of Ritherdon. I need to speak to Nic more about what this |
||||||
|
means. |
||||||
|
|
||||||
|
* Project Summary |
||||||
|
|
||||||
|
This is a website written in Common Lisp and the Caveman2 framework. The |
||||||
|
databased it uses in SQLite3 and Steel Bank Common Lisp (SBCL). |
Binary file not shown.
Binary file not shown.
@ -0,0 +1,12 @@ |
|||||||
|
|
||||||
|
(in-package :ritherdon-archive) |
||||||
|
|
||||||
|
(in-package :ritherdon-archive/web) |
||||||
|
|
||||||
|
;; |
||||||
|
;; To use an init configuration file: |
||||||
|
;; cp config-example.lisp config.lisp |
||||||
|
;; |
||||||
|
|
||||||
|
;; Override the port: |
||||||
|
;; (setf *port* 4545) |
@ -0,0 +1,18 @@ |
|||||||
|
(in-package :asdf-user) |
||||||
|
(defsystem "ritherdon-archive-tests" |
||||||
|
:description "Test suite for the ritherdon-archive system" |
||||||
|
:author "Craig Oates <craig@craigoates.net>" |
||||||
|
:version "0.0.0" |
||||||
|
:depends-on (:ritherdon-archive |
||||||
|
:parachute) |
||||||
|
:license "MIT" |
||||||
|
:serial t |
||||||
|
:components ((:module "tests" |
||||||
|
:serial t |
||||||
|
:components ((:file "packages") |
||||||
|
(:file "test-ritherdon-archive")))) |
||||||
|
:perform (test-op (op s) (symbol-call :parachute :test :tests)) |
||||||
|
|
||||||
|
;; The following would not return the right exit code on error, but still 0. |
||||||
|
;; :perform (test-op (op _) (symbol-call :fiveam :run-all-tests)) |
||||||
|
) |
@ -0,0 +1,89 @@ |
|||||||
|
(in-package :asdf-user) |
||||||
|
|
||||||
|
(defsystem "ritherdon-archive" |
||||||
|
:author "Craig Oates <craig@craigoates.net>" |
||||||
|
:version "0.0.0" |
||||||
|
:license "MIT" |
||||||
|
:description "Archive of Ritherdon and Nicola Ellis." |
||||||
|
:homepage "" |
||||||
|
:bug-tracker "" |
||||||
|
:source-control (:git "") |
||||||
|
|
||||||
|
;; Dependencies. |
||||||
|
:depends-on ( |
||||||
|
;; HTTP client |
||||||
|
:dexador |
||||||
|
|
||||||
|
;; templates |
||||||
|
:djula |
||||||
|
|
||||||
|
;; server, routing |
||||||
|
:hunchentoot |
||||||
|
:easy-routes |
||||||
|
|
||||||
|
;; JSON |
||||||
|
:cl-json |
||||||
|
|
||||||
|
;; DB |
||||||
|
:mito |
||||||
|
:mito-auth |
||||||
|
|
||||||
|
;; utilities |
||||||
|
:access |
||||||
|
:cl-ppcre |
||||||
|
:cl-slug |
||||||
|
:local-time |
||||||
|
:local-time-duration |
||||||
|
:log4cl |
||||||
|
:str |
||||||
|
|
||||||
|
;; scripting |
||||||
|
:unix-opts |
||||||
|
|
||||||
|
;; deployment |
||||||
|
:deploy |
||||||
|
|
||||||
|
;; development utilities |
||||||
|
) |
||||||
|
|
||||||
|
;; Build a binary. |
||||||
|
;; :build-operation "program-op" ;; usual op to build a binary. |
||||||
|
;; Deploy: |
||||||
|
:defsystem-depends-on (:deploy) |
||||||
|
:build-operation "deploy-op" |
||||||
|
:build-pathname "ritherdon-archive" |
||||||
|
:entry-point "ritherdon-archive:run" |
||||||
|
|
||||||
|
;; Project stucture. |
||||||
|
:serial t |
||||||
|
:components ((:module "src" |
||||||
|
:components |
||||||
|
;; stand-alone packages. |
||||||
|
((:file "packages") |
||||||
|
(:file "utils") |
||||||
|
;; they depend on the above. |
||||||
|
;; (:file "authentication") |
||||||
|
(:file "web") |
||||||
|
(:file "ritherdon-archive") |
||||||
|
(:file "database"))) |
||||||
|
|
||||||
|
(:module "src/models" |
||||||
|
:components |
||||||
|
((:file "models") |
||||||
|
(:file "user"))) |
||||||
|
|
||||||
|
(:static-file "README.md"))) |
||||||
|
|
||||||
|
;; Deploy may not find libcrypto on your system. |
||||||
|
;; But anyways, we won't ship it to rely instead |
||||||
|
;; on its presence on the target OS. |
||||||
|
(require :cl+ssl) ; sometimes necessary. |
||||||
|
#+linux (deploy:define-library cl+ssl::libssl :dont-deploy T) |
||||||
|
#+linux (deploy:define-library cl+ssl::libcrypto :dont-deploy T) |
||||||
|
|
||||||
|
;; ASDF wants to update itself and fails. |
||||||
|
;; Yeah, it does that even when running the binary on my VPS O_o |
||||||
|
;; Please, don't. |
||||||
|
(deploy:define-hook (:deploy asdf) (directory) |
||||||
|
#+asdf (asdf:clear-source-registry) |
||||||
|
#+asdf (defun asdf:upgrade-asdf () NIL)) |
@ -0,0 +1,37 @@ |
|||||||
|
|
||||||
|
## How to use Roswell to build and share binaries |
||||||
|
|
||||||
|
From the project root: |
||||||
|
|
||||||
|
Run as a script: |
||||||
|
|
||||||
|
chmod +x roswell/ritherdon-archive.ros |
||||||
|
./roswell/ritherdon-archive.ros |
||||||
|
|
||||||
|
Build a binary: |
||||||
|
|
||||||
|
ros build roswell/ritherdon-archive.ros |
||||||
|
|
||||||
|
and run it: |
||||||
|
|
||||||
|
./roswell/ritherdon-archive |
||||||
|
|
||||||
|
Or install it in ~/.roswell/bin: |
||||||
|
|
||||||
|
ros install roswell/ritherdon-archive.ros |
||||||
|
|
||||||
|
It creates the binary in ~/.roswell/bin/ |
||||||
|
Run it: |
||||||
|
|
||||||
|
~/.roswell/bin/ritherdon-archive [name]~& |
||||||
|
|
||||||
|
Your users can install the script with ros install craig/ritherdon-archive |
||||||
|
|
||||||
|
Use `+Q` if you don't have Quicklisp dependencies to save startup time. |
||||||
|
Use `ros build --disable-compression` to save on startup time and loose on application size. |
||||||
|
|
||||||
|
|
||||||
|
## See |
||||||
|
|
||||||
|
- https://github.com/roswell/roswell/wiki/ |
||||||
|
- https://github.com/roswell/roswell/wiki/Reducing-Startup-Time |
@ -0,0 +1,28 @@ |
|||||||
|
#!/bin/sh |
||||||
|
#|-*- mode:lisp -*-|# |
||||||
|
#| |
||||||
|
exec ros -Q -- $0 "$@" |
||||||
|
|# |
||||||
|
|
||||||
|
;; use +Q if you don't have Quicklisp dependencies to save startup time. |
||||||
|
|
||||||
|
(defun help () |
||||||
|
(format t "~&Usage: |
||||||
|
|
||||||
|
ritherdon-archive [name] |
||||||
|
|
||||||
|
")) |
||||||
|
|
||||||
|
;; XXX: this load does not load from everywhere |
||||||
|
;; it doesn't work for to run as a script. |
||||||
|
(load (truename "ritherdon-archive.asd")) |
||||||
|
(ql:quickload "ritherdon-archive") |
||||||
|
|
||||||
|
(defun main (&rest argv) |
||||||
|
"Optional name parameter." |
||||||
|
(when (member "-h" argv :test #'equal) |
||||||
|
;; To parse command line arguments, use a third-party library such as |
||||||
|
;; unix-opts, defmain, adopt… |
||||||
|
(help) |
||||||
|
(uiop:quit)) |
||||||
|
(ritherdon-archive::greet (first argv))) |
@ -0,0 +1,9 @@ |
|||||||
|
|
||||||
|
(load "ritherdon-archive.asd") |
||||||
|
(load "ritherdon-archive-tests.asd") |
||||||
|
|
||||||
|
(ql:quickload "ritherdon-archive-tests") |
||||||
|
|
||||||
|
(in-package :ritherdon-archive-tests) |
||||||
|
|
||||||
|
(uiop:quit (if (run-all-tests) 0 1)) |
@ -0,0 +1,25 @@ |
|||||||
|
" |
||||||
|
Usage: |
||||||
|
|
||||||
|
rlwrap sbcl --load run.lisp |
||||||
|
|
||||||
|
This loads the project's asd, loads the quicklisp dependencies, and |
||||||
|
calls the main function. |
||||||
|
|
||||||
|
Then, we are given the lisp prompt. |
||||||
|
|
||||||
|
If you don't want to land in the REPL, you can (quit) below or call lisp with the --non-interactive flag. |
||||||
|
|
||||||
|
Another solution to run the app is to build and run a binary (see README). |
||||||
|
" |
||||||
|
|
||||||
|
(load "ritherdon-archive.asd") |
||||||
|
|
||||||
|
(ql:quickload "ritherdon-archive") |
||||||
|
|
||||||
|
(in-package :ritherdon-archive) |
||||||
|
(handler-case |
||||||
|
(main) |
||||||
|
(error (c) |
||||||
|
(format *error-output* "~&An error occured: ~a~&" c) |
||||||
|
(uiop:quit 1))) |
@ -0,0 +1,39 @@ |
|||||||
|
#!/bin/bash |
||||||
|
|
||||||
|
# Create account so user can log-in to the website. Assumes you're using |
||||||
|
# SQLilte3 as the database. |
||||||
|
|
||||||
|
# Moves to the location of the script (regardless of where the script |
||||||
|
# was called from). |
||||||
|
cd "$(dirname "$0")" |
||||||
|
DATABASE="ritherdon-archive.db" |
||||||
|
|
||||||
|
read -p "Username: " USERNAME |
||||||
|
read -p "Display Name: " DISPLAY_NAME |
||||||
|
read -sp "Password: " USER_PASSWORD |
||||||
|
echo |
||||||
|
read -sp "Confirm Password: " PASSWORD_TEST |
||||||
|
echo |
||||||
|
|
||||||
|
if [[ $USERNAME == "" ]] |
||||||
|
|| [[ $DISPLAY_NAME == "" ]] |
||||||
|
|| [[ $USER_PASSWORD == "" ]]; then |
||||||
|
echo "[ERROR] Empty string used." |
||||||
|
else |
||||||
|
if [[ $USER_PASSWORD == $PASSWORD_TEST ]]; then |
||||||
|
echo "[SUCCESS] Password verified." |
||||||
|
if [ -e "../$DATABASE" ]; then |
||||||
|
echo "[INFO] Database found. Adding user to it..." |
||||||
|
SQL="INSERT INTO user (username,display_name,password,created_at,updated_at) \ |
||||||
|
VALUES (\"$USERNAME\",\"$DISPLAY_NAME\",\"$USER_PASSWORD\",(datetime(\"now\")),NULL);" |
||||||
|
cd ../ |
||||||
|
sqlite3 $DATABASE "$SQL" |
||||||
|
|
||||||
|
else |
||||||
|
echo "[ERROR] Cannot find database. Make sure you've ran make build." |
||||||
|
exit |
||||||
|
fi |
||||||
|
else |
||||||
|
echo "[ERROR] Passwords do not match." |
||||||
|
fi |
||||||
|
fi |
@ -0,0 +1,30 @@ |
|||||||
|
(in-package :ritherdon-archive/models) |
||||||
|
;;; |
||||||
|
;;; DB connection, migrations. |
||||||
|
;;; |
||||||
|
|
||||||
|
(defparameter *tables* '(product user) |
||||||
|
"List of the DB tables that need to be checked for migrations.") |
||||||
|
|
||||||
|
(defun connect (&optional (db-name *db-name*)) |
||||||
|
"Connect to the DB." |
||||||
|
;; *db* could be mito:*connection* |
||||||
|
(log:debug "connecting to ~a~&" *db-name*) |
||||||
|
(setf *db* (mito:connect-toplevel :sqlite3 :database-name db-name))) |
||||||
|
|
||||||
|
(defun ensure-tables-exist () |
||||||
|
"Run SQL to create the missing tables." |
||||||
|
(unless mito::*connection* |
||||||
|
(connect)) |
||||||
|
(mapcar #'mito:ensure-table-exists *tables*)) |
||||||
|
|
||||||
|
(defun migrate-all () |
||||||
|
"Migrate the tables after we changed the class definition." |
||||||
|
(mapcar #'mito:migrate-table *tables*)) |
||||||
|
|
||||||
|
;; |
||||||
|
;; Entry points |
||||||
|
;; |
||||||
|
(defun init-db () |
||||||
|
"Connect to the DB, run the required migrations and define a couple base user roles." |
||||||
|
(ensure-tables-exist)) |
@ -0,0 +1,61 @@ |
|||||||
|
(in-package :ritherdon-archive/models) |
||||||
|
|
||||||
|
(defparameter *db-name* (asdf:system-relative-pathname :ritherdon-archive "ritherdon-archive.db")) |
||||||
|
|
||||||
|
(defparameter *db* nil |
||||||
|
"DB connection object, returned by (connect).") |
||||||
|
|
||||||
|
;; After modification, run (migrate-all) |
||||||
|
;; |
||||||
|
;; - to create a date: (local-time:now) |
||||||
|
;; " |
||||||
|
(defclass product () |
||||||
|
((title |
||||||
|
:accessor title |
||||||
|
:initarg :title |
||||||
|
:initform nil |
||||||
|
:type string |
||||||
|
:col-type (:varchar 128)) |
||||||
|
|
||||||
|
(reference |
||||||
|
:accessor reference |
||||||
|
:initarg :reference |
||||||
|
:initform nil |
||||||
|
:type (or string null) |
||||||
|
:col-type (or (:varchar 128) :null)) |
||||||
|
|
||||||
|
(price |
||||||
|
:accessor price |
||||||
|
:initarg :price |
||||||
|
;; we don't the price to 0 (nil denotes a missing field) |
||||||
|
:initform nil |
||||||
|
:type (or integer null) |
||||||
|
:col-type (or :float :null) |
||||||
|
:documentation "Store prices as integers. $9.80 => 980") |
||||||
|
|
||||||
|
(quantity |
||||||
|
:accessor quantity |
||||||
|
:initform 1 |
||||||
|
:type (or integer null) |
||||||
|
:col-type (or (:integer) :null) |
||||||
|
:documentation "Quantity in stock.")) |
||||||
|
|
||||||
|
(:metaclass mito:dao-table-class) |
||||||
|
(:documentation "A product.")) |
||||||
|
|
||||||
|
(defun make-product (&key title reference price) |
||||||
|
"Create a product instance. |
||||||
|
It is not saved in the DB yet." |
||||||
|
(make-instance 'product |
||||||
|
:title title |
||||||
|
:reference reference |
||||||
|
:price price)) |
||||||
|
|
||||||
|
(defun select-products (&key (order :asc)) |
||||||
|
(mito:select-dao 'product |
||||||
|
(sxql:order-by `(,order :created-at)))) |
||||||
|
|
||||||
|
(defun find-by (key val) |
||||||
|
"Find a product by slot. Example: (find-by :id xxx). Return only the first matching result." |
||||||
|
(when val |
||||||
|
(mito:find-dao 'product key val))) |
@ -0,0 +1,26 @@ |
|||||||
|
(in-package :ritherdon-archive/models) |
||||||
|
|
||||||
|
(defclass user () |
||||||
|
((username |
||||||
|
:accessor username |
||||||
|
:initarg :username |
||||||
|
:initform nil |
||||||
|
:type (or string null) |
||||||
|
:col-type :text) |
||||||
|
|
||||||
|
(display-name |
||||||
|
:accessor display-name |
||||||
|
:initarg :display-name |
||||||
|
:initform nil |
||||||
|
:type (or string null) |
||||||
|
:col-type :text) |
||||||
|
|
||||||
|
(password |
||||||
|
:accessor password |
||||||
|
:initarg :password |
||||||
|
:initform nil |
||||||
|
:type (or string null) |
||||||
|
:col-type :text)) |
||||||
|
|
||||||
|
(:metaclass mito:dao-table-class) |
||||||
|
(:documentation "Account information for users to log-in to the website..")) |
@ -0,0 +1,41 @@ |
|||||||
|
;;; |
||||||
|
;;; define helper packages, |
||||||
|
;;; the models, |
||||||
|
;;; the web, |
||||||
|
;;; and the base package that relies on all of them. |
||||||
|
;;; |
||||||
|
|
||||||
|
(defpackage ritherdon-archive/utils |
||||||
|
(:use :cl |
||||||
|
:log4cl) |
||||||
|
(:export #:format-date |
||||||
|
#:i18n-load |
||||||
|
#:_ |
||||||
|
#:parse-iso-date) |
||||||
|
(:documentation "Utilities that do not depend on models.")) |
||||||
|
|
||||||
|
(defpackage ritherdon-archive/models |
||||||
|
(:use :cl) |
||||||
|
(:export :connect |
||||||
|
:make-product |
||||||
|
:select-products |
||||||
|
:find-by)) |
||||||
|
|
||||||
|
(defpackage ritherdon-archive/web |
||||||
|
(:use :cl) |
||||||
|
(:import-from :easy-routes |
||||||
|
:defroute) |
||||||
|
(:export :start-app |
||||||
|
:stop-app) |
||||||
|
(:local-nicknames (#:a #:alexandria) |
||||||
|
(#:models #:ritherdon-archive/models) |
||||||
|
(#:utils #:ritherdon-archive/utils))) |
||||||
|
|
||||||
|
(defpackage ritherdon-archive |
||||||
|
(:use :cl |
||||||
|
:log4cl) |
||||||
|
(:export :main :run) |
||||||
|
(:local-nicknames (#:a #:alexandria) |
||||||
|
(#:models #:ritherdon-archive/models) |
||||||
|
(#:web #:ritherdon-archive/web) |
||||||
|
(#:utils #:ritherdon-archive/utils))) |
@ -0,0 +1,105 @@ |
|||||||
|
(in-package :ritherdon-archive) |
||||||
|
|
||||||
|
;; Define your project functionality here... |
||||||
|
|
||||||
|
(defparameter +version+ "0.0.1") ;; xxx: read from .asd |
||||||
|
|
||||||
|
(defun print-system-info (&optional (stream t)) |
||||||
|
;; see also https://github.com/40ants/cl-info |
||||||
|
(format stream "~&OS: ~a ~a~&" (software-type) (software-version)) |
||||||
|
(format stream "~&Lisp: ~a ~a~&" (lisp-implementation-type) (lisp-implementation-version)) |
||||||
|
#+asdf |
||||||
|
(format stream "~&ASDF: ~a~&" (asdf:asdf-version)) |
||||||
|
#-asdf |
||||||
|
(format stream "NO ASDF!") |
||||||
|
#+quicklisp |
||||||
|
(format stream "~&Quicklisp: ~a~&" (ql-dist:all-dists)) |
||||||
|
#-quicklisp |
||||||
|
(format stream "!! Quicklisp is not installed !!")) |
||||||
|
|
||||||
|
(defun handle-parser-error (c) |
||||||
|
"unix-opts error handler." |
||||||
|
(format t "Argument error: ~a~&" (opts:option c))) |
||||||
|
|
||||||
|
(defun main () |
||||||
|
"Parse basic CLI args, start our web app." |
||||||
|
|
||||||
|
(unless (uiop:file-exists-p models::*db-name*) |
||||||
|
(uiop:format! t "Creating the database into ~a...~&" models::*db-name*) |
||||||
|
(models::init-db)) |
||||||
|
|
||||||
|
(opts:define-opts |
||||||
|
(:name :help |
||||||
|
:description "print this help and exit." |
||||||
|
:short #\h |
||||||
|
:long "help") |
||||||
|
|
||||||
|
(:name :version |
||||||
|
:description "print the version number and exit." |
||||||
|
:short #\v |
||||||
|
:long "version") |
||||||
|
|
||||||
|
(:name :verbose |
||||||
|
:description "print debug info." |
||||||
|
:short #\V |
||||||
|
:long "verbose") |
||||||
|
|
||||||
|
(:name :port |
||||||
|
:arg-parser #'parse-integer |
||||||
|
:description "set the port for the web server. You can also use the XYZ_PORT environment variable." |
||||||
|
:short #\p |
||||||
|
:long "port")) |
||||||
|
|
||||||
|
(multiple-value-bind (options free-args) |
||||||
|
(handler-bind ((error #'handle-parser-error)) |
||||||
|
(opts:get-opts)) |
||||||
|
|
||||||
|
(format t "ritherdon-archive version ~a~&" +version+) |
||||||
|
|
||||||
|
(when (getf options :version) |
||||||
|
(print-system-info) |
||||||
|
(uiop:quit)) |
||||||
|
|
||||||
|
(when (getf options :help) |
||||||
|
(opts:describe) |
||||||
|
(uiop:quit)) |
||||||
|
|
||||||
|
(when (getf options :verbose) |
||||||
|
(print-system-info)) |
||||||
|
|
||||||
|
(web::load-config) |
||||||
|
|
||||||
|
(web:start-app :port (or (getf options :port) |
||||||
|
(ignore-errors (parse-integer (uiop:getenv "XYZ_PORT"))) |
||||||
|
web::*port*)))) |
||||||
|
|
||||||
|
(defun run () |
||||||
|
"Start our web app calling the MAIN function, and: |
||||||
|
|
||||||
|
- put the server thread on the foreground, so that Lisp doesn't quit |
||||||
|
instantly, and our binary keeps running |
||||||
|
- catch a couple errors: port in use, a user's C-c." |
||||||
|
(handler-case |
||||||
|
(progn |
||||||
|
|
||||||
|
(main) |
||||||
|
|
||||||
|
;; That's only needed for the binary, not when running from sources |
||||||
|
;; (except if you run for Systemd…). |
||||||
|
;; Put the server thread on the foreground. |
||||||
|
;; Without this, the binary exits immediately. |
||||||
|
(bt:join-thread |
||||||
|
(find-if (lambda (th) |
||||||
|
(search "hunchentoot" (bt:thread-name th))) |
||||||
|
(bt:all-threads)))) |
||||||
|
|
||||||
|
;; Catch some errors. |
||||||
|
(usocket:address-in-use-error () |
||||||
|
(format *error-output* "This port is already taken.~&")) |
||||||
|
#+sbcl |
||||||
|
(sb-sys:interactive-interrupt () |
||||||
|
(format *error-output* "~&Bye!~&") |
||||||
|
(uiop:quit)) |
||||||
|
(error (c) |
||||||
|
(format *error-output* "~&An error occured: ~a~&" c) |
||||||
|
(uiop:quit 1)))) |
@ -0,0 +1,2 @@ |
|||||||
|
|
||||||
|
console.log("Hello ritherdon-archive!"); |
@ -0,0 +1 @@ |
|||||||
|
<h1>404: Web Page Not Found</h1> |
@ -0,0 +1,5 @@ |
|||||||
|
{% extends "base.html" %} |
||||||
|
|
||||||
|
{% block content %} |
||||||
|
<h1>About</h1> |
||||||
|
{% end block %} |
@ -0,0 +1,6 @@ |
|||||||
|
{% extends "base.html" %} |
||||||
|
|
||||||
|
{% block content %} |
||||||
|
<h1>Archive</h1> |
||||||
|
|
||||||
|
{% end block %} |
@ -0,0 +1,15 @@ |
|||||||
|
<!DOCTYPE html> |
||||||
|
<html lang="en"> |
||||||
|
<head> |
||||||
|
<meta charset="utf-8"> |
||||||
|
<title>{% block title %}{% endblock %}</title> |
||||||
|
<meta name="viewport" content="width=device-width, initial-scale=1"> |
||||||
|
<meta http-equiv="X-UA-Compatible" content="IE=edge"> |
||||||
|
<meta name="viewport" content="width=device-width, initial-scale=1"> |
||||||
|
<link rel="stylesheet" type="text/css" href="/static/css/main.css"> |
||||||
|
<script defer src="/static/js/ritherdon-archive.js"></script> |
||||||
|
</head> |
||||||
|
<body> |
||||||
|
{% block content %} {% endblock %} |
||||||
|
</body> |
||||||
|
</html> |
@ -0,0 +1,175 @@ |
|||||||
|
{% extends "base.html" %} |
||||||
|
|
||||||
|
{% block content %} |
||||||
|
|
||||||
|
<!-- this comes straight from a Bulma demo. --> |
||||||
|
|
||||||
|
|
||||||
|
<section class="hero is-info welcome is-small"> |
||||||
|
<div class="hero-body"> |
||||||
|
<div class="container"> |
||||||
|
<h1 class="title"> |
||||||
|
Hello, Admin. |
||||||
|
</h1> |
||||||
|
<h2 class="subtitle"> |
||||||
|
I hope you are having a great day! |
||||||
|
</h2> |
||||||
|
</div> |
||||||
|
</div> |
||||||
|
</section> |
||||||
|
<section class="info-tiles"> |
||||||
|
<div class="tile is-ancestor has-text-centered"> |
||||||
|
<div class="tile is-parent"> |
||||||
|
<article class="tile is-child box"> |
||||||
|
<p class="title"> {{ data.nb-titles }} </p> |
||||||
|
<p class="subtitle"> Nombre de titres </p> |
||||||
|
</article> |
||||||
|
</div> |
||||||
|
<div class="tile is-parent"> |
||||||
|
<article class="tile is-child box"> |
||||||
|
<p class="title"> {{ data.nb-books }} </p> |
||||||
|
<p class="subtitle"> Nombre de livres </p> |
||||||
|
</article> |
||||||
|
</div> |
||||||
|
<div class="tile is-parent"> |
||||||
|
<article class="tile is-child box"> |
||||||
|
<p class="title"> {{ data.nb-titles-negative }} </p> |
||||||
|
<p class="subtitle"> Titres en stock négatif </p> |
||||||
|
</article> |
||||||
|
</div> |
||||||
|
<div class="tile is-parent"> |
||||||
|
<article class="tile is-child box"> |
||||||
|
<p class="title">19</p> |
||||||
|
<p class="subtitle">Exceptions</p> |
||||||
|
</article> |
||||||
|
</div> |
||||||
|
</div> |
||||||
|
</section> |
||||||
|
<div class="columns"> |
||||||
|
<div class="column is-6"> |
||||||
|
<div class="card events-card"> |
||||||
|
<header class="card-header"> |
||||||
|
<p class="card-header-title"> |
||||||
|
Events |
||||||
|
</p> |
||||||
|
<a href="#" class="card-header-icon" aria-label="more options"> |
||||||
|
<span class="icon"> |
||||||
|
<i class="fa fa-angle-down" aria-hidden="true"></i> |
||||||
|
</span> |
||||||
|
</a> |
||||||
|
</header> |
||||||
|
<div class="card-table"> |
||||||
|
<div class="content"> |
||||||
|
<table class="table is-fullwidth is-striped"> |
||||||
|
<tbody> |
||||||
|
<tr> |
||||||
|
<td width="5%"><i class="fa fa-bell-o"></i></td> |
||||||
|
<td>Lorum ipsum dolem aire</td> |
||||||
|
<td class="level-right"><a class="button is-small is-primary" href="#">Action</a></td> |
||||||
|
</tr> |
||||||
|
<tr> |
||||||
|
<td width="5%"><i class="fa fa-bell-o"></i></td> |
||||||
|
<td>Lorum ipsum dolem aire</td> |
||||||
|
<td class="level-right"><a class="button is-small is-primary" href="#">Action</a></td> |
||||||
|
</tr> |
||||||
|
<tr> |
||||||
|
<td width="5%"><i class="fa fa-bell-o"></i></td> |
||||||
|
<td>Lorum ipsum dolem aire</td> |
||||||
|
<td class="level-right"><a class="button is-small is-primary" href="#">Action</a></td> |
||||||
|
</tr> |
||||||
|
<tr> |
||||||
|
<td width="5%"><i class="fa fa-bell-o"></i></td> |
||||||
|
<td>Lorum ipsum dolem aire</td> |
||||||
|
<td class="level-right"><a class="button is-small is-primary" href="#">Action</a></td> |
||||||
|
</tr> |
||||||
|
<tr> |
||||||
|
<td width="5%"><i class="fa fa-bell-o"></i></td> |
||||||
|
<td>Lorum ipsum dolem aire</td> |
||||||
|
<td class="level-right"><a class="button is-small is-primary" href="#">Action</a></td> |
||||||
|
</tr> |
||||||
|
<tr> |
||||||
|
<td width="5%"><i class="fa fa-bell-o"></i></td> |
||||||
|
<td>Lorum ipsum dolem aire</td> |
||||||
|
<td class="level-right"><a class="button is-small is-primary" href="#">Action</a></td> |
||||||
|
</tr> |
||||||
|
<tr> |
||||||
|
<td width="5%"><i class="fa fa-bell-o"></i></td> |
||||||
|
<td>Lorum ipsum dolem aire</td> |
||||||
|
<td class="level-right"><a class="button is-small is-primary" href="#">Action</a></td> |
||||||
|
</tr> |
||||||
|
<tr> |
||||||
|
<td width="5%"><i class="fa fa-bell-o"></i></td> |
||||||
|
<td>Lorum ipsum dolem aire</td> |
||||||
|
<td class="level-right"><a class="button is-small is-primary" href="#">Action</a></td> |
||||||
|
</tr> |
||||||
|
<tr> |
||||||
|
<td width="5%"><i class="fa fa-bell-o"></i></td> |
||||||
|
<td>Lorum ipsum dolem aire</td> |
||||||
|
<td class="level-right"><a class="button is-small is-primary" href="#">Action</a></td> |
||||||
|
</tr> |
||||||
|
</tbody> |
||||||
|
</table> |
||||||
|
</div> |
||||||
|
</div> |
||||||
|
<footer class="card-footer"> |
||||||
|
<a href="#" class="card-footer-item">View All</a> |
||||||
|
</footer> |
||||||
|
</div> |
||||||
|
</div> |
||||||
|
<div class="column is-6"> |
||||||
|
<div class="card"> |
||||||
|
<header class="card-header"> |
||||||
|
<p class="card-header-title"> |
||||||
|
Inventory Search |
||||||
|
</p> |
||||||
|
<a href="#" class="card-header-icon" aria-label="more options"> |
||||||
|
<span class="icon"> |
||||||
|
<i class="fa fa-angle-down" aria-hidden="true"></i> |
||||||
|
</span> |
||||||
|
</a> |
||||||
|
</header> |
||||||
|
<div class="card-content"> |
||||||
|
<div class="content"> |
||||||
|
<div class="control has-icons-left has-icons-right"> |
||||||
|
<input class="input is-large" type="text" placeholder=""> |
||||||
|
<span class="icon is-medium is-left"> |
||||||
|
<i class="fa fa-search"></i> |
||||||
|
</span> |
||||||
|
<span class="icon is-medium is-right"> |
||||||
|
<i class="fa fa-check"></i> |
||||||
|
</span> |
||||||
|
</div> |
||||||
|
</div> |
||||||
|
</div> |
||||||
|
</div> |
||||||
|
<div class="card"> |
||||||
|
<header class="card-header"> |
||||||
|
<p class="card-header-title"> |
||||||
|
User Search |
||||||
|
</p> |
||||||
|
<a href="#" class="card-header-icon" aria-label="more options"> |
||||||
|
<span class="icon"> |
||||||
|
<i class="fa fa-angle-down" aria-hidden="true"></i> |
||||||
|
</span> |
||||||
|
</a> |
||||||
|
</header> |
||||||
|
<div class="card-content"> |
||||||
|
<div class="content"> |
||||||
|
<div class="control has-icons-left has-icons-right"> |
||||||
|
<input class="input is-large" type="text" placeholder=""> |
||||||
|
<span class="icon is-medium is-left"> |
||||||
|
<i class="fa fa-search"></i> |
||||||
|
</span> |
||||||
|
<span class="icon is-medium is-right"> |
||||||
|
<i class="fa fa-check"></i> |
||||||
|
</span> |
||||||
|
</div> |
||||||
|
</div> |
||||||
|
</div> |
||||||
|
</div> |
||||||
|
</div> |
||||||
|
</div> |
||||||
|
|
||||||
|
{% endblock %} |
||||||
|
|
||||||
|
|
@ -0,0 +1,6 @@ |
|||||||
|
{% extends "base.html" %} |
||||||
|
|
||||||
|
{% block content %} |
||||||
|
<h1>Index</h1> |
||||||
|
|
||||||
|
{% end block %} |
@ -0,0 +1,16 @@ |
|||||||
|
{% extends "base.html" %} |
||||||
|
{% block title %}Nicola Ellis & Ritherdon Archive: Log-In{% endblock %} |
||||||
|
{% block content %} |
||||||
|
<h2>Login</h2> |
||||||
|
<div> |
||||||
|
<formaction="/login" method="post"> |
||||||
|
<input type="hidden" name="AUTHENTICITY-TOKEN" value="{{token}}"> |
||||||
|
<input type="hidden" name="METHOD" value="login"> |
||||||
|
<label>Username</label> |
||||||
|
<input required type="text" name="USERNAME"> |
||||||
|
<label>password</label> |
||||||
|
<input required type="password" name="PASSWORD"> |
||||||
|
<input type="submit" value="Log-in"> |
||||||
|
</form> |
||||||
|
</div> |
||||||
|
{% endblock %} |
@ -0,0 +1,9 @@ |
|||||||
|
(in-package :ritherdon-archive/utils) |
||||||
|
|
||||||
|
|
||||||
|
(defun format-date (date) |
||||||
|
"Format the given date with the default date format (yyyy-mm-dd). Return a string." |
||||||
|
(local-time:format-timestring nil date :format +date-y-m-d+)) |
||||||
|
|
||||||
|
(defun asciify (string) |
||||||
|
(str:downcase (slug:asciify string))) |
@ -0,0 +1,135 @@ |
|||||||
|
(in-package :ritherdon-archive/web) |
||||||
|
|
||||||
|
(defvar *server* nil |
||||||
|
"Current instance of easy-acceptor.") |
||||||
|
|
||||||
|
(defparameter *port* 4242) |
||||||
|
|
||||||
|
;;; |
||||||
|
;;; Djula filters. |
||||||
|
;;; |
||||||
|
|
||||||
|
(djula:def-filter :price (val) |
||||||
|
(format nil "~,2F" val)) |
||||||
|
|
||||||
|
;;; |
||||||
|
;;; Load templates. |
||||||
|
;;; |
||||||
|
(djula:add-template-directory |
||||||
|
(asdf:system-relative-pathname "ritherdon-archive" "src/templates/")) |
||||||
|
|
||||||
|
(defparameter +base.html+ (djula:compile-template* "base.html")) |
||||||
|
(defparameter +404.html+ (djula:compile-template* "404.html")) |
||||||
|
|
||||||
|
;; Front-End Templates |
||||||
|
(defparameter +index.html+ (djula:compile-template* "home.html")) |
||||||
|
(defparameter +archive.html+ (djula:compile-template* "archive.html")) |
||||||
|
(defparameter +about.html+ (djula:compile-template* "about.html")) |
||||||
|
(defparameter +login.html+ (djula:compile-template* "login.html")) |
||||||
|
|
||||||
|
;; Back-End Templates |
||||||
|
(defparameter +dashboard.html+ (djula:compile-template* "dashboard.html")) |
||||||
|
|
||||||
|
;;; |
||||||
|
;;; Serve static assets |
||||||
|
;;; |
||||||
|
(defparameter *default-static-directory* "src/static/" |
||||||
|
"The directory where to serve static assets from (STRING). If it starts with a slash, it is an absolute directory. Otherwise, it will be a subdirectory of where the system :abstock is installed. |
||||||
|
Static assets are reachable under the /static/ prefix.") |
||||||
|
|
||||||
|
(defun serve-static-assets () |
||||||
|
(push (hunchentoot:create-folder-dispatcher-and-handler |
||||||
|
"/static/" (merge-pathnames *default-static-directory* |
||||||
|
(asdf:system-source-directory :ritherdon-archive))) |
||||||
|
hunchentoot:*dispatch-table*)) |
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
||||||
|
;;; Routes. |
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
||||||
|
|
||||||
|
;; Root route. |
||||||
|
(defroute home-route ("/") () |
||||||
|
(djula:render-template* +dashboard.html+ nil |
||||||
|
:route "/")) |
||||||
|
|
||||||
|
(defroute login ("/login") () |
||||||
|
(djula:render-template* +login.html+ nil)) |
||||||
|
|
||||||
|
(defroute card-page ("/product/:slug") |
||||||
|
(&get raw) |
||||||
|
"Show a product. |
||||||
|
|
||||||
|
Dev helper: if the URL parameter RAW is \"t\" (the string), then display the card object literally (with describe)." |
||||||
|
;; The product URL is of the form: /xyz-product-title where xyz is its pk. |
||||||
|
(let* ((product-id (ignore-errors |
||||||
|
(parse-integer (first (str:split "-" slug))))) |
||||||
|
(product (when product-id |
||||||
|
(models:find-by :id product-id)))) |
||||||
|
(cond |
||||||
|
((null product-id) |
||||||
|
(render-template* +404.html+ nil)) |
||||||
|
(product |
||||||
|
(render-template* +product-stock.html+ nil |
||||||
|
:messages nil |
||||||
|
:route "/product" |
||||||
|
:product product |
||||||
|
:raw raw)) |
||||||
|
(t |
||||||
|
(render-template* +404.html+ nil))))) |
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
||||||
|
;; Start-up functions. |
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
||||||
|
|
||||||
|
(defun find-config () |
||||||
|
(cond |
||||||
|
((uiop:file-exists-p "config.lisp") |
||||||
|
"config.lisp") |
||||||
|
(t |
||||||
|
nil))) |
||||||
|
|
||||||
|
(defun load-config () |
||||||
|
"Load `config.lisp', situated at the project's root." |
||||||
|
(let ((file (find-config))) |
||||||
|
(if file |
||||||
|
;; One case of failure: a symbolic link exists, but |
||||||
|
;; the target file doesn't. |
||||||
|
(progn |
||||||
|
(uiop:format! t "Loading config file ~a…~&" file) |
||||||
|
(load (uiop:native-namestring file))) |
||||||
|
(format t "... no config file found.~&")))) |
||||||
|
|
||||||
|
(defun start-app (&key (port *port*) (load-config-p nil)) |
||||||
|
"Start the Hunchentoot web server on port PORT (defaults to `*PORT*'), serve static assets. |
||||||
|
|
||||||
|
If LOAD-CONFIG-P is non nil, load the config file (this is normally done in the main function of run.lisp before)." |
||||||
|
;; You can use the find-port library to find an available port. |
||||||
|
|
||||||
|
;; Load the config.lisp init file. |
||||||
|
(if load-config-p |
||||||
|
(load-config) |
||||||
|
(uiop:format! t "Skipping config file.~&")) |
||||||
|
|
||||||
|
;; Set up the DB. |
||||||
|
(models:connect) |
||||||
|
|
||||||
|
;; Start the server. |
||||||
|
(uiop:format! t "Starting Hunchentoot on port ~a…~&" port) |
||||||
|
(setf *server* (make-instance 'easy-routes:easy-routes-acceptor :port port)) |
||||||
|
(hunchentoot:start *server*) |
||||||
|
(serve-static-assets) |
||||||
|
(uiop:format! t "~&Application started on port ~a.~&" port)) |
||||||
|
|
||||||
|
(defun stop-app () |
||||||
|
;; disconnect db ? |
||||||
|
(hunchentoot:stop *server*)) |
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
||||||
|
;; Authentication functions. |
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
||||||
|
|
||||||
|
(defun current-user () |
||||||
|
(hunchentoot:session-value :user)) |
||||||
|
|
||||||
|
(defun logout () |
||||||
|
(setf (hunchentoot:session-value :user) nil)) |
@ -0,0 +1,8 @@ |
|||||||
|
(in-package :asdf-user) |
||||||
|
(defpackage :ritherdon-archive-tests |
||||||
|
(:use :common-lisp |
||||||
|
:parachute |
||||||
|
:ritherdon-archive)) |
||||||
|
|
||||||
|
|
||||||
|
(in-package :ritherdon-archive-tests) |
@ -0,0 +1,16 @@ |
|||||||
|
(in-package :ritherdon-archive-tests) |
||||||
|
|
||||||
|
#| parachute: https://shinmera.github.io/parachute/ |
||||||
|
================================================================================ |
||||||
|
Use the URL to access the documentation for parachute. |
||||||
|
|# |
||||||
|
|
||||||
|
;; This was an example taken from the doc's for parachute. I'm going to keep it |
||||||
|
;; here as a reference until I get comfortable with parachute. |
||||||
|
(define-test reference-tests |
||||||
|
(of-type integer 5) |
||||||
|
(true (numberp 2/3)) |
||||||
|
(false (numberp :keyword)) |
||||||
|
(is-values (values 0 "1") |
||||||
|
(= 0) |
||||||
|
(equal "1"))) |
Loading…
Reference in new issue