diff --git a/hunchentoot-example/Makefile b/hunchentoot-example/Makefile new file mode 100644 index 0000000..74a2597 --- /dev/null +++ b/hunchentoot-example/Makefile @@ -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 diff --git a/hunchentoot-example/README.md b/hunchentoot-example/README.md new file mode 100644 index 0000000..50ca3c8 --- /dev/null +++ b/hunchentoot-example/README.md @@ -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 diff --git a/hunchentoot-example/README.org b/hunchentoot-example/README.org new file mode 100644 index 0000000..72a823f --- /dev/null +++ b/hunchentoot-example/README.org @@ -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). diff --git a/hunchentoot-example/bin/libz.so.1.2.11 b/hunchentoot-example/bin/libz.so.1.2.11 new file mode 100644 index 0000000..22fe000 Binary files /dev/null and b/hunchentoot-example/bin/libz.so.1.2.11 differ diff --git a/hunchentoot-example/bin/ritherdon-archive b/hunchentoot-example/bin/ritherdon-archive new file mode 100755 index 0000000..52febf4 Binary files /dev/null and b/hunchentoot-example/bin/ritherdon-archive differ diff --git a/hunchentoot-example/config-example.lisp b/hunchentoot-example/config-example.lisp new file mode 100644 index 0000000..f64f408 --- /dev/null +++ b/hunchentoot-example/config-example.lisp @@ -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) diff --git a/hunchentoot-example/ritherdon-archive-tests.asd b/hunchentoot-example/ritherdon-archive-tests.asd new file mode 100644 index 0000000..5c89eb5 --- /dev/null +++ b/hunchentoot-example/ritherdon-archive-tests.asd @@ -0,0 +1,18 @@ +(in-package :asdf-user) +(defsystem "ritherdon-archive-tests" + :description "Test suite for the ritherdon-archive system" + :author "Craig Oates " + :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)) + ) diff --git a/hunchentoot-example/ritherdon-archive.asd b/hunchentoot-example/ritherdon-archive.asd new file mode 100644 index 0000000..945e2e7 --- /dev/null +++ b/hunchentoot-example/ritherdon-archive.asd @@ -0,0 +1,89 @@ +(in-package :asdf-user) + +(defsystem "ritherdon-archive" + :author "Craig Oates " + :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)) diff --git a/hunchentoot-example/roswell/README.md b/hunchentoot-example/roswell/README.md new file mode 100644 index 0000000..768d434 --- /dev/null +++ b/hunchentoot-example/roswell/README.md @@ -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 \ No newline at end of file diff --git a/hunchentoot-example/roswell/ritherdon-archive.ros b/hunchentoot-example/roswell/ritherdon-archive.ros new file mode 100644 index 0000000..62c8e1e --- /dev/null +++ b/hunchentoot-example/roswell/ritherdon-archive.ros @@ -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))) diff --git a/hunchentoot-example/run-tests.lisp b/hunchentoot-example/run-tests.lisp new file mode 100644 index 0000000..03d455c --- /dev/null +++ b/hunchentoot-example/run-tests.lisp @@ -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)) diff --git a/hunchentoot-example/run.lisp b/hunchentoot-example/run.lisp new file mode 100644 index 0000000..dbfb21d --- /dev/null +++ b/hunchentoot-example/run.lisp @@ -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))) diff --git a/hunchentoot-example/scripts/create-user.sh b/hunchentoot-example/scripts/create-user.sh new file mode 100755 index 0000000..c0efaee --- /dev/null +++ b/hunchentoot-example/scripts/create-user.sh @@ -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 diff --git a/hunchentoot-example/src/database.lisp b/hunchentoot-example/src/database.lisp new file mode 100644 index 0000000..a90962e --- /dev/null +++ b/hunchentoot-example/src/database.lisp @@ -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)) diff --git a/hunchentoot-example/src/models/models.lisp b/hunchentoot-example/src/models/models.lisp new file mode 100644 index 0000000..e7f720b --- /dev/null +++ b/hunchentoot-example/src/models/models.lisp @@ -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))) diff --git a/hunchentoot-example/src/models/user.lisp b/hunchentoot-example/src/models/user.lisp new file mode 100644 index 0000000..d531693 --- /dev/null +++ b/hunchentoot-example/src/models/user.lisp @@ -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..")) diff --git a/hunchentoot-example/src/packages.lisp b/hunchentoot-example/src/packages.lisp new file mode 100644 index 0000000..0c1859d --- /dev/null +++ b/hunchentoot-example/src/packages.lisp @@ -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))) diff --git a/hunchentoot-example/src/ritherdon-archive.lisp b/hunchentoot-example/src/ritherdon-archive.lisp new file mode 100644 index 0000000..cff8488 --- /dev/null +++ b/hunchentoot-example/src/ritherdon-archive.lisp @@ -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)))) diff --git a/hunchentoot-example/src/static/css/main.css b/hunchentoot-example/src/static/css/main.css new file mode 100644 index 0000000..8d1c8b6 --- /dev/null +++ b/hunchentoot-example/src/static/css/main.css @@ -0,0 +1 @@ + diff --git a/hunchentoot-example/src/static/js/ritherdon-archive.js b/hunchentoot-example/src/static/js/ritherdon-archive.js new file mode 100644 index 0000000..897d2f8 --- /dev/null +++ b/hunchentoot-example/src/static/js/ritherdon-archive.js @@ -0,0 +1,2 @@ + +console.log("Hello ritherdon-archive!"); diff --git a/hunchentoot-example/src/templates/404.html b/hunchentoot-example/src/templates/404.html new file mode 100644 index 0000000..59a93fc --- /dev/null +++ b/hunchentoot-example/src/templates/404.html @@ -0,0 +1 @@ +

404: Web Page Not Found

diff --git a/hunchentoot-example/src/templates/about.html b/hunchentoot-example/src/templates/about.html new file mode 100644 index 0000000..82f1a7c --- /dev/null +++ b/hunchentoot-example/src/templates/about.html @@ -0,0 +1,5 @@ +{% extends "base.html" %} + +{% block content %} +

About

+{% end block %} diff --git a/hunchentoot-example/src/templates/archive.html b/hunchentoot-example/src/templates/archive.html new file mode 100644 index 0000000..1bbd79f --- /dev/null +++ b/hunchentoot-example/src/templates/archive.html @@ -0,0 +1,6 @@ +{% extends "base.html" %} + +{% block content %} +

Archive

+ +{% end block %} diff --git a/hunchentoot-example/src/templates/base.html b/hunchentoot-example/src/templates/base.html new file mode 100644 index 0000000..b3a9fd6 --- /dev/null +++ b/hunchentoot-example/src/templates/base.html @@ -0,0 +1,15 @@ + + + + + {% block title %}{% endblock %} + + + + + + + + {% block content %} {% endblock %} + + diff --git a/hunchentoot-example/src/templates/dashboard.html b/hunchentoot-example/src/templates/dashboard.html new file mode 100644 index 0000000..b1bb783 --- /dev/null +++ b/hunchentoot-example/src/templates/dashboard.html @@ -0,0 +1,175 @@ +{% extends "base.html" %} + +{% block content %} + + + + +
+
+
+

+ Hello, Admin. +

+

+ I hope you are having a great day! +

+
+
+
+
+
+
+
+

{{ data.nb-titles }}

+

Nombre de titres

+
+
+
+
+

{{ data.nb-books }}

+

Nombre de livres

+
+
+
+
+

{{ data.nb-titles-negative }}

+

Titres en stock négatif

+
+
+
+
+

19

+

Exceptions

+
+
+
+
+
+
+
+
+

+ Events +

+ + + + + +
+
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Lorum ipsum dolem aireAction
Lorum ipsum dolem aireAction
Lorum ipsum dolem aireAction
Lorum ipsum dolem aireAction
Lorum ipsum dolem aireAction
Lorum ipsum dolem aireAction
Lorum ipsum dolem aireAction
Lorum ipsum dolem aireAction
Lorum ipsum dolem aireAction
+
+
+ +
+
+
+
+
+

+ Inventory Search +

+ + + + + +
+
+
+
+ + + + + + + +
+
+
+
+
+
+

+ User Search +

+ + + + + +
+
+
+
+ + + + + + + +
+
+
+
+
+
+ +{% endblock %} + + diff --git a/hunchentoot-example/src/templates/home.html b/hunchentoot-example/src/templates/home.html new file mode 100644 index 0000000..91d3034 --- /dev/null +++ b/hunchentoot-example/src/templates/home.html @@ -0,0 +1,6 @@ +{% extends "base.html" %} + +{% block content %} +

Index

+ +{% end block %} diff --git a/hunchentoot-example/src/templates/login.html b/hunchentoot-example/src/templates/login.html new file mode 100644 index 0000000..4a46ec3 --- /dev/null +++ b/hunchentoot-example/src/templates/login.html @@ -0,0 +1,16 @@ +{% extends "base.html" %} +{% block title %}Nicola Ellis & Ritherdon Archive: Log-In{% endblock %} +{% block content %} +

Login

+
+ + + + + + + + + +
+{% endblock %} diff --git a/hunchentoot-example/src/utils.lisp b/hunchentoot-example/src/utils.lisp new file mode 100644 index 0000000..ae2f421 --- /dev/null +++ b/hunchentoot-example/src/utils.lisp @@ -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))) diff --git a/hunchentoot-example/src/web.lisp b/hunchentoot-example/src/web.lisp new file mode 100644 index 0000000..255d806 --- /dev/null +++ b/hunchentoot-example/src/web.lisp @@ -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)) diff --git a/hunchentoot-example/tests/packages.lisp b/hunchentoot-example/tests/packages.lisp new file mode 100644 index 0000000..67a679e --- /dev/null +++ b/hunchentoot-example/tests/packages.lisp @@ -0,0 +1,8 @@ +(in-package :asdf-user) +(defpackage :ritherdon-archive-tests + (:use :common-lisp + :parachute + :ritherdon-archive)) + + +(in-package :ritherdon-archive-tests) diff --git a/hunchentoot-example/tests/test-ritherdon-archive.lisp b/hunchentoot-example/tests/test-ritherdon-archive.lisp new file mode 100644 index 0000000..e249fe7 --- /dev/null +++ b/hunchentoot-example/tests/test-ritherdon-archive.lisp @@ -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")))