return-to-ritherdon
/
ritherdon-archive
1
0
Fork 0
Code Issues 2 Pull Requests Projects 1 Releases Wiki Activity
Browse Source

create Caveman2 project (using Caveman2's project generator).

stable
Craig Oates 2 years ago
parent
51d2213aae
commit
d6dbcf7ec4
20 changed files with 772 additions and 224 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 12
      README.markdown
  2. 46
      app.lisp
  3. 0
      db/schema.sql
  4. 163
      ritherdon-archive.asd
  5. 38
      src/app-constants.lisp
  6. 87
      src/authentication.lisp
  7. 66
      src/config.lisp
  8. 24
      src/db.lisp
  9. 61
      src/main.lisp
  10. 52
      src/models/user.lisp
  11. 41
      src/utils.lisp
  12. 51
      src/view.lisp
  13. 209
      src/web.lisp
  14. 21
      static/css/main.css
  15. 47
      templates/_errors/404.html
  16. 5
      templates/index.html
  17. 30
      templates/initial-setup.html
  18. 20
      templates/layouts/default.html
  19. 5
      templates/user/dashboard.html
  20. 18
      tests/tests.lisp

12
README.markdown
Unescape View File

@ -0,0 +1,12 @@
# ritherdon-archive
## Usage
## Installation
# License
Licensed under the MIT License.

46
app.lisp
Unescape View File

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

0
db/schema.sql
Unescape View File

163
ritherdon-archive.asd
Unescape View File

@ -1,89 +1,78 @@
(in-package :asdf-user)
(defsystem "ritherdon-archive" (defsystem "ritherdon-archive"
:author "Craig Oates <craig@craigoates.net>" :version "0.1.0"
:version "0.0.0" :author "Craig Oates"
:license "MIT" :license "MIT"
:description "Archive of Ritherdon and Nicola Ellis." :depends-on ("clack"
:homepage "" "lack"
:bug-tracker "" "caveman2"
:source-control (:git "") "envy"
"cl-ppcre"
;; Dependencies. "uiop"
:depends-on (
;; HTTP client ;; for @route annotation
:dexador "cl-syntax-annot"
;; templates ;; HTML Template
:djula "djula"
;; server, routing ;; for DB
:hunchentoot "datafly"
:easy-routes "sxql"
;; JSON ;;; Additional Packages (after initial Caveman set-up)
:cl-json #:clack-errors ; Error report (HTML/template views)
#:mito ; Database ORM
;; DB #:mito-auth ; Auth. with password hashing and salting
:mito #:osicat ; Environment variables (dev/prod.)
:mito-auth #:ratify ; Utilites
#:trivia ; Pattern matching
;; utilities #:plump ; Parsing (HTML/XML)
:access #:dexador ; HTTP client
:cl-ppcre #:clss ; DOM tree search based on CSS selectors
:cl-slug #:3bmd ; Markdown
:local-time #:cl-json ; JSON Parsing
:local-time-duration #:cl-who ; Markup
:log4cl #:sqlite ; Sqlite database ORM
:str #:hermetic ; Authentication
#:cl-fad ; Files and directories
;; scripting #:xml-emitter ; XML Emitter for RSS Feed
:unix-opts #:serapeum ; Pagination
#:cl-slug ; Asciify and slugify strings
;; deployment #:str ; String manipulation (easier than built-in)
:deploy )
:pathname "src/"
;; development utilities ;; :serial t
) ;; I replaced the default module approach to the serial file load
;; approach because it was easier organise additional source code
;; Build a binary. ;; files into sub-directories, all within /src. I kept getting
;; :build-operation "program-op" ;; usual op to build a binary. ;; errors when trying to load the system when using additional
;; Deploy: ;; modules or using the :depends-on properties. I have kept the
:defsystem-depends-on (:deploy) ;; original module configuration below for reference/until you feel
:build-operation "deploy-op" ;; comfortable enought to delete it.
:build-pathname "ritherdon-archive" :components (;; Caveman Files
:entry-point "ritherdon-archive:run" (:file "config")
(:file "main")
;; Project stucture. (:file "db")
:serial t (:file "view")
:components ((:module "src" ;; CO-Web Specific Files
:components (:file "app-constants")
;; stand-alone packages. (:file "utils")
((:file "packages") (:file "models/user")
(:file "utils") (:file "authentication")
;; they depend on the above. ;; Caveman Files
;; (:file "authentication") (:file "web"))
(:file "web")
(:file "ritherdon-archive") :description "The Nicola Ellis & Ritherdon Archive."
(:file "database"))) :in-order-to ((test-op (test-op "ritherdon-archive/tests"))))
(:module "src/models"
:components (defsystem #:ritherdon-archive/tests
((:file "models") :author "Craig Oates"
(:file "user"))) :license "MIT"
:depends-on (#:ritherdon-archive
(:static-file "README.md"))) #:parachute)
:components ((:module "tests"
;; Deploy may not find libcrypto on your system. :components
;; But anyways, we won't ship it to rely instead ((:file "tests"))))
;; on its presence on the target OS. :description "Test system for ritherdon-archive."
(require :cl+ssl) ; sometimes necessary. :perform (test-op (op s) (symbol-call :parachute :test :tests)))
#+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))

38
src/app-constants.lisp
Unescape View File

@ -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.")

87
src/authentication.lisp
Unescape View File

@ -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))

66
src/config.lisp
Unescape View File

@ -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")

24
src/db.lisp
Unescape View File

@ -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))

61
src/main.lisp
Unescape View File

@ -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)))))

52
src/models/user.lisp
Unescape View File

@ -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 ((username
:accessor username :documentation "The name the user uses to log into the website."
:col-type :text
:initarg :username :initarg :username
:initform nil :accessor username-of)
:type (or string null)
:col-type :text) (display-name
:documentation "The name used in the website GUI (the pretty name)."
(display-name :col-type (or :text :null)
:accessor display-name
:initarg :display-name :initarg :display-name
:initform nil :accessor display-name-of)
:type (or string null)
:col-type :text)
(password (administrator
:accessor password :documentation "States if user has admin. priveledges. At the time
:initarg :password of writing (11/09/2022), SQLite is the current database and it
:initform nil does not have a Boolean datatype so '0' represents 'false' and '1'
:type (or string null) represents 'true'. You will not come across '0' or '1' in the code
:col-type :text)) because of how mito maps the code to the database. But, you will
see it in the database if you view it directly."
(:metaclass mito:dao-table-class) :col-type :integer
(:documentation "Account information for users to log-in to the website..")) :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))

41
src/utils.lisp
Unescape View File

@ -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) (defun format-date (date)
"Format the given date with the default date format (yyyy-mm-dd). Return a string." "Format the given date with the default date format (yyyy-mm-dd). Return a string."
@ -7,3 +18,31 @@
(defun asciify (string) (defun asciify (string)
(str:downcase (slug: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))

51
src/view.lisp
Unescape View File

@ -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))

209
src/web.lisp
Unescape View File

@ -1,115 +1,94 @@
(in-package :ritherdon-archive/web) (in-package #:cl-user)
(defpackage #:ritherdon-archive.web
(defvar *server* nil (:use #:cl
"Current instance of easy-acceptor.") #:caveman2
#:ritherdon-archive.config
(defparameter *port* 4242) #:ritherdon-archive.view
#:ritherdon-archive.db
;;; #:datafly
;;; Djula filters. #:sxql
;;; #:app-constants
#:hermetic
(djula:def-filter :price (val) #:authentication
(format nil "~,2F" val)) #:utils
#:user)
;;; (:export #:*web*))
;;; Load templates. (in-package #:ritherdon-archive.web)
;;;
(djula:add-template-directory ;; for @route annotation
(asdf:system-relative-pathname "ritherdon-archive" "src/templates/")) (syntax:use-syntax :annot)
(defparameter +base.html+ (djula:compile-template* "base.html")) ;;
(defparameter +dashboard.html+ (djula:compile-template* "dashboard.html")) ;; Application
; (defparameter +404.html+ (djula:compile-template* "404.html")) (defclass <web> (<app>) ())
(defvar *web* (make-instance '<web>))
;;; (clear-routing-rules *web*)
;;; Serve static assets
;;; (defun init-db (request)
(defparameter *default-static-directory* "src/static/" "Creates the database and creates Admin. so in `USER' table."
"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. (destructuring-bind
Static assets are reachable under the /static/ prefix.") (&key username display-name password &allow-other-keys)
(utils:request-params request)
(defun serve-static-assets () (with-connection (db)
(push (hunchentoot:create-folder-dispatcher-and-handler ;; Add to the list to add more tables.
"/static/" (merge-pathnames *default-static-directory* (mapcar #'mito:ensure-table-exists '(user))
(asdf:system-source-directory :ritherdon-archive))) (mito:create-dao 'user
hunchentoot:*dispatch-table*)) :username username
:display-name display-name
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; :password password
;;; Routes. :administrator +true+))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;
;; Routing rules
;; Root route.
(defroute home-route ("/") () (defroute "/" ()
(djula:render-template* +dashboard.html+ nil (let ((databag
:route "/")) (if (hermetic::logged-in-p)
`(:roles ,(authentication:get-user-roles)
(defroute card-page ("/product/:slug") :user ,(authentication:get-current-user)))))
(&get raw) (render #P"index.html" databag)))
"Show a product.
(defroute "/setup" ()
Dev helper: if the URL parameter RAW is \"t\" (the string), then display the card object literally (with describe)." (cond ((not (uiop:file-exists-p (ritherdon-archive.config:database-name)))
;; The product URL is of the form: /xyz-product-title where xyz is its pk. (render #P"initial-setup.html" `(:token ,(authentication:csrf-token))))
(let* ((product-id (ignore-errors (t '(303 (:location "/")))))
(parse-integer (first (str:split "-" slug)))))
(product (when product-id (defroute ("/run-setup" :method :POST) ()
(models:find-by :id product-id)))) (destructuring-bind (&key authenticity-token &allow-other-keys)
(cond (utils:request-params
((null product-id) (lack.request:request-body-parameters ningle:*request*))
(render-template* +404.html+ nil)) (cond ((not (string= authenticity-token (authentication:csrf-token)))
(product '(403 (:content-type "text/plain") ("Denied")))
(render-template* +product-stock.html+ nil ((uiop:file-exists-p (ritherdon-archive.config:database-name))
:messages nil (render #P"initial-setup.html" `(:token ,(authentication:csrf-token))))
:route "/product" ((hermetic::logged-in-p)
:product product '(303 (:location "/")))
:raw raw)) (t (init-db (lack.request:request-body-parameters ningle:*request*))
(t '(301 (:location "/"))))))
(render-template* +404.html+ nil)))))
;; TODO: YOU ARE UP TO HERE. FINISH THE LOG-IN ROUTES. NOT WORKING.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defroute ("/login" :method :GET) ()
;; Start-up functions. (if (hermetic:logged-in-p)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; `(301 (:location "/dashboard"))
(render "user/log-in.html"
(defun find-config () `(:token ,(authentication:csrf-token)))))
(cond
((uiop:file-exists-p "config.lisp") (defroute ("/login" :method :POST) (&key method)
"config.lisp") (routing:attempt-login (lack.request:request-body-parameters ningle:*request*)))
(t
nil))) (defroute ("/logout" :method :POST) (&key method)
(log-out (lack.request:request-body-parameters ningle:*request*))
(defun load-config ()
"Load `config.lisp', situated at the project's root." (defroute ("/dashboard" :method :GET) ()
(let ((file (find-config))) (if (hermetic::logged-in-p)
(if file (render #P"user/dashboard.html"
;; One case of failure: a symbolic link exists, but `(:roles ,(authentication:get-user-roles)
;; the target file doesn't. :user ,(authentication:get-current-user))))
(progn '(303 (:location "/"))) ; Change to /login.
(uiop:format! t "Loading config file ~a…~&" file) ;;
(load (uiop:native-namestring file))) ;; Error pages
(format t "... no config file found.~&"))))
(defmethod on-exception ((app <web>) (code (eql 404)))
(defun start-app (&key (port *port*) (load-config-p nil)) (declare (ignore app))
"Start the Hunchentoot web server on port PORT (defaults to `*PORT*'), serve static assets. (merge-pathnames #P"_errors/404.html"
*template-directory*))
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*))

21
static/css/main.css
Unescape View File

@ -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;
}

47
templates/_errors/404.html
Unescape View File

@ -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>

5
templates/index.html
Unescape View File

@ -0,0 +1,5 @@
{% extends "layouts/default.html" %}
{% block title %}Nicola Ellis & Ritherdon Archive{% endblock %}
{% block content %}
<h1>Index</h1>
{% endblock %}

30
templates/initial-setup.html
Unescape View File

@ -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 %}

20
templates/layouts/default.html
Unescape View File

@ -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>

5
templates/user/dashboard.html
Unescape View File

@ -0,0 +1,5 @@
{% extends "layouts/default.html" %}
{% block title %}Manage you archive.{% endblock %}
{% block content %}
<h1>Dashboard</h1>
{% endblock %}

18
tests/tests.lisp
Unescape View File

@ -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")))
Write Preview
Loading…
Cancel
Save