Craig Oates
2 years ago
20 changed files with 772 additions and 224 deletions
@ -0,0 +1,12 @@
|
||||
# ritherdon-archive |
||||
|
||||
|
||||
|
||||
## Usage |
||||
|
||||
## Installation |
||||
|
||||
# License |
||||
|
||||
Licensed under the MIT License. |
||||
|
@ -0,0 +1,46 @@
|
||||
(ql:quickload :ritherdon-archive) |
||||
|
||||
(defpackage ritherdon-archive.app |
||||
(:use :cl) |
||||
(:import-from :lack.builder |
||||
:builder) |
||||
(:import-from :ppcre |
||||
:scan |
||||
:regex-replace) |
||||
(:import-from :ritherdon-archive.web |
||||
:*web*) |
||||
(:import-from :ritherdon-archive.config |
||||
:config |
||||
:productionp |
||||
:*static-directory*)) |
||||
(in-package :ritherdon-archive.app) |
||||
|
||||
(funcall clack-errors:*clack-error-middleware* |
||||
;; The funcall line above is added as part of the |
||||
;; clack-errors set-up. Usually, the '(builder' line is the |
||||
;; start of this block. |
||||
(builder |
||||
(:static |
||||
:path (lambda (path) |
||||
(if (ppcre:scan "^(?:/images/|/css/|/js/|/robot\\.txt$|/favicon\\.ico$)" path) |
||||
path |
||||
nil)) |
||||
:root *static-directory*) |
||||
(if (productionp) |
||||
nil |
||||
:accesslog) |
||||
(if (getf (config) :error-log) |
||||
`(:backtrace |
||||
:output ,(getf (config) :error-log)) |
||||
nil) |
||||
:session |
||||
(if (productionp) |
||||
nil |
||||
(lambda (app) |
||||
(lambda (env) |
||||
(let ((datafly:*trace-sql* t)) |
||||
(funcall app env))))) |
||||
*web*) |
||||
:debug (if (ritherdon-archive.config:productionp) |
||||
nil |
||||
t)) ; Added as part of clack-error-middleware. |
@ -1,89 +1,78 @@
|
||||
(in-package :asdf-user) |
||||
|
||||
(defsystem "ritherdon-archive" |
||||
:author "Craig Oates <craig@craigoates.net>" |
||||
:version "0.0.0" |
||||
:version "0.1.0" |
||||
:author "Craig Oates" |
||||
: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)) |
||||
:depends-on ("clack" |
||||
"lack" |
||||
"caveman2" |
||||
"envy" |
||||
"cl-ppcre" |
||||
"uiop" |
||||
|
||||
;; for @route annotation |
||||
"cl-syntax-annot" |
||||
|
||||
;; HTML Template |
||||
"djula" |
||||
|
||||
;; for DB |
||||
"datafly" |
||||
"sxql" |
||||
|
||||
;;; Additional Packages (after initial Caveman set-up) |
||||
#:clack-errors ; Error report (HTML/template views) |
||||
#:mito ; Database ORM |
||||
#:mito-auth ; Auth. with password hashing and salting |
||||
#:osicat ; Environment variables (dev/prod.) |
||||
#:ratify ; Utilites |
||||
#:trivia ; Pattern matching |
||||
#:plump ; Parsing (HTML/XML) |
||||
#:dexador ; HTTP client |
||||
#:clss ; DOM tree search based on CSS selectors |
||||
#:3bmd ; Markdown |
||||
#:cl-json ; JSON Parsing |
||||
#:cl-who ; Markup |
||||
#:sqlite ; Sqlite database ORM |
||||
#:hermetic ; Authentication |
||||
#:cl-fad ; Files and directories |
||||
#:xml-emitter ; XML Emitter for RSS Feed |
||||
#:serapeum ; Pagination |
||||
#:cl-slug ; Asciify and slugify strings |
||||
#:str ; String manipulation (easier than built-in) |
||||
) |
||||
:pathname "src/" |
||||
;; :serial t |
||||
;; I replaced the default module approach to the serial file load |
||||
;; approach because it was easier organise additional source code |
||||
;; files into sub-directories, all within /src. I kept getting |
||||
;; errors when trying to load the system when using additional |
||||
;; modules or using the :depends-on properties. I have kept the |
||||
;; original module configuration below for reference/until you feel |
||||
;; comfortable enought to delete it. |
||||
:components (;; Caveman Files |
||||
(:file "config") |
||||
(:file "main") |
||||
(:file "db") |
||||
(:file "view") |
||||
;; CO-Web Specific Files |
||||
(:file "app-constants") |
||||
(:file "utils") |
||||
(:file "models/user") |
||||
(:file "authentication") |
||||
;; Caveman Files |
||||
(:file "web")) |
||||
|
||||
:description "The Nicola Ellis & Ritherdon Archive." |
||||
:in-order-to ((test-op (test-op "ritherdon-archive/tests")))) |
||||
|
||||
|
||||
(defsystem #:ritherdon-archive/tests |
||||
:author "Craig Oates" |
||||
:license "MIT" |
||||
:depends-on (#:ritherdon-archive |
||||
#:parachute) |
||||
:components ((:module "tests" |
||||
:components |
||||
((:file "tests")))) |
||||
:description "Test system for ritherdon-archive." |
||||
:perform (test-op (op s) (symbol-call :parachute :test :tests))) |
||||
|
@ -0,0 +1,38 @@
|
||||
(defpackage #:app-constants |
||||
(:use #:cl) |
||||
(:export #:+false+ |
||||
#:+true+)) |
||||
|
||||
(in-package #:app-constants) |
||||
|
||||
#| Switched to `DEFINE-CONSTANT' from `DEFCONSTANT'. |
||||
================================================================================ |
||||
Because this website uses Steel Bank Common Lisp (SBCL), I need to go through a |
||||
cycle of confirming changes to the constant values even though they have not |
||||
changed. This behaviour is explained in the SBCL Manual 2.1.3 2021-03 (Section |
||||
2.3.4 Defining Constants, page 5 (printed) page 13 (PDF)). The key part of the |
||||
section is, |
||||
'ANSI says that doing `DEFCONSTANT' of the same symbol more than once is |
||||
undefined unless the new value is eql to the old value.' |
||||
http://www.sbcl.org/manual/#Defining-Constants (this URL should provide the |
||||
latest information of the subject). |
||||
A workaround, provided by the SBCL Manual is to use the `DEFINE-CONSTANT' macro |
||||
instead of `DEFCONST'. By doing this, I can use Quickload to reload the code |
||||
(after a big change for example) and not have to repeat the cycle of 'updating' |
||||
the constants when they have not changed. |
||||
|# |
||||
(defmacro define-constant (name value &optional doc) |
||||
`(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value) |
||||
,@(when doc (list doc)))) |
||||
|
||||
#| SQLite does not have Boolean value types. |
||||
================================================================================ |
||||
At the time of writing (February 2022), the website uses SQLite as its |
||||
database. So, I have made these constants to reduce hard-coded `1' |
||||
and/or `0' values when `TRUE' and `NIL'/`FALSE' values are want is |
||||
meant (in the code-base). |
||||
|# |
||||
(define-constant +false+ 0 |
||||
"An integer representing 'false' (for SQLite mostly).") |
||||
(define-constant +true+ 1 |
||||
"An integer representing 'true' (for SQLite mostly.") |
@ -0,0 +1,87 @@
|
||||
(defpackage #:authentication |
||||
(:use #:cl |
||||
#:hermetic |
||||
#:sxql |
||||
;; #:datafly |
||||
#:ningle |
||||
#:mito |
||||
#:app-constants |
||||
#:user) |
||||
(:import-from #:ritherdon-archive.db |
||||
#:connection-settings |
||||
#:db |
||||
#:with-connection) |
||||
(:export #:csrf-token |
||||
#:get-user-roles |
||||
#:request-params |
||||
#:get-current-user |
||||
#:get-user-id)) |
||||
|
||||
(in-package #:authentication) |
||||
|
||||
(defun csrf-token () |
||||
"Cross-Site Request Forgery (CSRF) token." |
||||
(cdr (assoc "lack.session" |
||||
(lack.request:request-cookies ningle:*request*) |
||||
:test #'string=))) |
||||
|
||||
(hermetic:setup |
||||
;; #' is needed. (hermetic:roles) generates infinite-loop when called |
||||
;; otherwise -- 'roles' called in other parts of code-base. |
||||
;; #' is shorthand for the 'function' operator (returns the function |
||||
;; object associated with the name of the function which is supplied |
||||
;; as an argument. Keep forgetting that. |
||||
:user-p #'(lambda (username) |
||||
(with-connection (db) |
||||
(mito:find-dao 'user :username username))) |
||||
:user-pass #'(lambda (username) |
||||
(user::password-of |
||||
(with-connection (db) |
||||
(mito:find-dao 'user :username username)))) |
||||
:user-roles #'(lambda (username) |
||||
(cons :logged-in |
||||
(let ((user (with-connection (db) |
||||
(mito:find-dao |
||||
'user :username username)))) |
||||
(and user |
||||
(= (user::is-administrator-p user) app-constants:+true+) |
||||
'(:administrator))))) |
||||
:Session ningle:*session* |
||||
:denied (constantly '(400 (:content-type "text/plain") ("Authentication denied")))) |
||||
|
||||
(defun get-current-user() |
||||
"Returns the currently logged in user from the browser session." |
||||
(with-connection (db) |
||||
(mito:find-dao 'user |
||||
:id (gethash :id ningle:*session*)))) |
||||
|
||||
(defun get-user-data () |
||||
"Get session csrf-token, current (logged-in) user and there roles." |
||||
(let ((databag (list :token (csrf-token)))) |
||||
(if (hermetic::logged-in-p) |
||||
(append databag |
||||
(list |
||||
:roles (get-user-roles) |
||||
:user (get-current-user)))))) |
||||
|
||||
(defun get-user-id (username) |
||||
"Returns the Id. number of the specified `USERNAME' in the database." |
||||
(with-connection (db) |
||||
(mito:object-id |
||||
(mito:find-dao 'user :username username)))) |
||||
|
||||
(defun request-params (request) |
||||
"Loops through the HTTP `REQUEST' and creates a key-value pairing." |
||||
(loop :for (key . value) :in request |
||||
:collect (let ((*package* (find-package :keyword))) |
||||
(read-from-string key)) |
||||
:collect value)) |
||||
|
||||
(defun get-user-roles() |
||||
"Returns a list of roles the current user has assigned to them. |
||||
This is mostly to check if the user is logged-in or has administration |
||||
privileges. You can then create if-blocks in the HTML templates and |
||||
control what the user can and cannot see or do." |
||||
(loop :for role :in (hermetic:roles) |
||||
:collect role |
||||
:collect t)) |
@ -0,0 +1,66 @@
|
||||
(in-package #:cl-user) |
||||
(defpackage #:ritherdon-archive.config |
||||
(:use #:cl) |
||||
(:import-from #:envy |
||||
#:config-env-var |
||||
#:defconfig) |
||||
(:export #:config |
||||
#:*application-root* |
||||
#:*static-directory* |
||||
#:*template-directory* |
||||
#:appenv |
||||
#:developmentp |
||||
#:productionp |
||||
#:testp |
||||
#:database-name)) |
||||
(in-package #:ritherdon-archive.config) |
||||
|
||||
(setf (config-env-var) "APP_ENV") |
||||
|
||||
(defparameter *application-root* (asdf:system-source-directory :ritherdon-archive)) |
||||
(defparameter *static-directory* (merge-pathnames #P"static/" *application-root*)) |
||||
(defparameter *template-directory* (merge-pathnames #P"templates/" *application-root*)) |
||||
|
||||
(defconfig :common |
||||
`(:application-root ,(asdf:component-pathname (asdf:find-system :ritherdon-archive)))) |
||||
|
||||
(defconfig |development| |
||||
`(:debug T |
||||
:databases |
||||
((:maindb :sqlite3 |
||||
:database-name ,(merge-pathnames #P"db/nera-dev.db" |
||||
*application-root*))))) |
||||
|
||||
(defconfig |production| |
||||
`(:debug nil |
||||
:databases |
||||
((:maindb :sqlite3 |
||||
:database-name ,(merge-pathnames #P"db/nera-prod.db" |
||||
*application-root*))))) |
||||
|
||||
(defconfig |staging| |
||||
`(:debug T |
||||
,@|production|)) |
||||
|
||||
(defun config (&optional key) |
||||
(envy:config #.(package-name *package*) key)) |
||||
|
||||
(defun appenv () |
||||
(uiop:getenv (config-env-var #.(package-name *package*)))) |
||||
|
||||
(defun developmentp () |
||||
(string= (appenv) "development")) |
||||
|
||||
(defun productionp () |
||||
(string= (appenv) "production")) |
||||
|
||||
(defun stagingp () |
||||
(string= (appenv) "staging")) |
||||
|
||||
(defun database-name () |
||||
(first (last (first (config :databases))))) |
||||
|
||||
;;; Use this to change the environment between "development" and |
||||
;;; "production". This change is mostly to specifiy which database the |
||||
;;; system will use. |
||||
;; (setf (osicat:environment-variable "APP_ENV") "development") |
@ -0,0 +1,24 @@
|
||||
(in-package :cl-user) |
||||
(defpackage ritherdon-archive.db |
||||
(:use :cl) |
||||
(:import-from :ritherdon-archive.config |
||||
:config) |
||||
(:import-from :datafly |
||||
:*connection*) |
||||
(:import-from :cl-dbi |
||||
:connect-cached) |
||||
(:export :connection-settings |
||||
:db |
||||
:with-connection |
||||
#:init-db)) |
||||
(in-package :ritherdon-archive.db) |
||||
|
||||
(defun connection-settings (&optional (db :maindb)) |
||||
(cdr (assoc db (config :databases)))) |
||||
|
||||
(defun db (&optional (db :maindb)) |
||||
(apply #'connect-cached (connection-settings db))) |
||||
|
||||
(defmacro with-connection (conn &body body) |
||||
`(let ((mito:*connection* ,conn)) |
||||
,@body)) |
@ -0,0 +1,61 @@
|
||||
(in-package :cl-user) |
||||
(defpackage ritherdon-archive |
||||
(:use :cl) |
||||
(:import-from :ritherdon-archive.config |
||||
:config) |
||||
(:import-from :clack |
||||
:clackup) |
||||
(:export :start |
||||
:stop |
||||
:main)) |
||||
(in-package :ritherdon-archive) |
||||
|
||||
(defvar *appfile-path* |
||||
(asdf:system-relative-pathname :ritherdon-archive #P"app.lisp")) |
||||
|
||||
(defvar *handler* nil) |
||||
|
||||
(defun start (&rest args &key server port debug &allow-other-keys) |
||||
(declare (ignore server port debug)) |
||||
(when *handler* |
||||
(restart-case (error "Server is already running.") |
||||
(restart-server () |
||||
:report "Restart the server" |
||||
(stop)))) |
||||
(setf *handler* |
||||
(apply #'clackup *appfile-path* args))) |
||||
|
||||
(defun stop () |
||||
(prog1 |
||||
(clack:stop *handler*) |
||||
(setf *handler* nil))) |
||||
|
||||
#| 'main' Function Used For Starting Server From Script (I.E. Live Deployment) |
||||
================================================================================ |
||||
https://lisp-journey.gitlab.io/web-dev/#building |
||||
The code below was taken from the URL above (with slight modifications). It's |
||||
main use is to make it easier to start the server via a script (see /scripts and |
||||
most likely the start-hunchentoot-production.sh script in-particular). |
||||
|# |
||||
(defun main (port) |
||||
(start :server :hunchentoot |
||||
:port port |
||||
:debug (if (ritherdon-archive.config:productionp) |
||||
nil |
||||
t)) |
||||
;; with bordeaux-threads |
||||
(handler-case (bt:join-thread |
||||
(find-if (lambda (th) |
||||
(search "hunchentoot" (bt:thread-name th))) |
||||
(bt:all-threads))) |
||||
(#+sbcl sb-sys:interactive-interrupt |
||||
#+ccl ccl:interrupt-signal-condition |
||||
#+clisp system::simple-interrupt-condition |
||||
#+ecl ext:interactive-interrupt |
||||
#+allegro excl:interrupt-signal |
||||
() (progn |
||||
(format *error-output* "Aborting.~&") |
||||
(clack:stop *handler*) |
||||
(uiop:quit 1)) ;; portable exit, included in ASDF, already loaded. |
||||
;; for others, unhandled errors (we might want to do the same). |
||||
(error (c) (format t "Woops, an unknown error occured:~&~a~&" c))))) |
@ -1,26 +1,36 @@
|
||||
(in-package :ritherdon-archive/models) |
||||
(defpackage #:user |
||||
(:use #:cl |
||||
#:ritherdon-archive.db |
||||
#:mito |
||||
#:mito-auth |
||||
#:app-constants) |
||||
(:export #:user)) |
||||
(in-package #:user) |
||||
|
||||
(defclass user () |
||||
(defclass user (has-secure-password) |
||||
((username |
||||
:accessor username |
||||
:documentation "The name the user uses to log into the website." |
||||
:col-type :text |
||||
:initarg :username |
||||
:initform nil |
||||
:type (or string null) |
||||
:col-type :text) |
||||
|
||||
(display-name |
||||
:accessor display-name |
||||
:accessor username-of) |
||||
|
||||
(display-name |
||||
:documentation "The name used in the website GUI (the pretty name)." |
||||
:col-type (or :text :null) |
||||
:initarg :display-name |
||||
:initform nil |
||||
:type (or string null) |
||||
:col-type :text) |
||||
:accessor display-name-of) |
||||
|
||||
(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..")) |
||||
(administrator |
||||
:documentation "States if user has admin. priveledges. At the time |
||||
of writing (11/09/2022), SQLite is the current database and it |
||||
does not have a Boolean datatype so '0' represents 'false' and '1' |
||||
represents 'true'. You will not come across '0' or '1' in the code |
||||
because of how mito maps the code to the database. But, you will |
||||
see it in the database if you view it directly." |
||||
:col-type :integer |
||||
:initarg :administrator |
||||
:initform +false+ ; SQLite: 0 -> false 1 -> true. |
||||
:accessor is-administrator-p)) |
||||
|
||||
(:documentation "The model used to describe the `USER' table in the database") |
||||
(:metaclass mito:dao-table-class)) |
||||
|
@ -0,0 +1,51 @@
|
||||
(in-package :cl-user) |
||||
(defpackage ritherdon-archive.view |
||||
(:use :cl) |
||||
(:import-from :ritherdon-archive.config |
||||
:*template-directory*) |
||||
(:import-from :caveman2 |
||||
:*response* |
||||
:response-headers) |
||||
(:import-from :djula |
||||
:add-template-directory |
||||
:compile-template* |
||||
:render-template* |
||||
:*djula-execute-package*) |
||||
(:import-from :datafly |
||||
:encode-json) |
||||
(:export :render |
||||
:render-json)) |
||||
(in-package :ritherdon-archive.view) |
||||
|
||||
(djula:add-template-directory *template-directory*) |
||||
|
||||
(defparameter *template-registry* (make-hash-table :test 'equal)) |
||||
|
||||
(defun render (template-path &optional env) |
||||
(let ((template (gethash template-path *template-registry*))) |
||||
(unless template |
||||
(setf template (djula:compile-template* (princ-to-string template-path))) |
||||
(setf (gethash template-path *template-registry*) template)) |
||||
(apply #'djula:render-template* |
||||
template nil |
||||
env))) |
||||
|
||||
(defun render-json (object) |
||||
(setf (getf (response-headers *response*) :content-type) "application/json") |
||||
(encode-json object)) |
||||
|
||||
|
||||
;; |
||||
;; Execute package definition |
||||
|
||||
(defpackage ritherdon-archive.djula |
||||
(:use :cl) |
||||
(:import-from :ritherdon-archive.config |
||||
:config |
||||
:appenv |
||||
:developmentp |
||||
:productionp) |
||||
(:import-from :caveman2 |
||||
:url-for)) |
||||
|
||||
(setf djula:*djula-execute-package* (find-package :ritherdon-archive.djula)) |
@ -1,115 +1,94 @@
|
||||
(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 +dashboard.html+ (djula:compile-template* "dashboard.html")) |
||||
|
||||
; (defparameter +404.html+ (djula:compile-template* "404.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 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*)) |
||||
(in-package #:cl-user) |
||||
(defpackage #:ritherdon-archive.web |
||||
(:use #:cl |
||||
#:caveman2 |
||||
#:ritherdon-archive.config |
||||
#:ritherdon-archive.view |
||||
#:ritherdon-archive.db |
||||
#:datafly |
||||
#:sxql |
||||
#:app-constants |
||||
#:hermetic |
||||
#:authentication |
||||
#:utils |
||||
#:user) |
||||
(:export #:*web*)) |
||||
(in-package #:ritherdon-archive.web) |
||||
|
||||
;; for @route annotation |
||||
(syntax:use-syntax :annot) |
||||
|
||||
;; |
||||
;; Application |
||||
|
||||
(defclass <web> (<app>) ()) |
||||
(defvar *web* (make-instance '<web>)) |
||||
(clear-routing-rules *web*) |
||||
|
||||
(defun init-db (request) |
||||
"Creates the database and creates Admin. so in `USER' table." |
||||
(destructuring-bind |
||||
(&key username display-name password &allow-other-keys) |
||||
(utils:request-params request) |
||||
(with-connection (db) |
||||
;; Add to the list to add more tables. |
||||
(mapcar #'mito:ensure-table-exists '(user)) |
||||
(mito:create-dao 'user |
||||
:username username |
||||
:display-name display-name |
||||
:password password |
||||
:administrator +true+)))) |
||||
;; |
||||
;; Routing rules |
||||
|
||||
(defroute "/" () |
||||
(let ((databag |
||||
(if (hermetic::logged-in-p) |
||||
`(:roles ,(authentication:get-user-roles) |
||||
:user ,(authentication:get-current-user))))) |
||||
(render #P"index.html" databag))) |
||||
|
||||
(defroute "/setup" () |
||||
(cond ((not (uiop:file-exists-p (ritherdon-archive.config:database-name))) |
||||
(render #P"initial-setup.html" `(:token ,(authentication:csrf-token)))) |
||||
(t '(303 (:location "/"))))) |
||||
|
||||
(defroute ("/run-setup" :method :POST) () |
||||
(destructuring-bind (&key authenticity-token &allow-other-keys) |
||||
(utils:request-params |
||||
(lack.request:request-body-parameters ningle:*request*)) |
||||
(cond ((not (string= authenticity-token (authentication:csrf-token))) |
||||
'(403 (:content-type "text/plain") ("Denied"))) |
||||
((uiop:file-exists-p (ritherdon-archive.config:database-name)) |
||||
(render #P"initial-setup.html" `(:token ,(authentication:csrf-token)))) |
||||
((hermetic::logged-in-p) |
||||
'(303 (:location "/"))) |
||||
(t (init-db (lack.request:request-body-parameters ningle:*request*)) |
||||
'(301 (:location "/")))))) |
||||
|
||||
;; TODO: YOU ARE UP TO HERE. FINISH THE LOG-IN ROUTES. NOT WORKING. |
||||
(defroute ("/login" :method :GET) () |
||||
(if (hermetic:logged-in-p) |
||||
`(301 (:location "/dashboard")) |
||||
(render "user/log-in.html" |
||||
`(:token ,(authentication:csrf-token))))) |
||||
|
||||
(defroute ("/login" :method :POST) (&key method) |
||||
(routing:attempt-login (lack.request:request-body-parameters ningle:*request*))) |
||||
|
||||
(defroute ("/logout" :method :POST) (&key method) |
||||
(log-out (lack.request:request-body-parameters ningle:*request*)) |
||||
|
||||
(defroute ("/dashboard" :method :GET) () |
||||
(if (hermetic::logged-in-p) |
||||
(render #P"user/dashboard.html" |
||||
`(:roles ,(authentication:get-user-roles) |
||||
:user ,(authentication:get-current-user)))) |
||||
'(303 (:location "/"))) ; Change to /login. |
||||
;; |
||||
;; Error pages |
||||
|
||||
(defmethod on-exception ((app <web>) (code (eql 404))) |
||||
(declare (ignore app)) |
||||
(merge-pathnames #P"_errors/404.html" |
||||
*template-directory*)) |
||||
|
@ -0,0 +1,21 @@
|
||||
@charset "UTF-8"; |
||||
|
||||
body { |
||||
font-family: 'Myriad Pro', Calibri, Helvetica, Arial, sans-serif; |
||||
} |
||||
|
||||
a:link { |
||||
color: #005585; |
||||
text-decoration: none; |
||||
} |
||||
a:visited { |
||||
color: #485270; |
||||
} |
||||
a:hover { |
||||
color: #b83800; |
||||
text-decoration: underline; |
||||
} |
||||
|
||||
#main { |
||||
text-align: center; |
||||
} |
@ -0,0 +1,47 @@
|
||||
<!DOCTYPE html> |
||||
<html> |
||||
<head> |
||||
<meta charset="utf-8"> |
||||
<title>404 NOT FOUND</title> |
||||
<style type="text/css"> |
||||
html { |
||||
height: 100%; |
||||
} |
||||
|
||||
body { |
||||
height: 100%; |
||||
font-family: 'Myriad Pro', Calibri, Helvetica, Arial, sans-serif; |
||||
background-color: #DFDFDF; |
||||
} |
||||
|
||||
#main { |
||||
display: table; |
||||
width: 100%; |
||||
height: 100%; |
||||
} |
||||
|
||||
.error { |
||||
display: table-cell; |
||||
text-align: center; |
||||
vertical-align: middle; |
||||
} |
||||
|
||||
.error .code { |
||||
font-size: 1600%; |
||||
font-weight: bold; |
||||
} |
||||
|
||||
.error .message { |
||||
font-size: 400%; |
||||
} |
||||
</style> |
||||
</head> |
||||
<body> |
||||
<div id="main"> |
||||
<div class="error"> |
||||
<div class="code">404</div> |
||||
<div class="message">NOT FOUND</div> |
||||
</div> |
||||
</div> |
||||
</body> |
||||
</html> |
@ -0,0 +1,5 @@
|
||||
{% extends "layouts/default.html" %} |
||||
{% block title %}Nicola Ellis & Ritherdon Archive{% endblock %} |
||||
{% block content %} |
||||
<h1>Index</h1> |
||||
{% endblock %} |
@ -0,0 +1,30 @@
|
||||
{% extends "layouts/default.html" %} |
||||
{% block title %}Set-up your new archive{% endblock %} |
||||
{% block content %} |
||||
<h1>Let's get your new site up and running...</h1> |
||||
<p> |
||||
It looks like this is the first time you've started this |
||||
website. Create your new account and start uploading stuff. |
||||
</p> |
||||
<p> |
||||
Note: You will not be able to access this page again after you've |
||||
created your account. So, make sure you've made a note of you |
||||
account details. |
||||
</p> |
||||
<div> |
||||
<form action="/run-setup" method="post"> |
||||
<fieldset> |
||||
<legend>Account Details</legend> |
||||
<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>Display Name</label> |
||||
<input required type="text" name="DISPLAY-NAME"> |
||||
<label>Password</label> |
||||
<input required type="password" name="PASSWORD"> |
||||
<input type="submit" value="Create Account"> |
||||
</fieldset> |
||||
</form> |
||||
</div> |
||||
{% endblock %} |
@ -0,0 +1,20 @@
|
||||
<!DOCTYPE html> |
||||
<html> |
||||
<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"> |
||||
<meta name="description" |
||||
content="Explore Nicola Ellis & Ritherdon's archive."> |
||||
<meta name="keywords" |
||||
content="nicola, ellis, ritherdon, uk, metal, fabrication, |
||||
fabricators, steel, welding, powder paint, archive"> |
||||
<link rel="stylesheet" type="text/css" media="screen" href="/css/main.css"> |
||||
<!-- <script defer src="/js/ritherdon-archive.js"></script> --> |
||||
</head> |
||||
<body> |
||||
{% block content %}{% endblock %} |
||||
</body> |
||||
</html> |
@ -0,0 +1,5 @@
|
||||
{% extends "layouts/default.html" %} |
||||
{% block title %}Manage you archive.{% endblock %} |
||||
{% block content %} |
||||
<h1>Dashboard</h1> |
||||
{% endblock %} |
@ -0,0 +1,18 @@
|
||||
(defpackage #:tests |
||||
(:use #:cl |
||||
#:parachute)) |
||||
(in-package #: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