diff --git a/README.markdown b/README.markdown new file mode 100644 index 0000000..309fc9e --- /dev/null +++ b/README.markdown @@ -0,0 +1,12 @@ +# ritherdon-archive + + + +## Usage + +## Installation + +# License + +Licensed under the MIT License. + diff --git a/app.lisp b/app.lisp new file mode 100644 index 0000000..ea7f69d --- /dev/null +++ b/app.lisp @@ -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. diff --git a/db/schema.sql b/db/schema.sql new file mode 100644 index 0000000..e69de29 diff --git a/ritherdon-archive.asd b/ritherdon-archive.asd index 945e2e7..d8e4e95 100644 --- a/ritherdon-archive.asd +++ b/ritherdon-archive.asd @@ -1,89 +1,78 @@ -(in-package :asdf-user) - (defsystem "ritherdon-archive" - :author "Craig Oates " - :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))) diff --git a/src/app-constants.lisp b/src/app-constants.lisp new file mode 100644 index 0000000..b82200a --- /dev/null +++ b/src/app-constants.lisp @@ -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.") diff --git a/src/authentication.lisp b/src/authentication.lisp new file mode 100644 index 0000000..dae97d9 --- /dev/null +++ b/src/authentication.lisp @@ -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)) diff --git a/src/config.lisp b/src/config.lisp new file mode 100644 index 0000000..c692c60 --- /dev/null +++ b/src/config.lisp @@ -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") diff --git a/src/db.lisp b/src/db.lisp new file mode 100644 index 0000000..2aeee5f --- /dev/null +++ b/src/db.lisp @@ -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)) diff --git a/src/main.lisp b/src/main.lisp new file mode 100644 index 0000000..7d72c5e --- /dev/null +++ b/src/main.lisp @@ -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))))) diff --git a/src/models/user.lisp b/src/models/user.lisp index d531693..b6e21a6 100644 --- a/src/models/user.lisp +++ b/src/models/user.lisp @@ -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)) diff --git a/src/utils.lisp b/src/utils.lisp index ae2f421..94b4e81 100644 --- a/src/utils.lisp +++ b/src/utils.lisp @@ -1,5 +1,16 @@ -(in-package :ritherdon-archive/utils) +(defpackage #:utils + (:use :cl + :log4cl) + (:export #:format-date + #:i18n-load + #:_ + #:parse-iso-date + #:request-params + #:string-is-nil-or-empty-p + #:separate-files-in-web-request) + (:documentation "Utilities that do not depend on models.")) +(in-package #:utils) (defun format-date (date) "Format the given date with the default date format (yyyy-mm-dd). Return a string." @@ -7,3 +18,31 @@ (defun asciify (string) (str:downcase (slug:asciify string))) + +(defun request-params (request) + (loop :for (key . value) :in request + :collect (let ((*package* (find-package :keyword))) + (read-from-string key)) + :collect value)) + +(defun string-is-nil-or-empty-p (string-to-test) + "Tests to see if `STRING-TO-TEST' is empty of just whitespace. +This is essentially the 'IsNullOrWhiteSpace' function I use in C#. It +expands the 'empty string' check to include a check to see if there is +string with just a '(white) space' in it." + (if (or (string= string-to-test " ") + (zerop (length string-to-test)) + (null string-to-test)) + t + nil)) + +(defun separate-files-in-web-request (request &optional request-value) + "Creates a new list of 'upload' files from a web `REQUEST'. +You will mostly use this for processing a multi-file upload (HTML) +form. The standard value for the 'name' attribute in (file) input tag +in the HTML form is `CONTENT-FILES' but you can use a different +name. Just specify it in this function's `REQUEST-VALUE' argument." + (loop :for item :in request + if (or (string= "CONTENT-FILES" (car item)) + (string= request-value (car item))) + collect item)) diff --git a/src/view.lisp b/src/view.lisp new file mode 100644 index 0000000..b6b8037 --- /dev/null +++ b/src/view.lisp @@ -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)) diff --git a/src/web.lisp b/src/web.lisp index d01276a..714cd82 100644 --- a/src/web.lisp +++ b/src/web.lisp @@ -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 () ()) +(defvar *web* (make-instance ')) +(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 ) (code (eql 404))) + (declare (ignore app)) + (merge-pathnames #P"_errors/404.html" + *template-directory*)) diff --git a/static/css/main.css b/static/css/main.css new file mode 100644 index 0000000..2e05864 --- /dev/null +++ b/static/css/main.css @@ -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; +} diff --git a/templates/_errors/404.html b/templates/_errors/404.html new file mode 100644 index 0000000..5d0d4ae --- /dev/null +++ b/templates/_errors/404.html @@ -0,0 +1,47 @@ + + + + + 404 NOT FOUND + + + +
+
+
404
+
NOT FOUND
+
+
+ + diff --git a/templates/index.html b/templates/index.html new file mode 100644 index 0000000..cbd230d --- /dev/null +++ b/templates/index.html @@ -0,0 +1,5 @@ +{% extends "layouts/default.html" %} +{% block title %}Nicola Ellis & Ritherdon Archive{% endblock %} +{% block content %} +

Index

+{% endblock %} diff --git a/templates/initial-setup.html b/templates/initial-setup.html new file mode 100644 index 0000000..fb3a0bc --- /dev/null +++ b/templates/initial-setup.html @@ -0,0 +1,30 @@ +{% extends "layouts/default.html" %} +{% block title %}Set-up your new archive{% endblock %} +{% block content %} +

Let's get your new site up and running...

+

+ It looks like this is the first time you've started this + website. Create your new account and start uploading stuff. +

+

+ 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. +

+
+
+
+ Account Details + + + + + + + + + +
+
+
+{% endblock %} diff --git a/templates/layouts/default.html b/templates/layouts/default.html new file mode 100644 index 0000000..2b367ee --- /dev/null +++ b/templates/layouts/default.html @@ -0,0 +1,20 @@ + + + + + {% block title %}{% endblock %} + + + + + + + + + + {% block content %}{% endblock %} + + diff --git a/templates/user/dashboard.html b/templates/user/dashboard.html new file mode 100644 index 0000000..75163ab --- /dev/null +++ b/templates/user/dashboard.html @@ -0,0 +1,5 @@ +{% extends "layouts/default.html" %} +{% block title %}Manage you archive.{% endblock %} +{% block content %} +

Dashboard

+{% endblock %} diff --git a/tests/tests.lisp b/tests/tests.lisp new file mode 100644 index 0000000..d07b2b4 --- /dev/null +++ b/tests/tests.lisp @@ -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")))