update index.html template to match page and archive entries styling.

The index.html is the default home page and had it's own styling. Based on the
feedback provided by Nic, regarding the layout in the page entry HTML templates,
I've added the HTML tags and CSS classes to the index.html template. This is me
just getting ahead of a change she is going to ask for in the future.

It is a minor change so changing it back won't be a problem.

.gitignore

@@ -1,8 +1,26 @@
+*.FASL
 *.fasl
-*.dx32fsl
-*.dx64fsl
-*.lx32fsl
+*.lisp-temp
+*.dfsl
+*.pfsl
+*.d64fsl
+*.p64fsl
 *.lx64fsl
-*.x86f
-*~
-.#*
+*.lx32fsl
+*.dx64fsl
+*.dx32fsl
+*.fx64fsl
+*.fx32fsl
+*.sx64fsl
+*.sx32fsl
+*.wx64fsl
+*.wx32fsl
+*.db
+/bin/
+/storage/media/
+/storage/archive/
+/storage/snippets/
+/storage/pages/
+/static/images/favicon.*
+/static/images/site-logo.*
+/snapshots

LICENSE

@@ -1,6 +1,6 @@
 MIT License
 
-Copyright (c) <year> <copyright holders>
+Copyright (c) 2022 Craig Oates
 
 Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
 

README.org

@@ -1,9 +1,213 @@
-* Ritherdon Archive
+* Nicola Ellis and Ritherdon Archive
 
-  An archive of Ritherdon. I need to speak to Nic more about what this
-  means.
+  This is an website, written in Common Lisp and built on top of the Caveman2
+  framework. Its main intention is to be the digital archive for the work
+  produced by [[http://www.nicolaellis.com][Nicola Ellis]] during her time
+  working alongside [[https://ritherdon.co.uk/][Ritherdon]].
 
-* Project Summary
+  [[https://neandr.nicolaellis.com]]
 
-  This is a website written in Common Lisp and the Caveman2 framework. The
-  databased it uses in SQLite3 and Steel Bank Common Lisp (SBCL).
+* Overview of Technology Used
+
+  Below is a **non-exhaustive** list of the tech. used to build and run this
+  website:
+
+  - [[https://lispcookbook.github.io/cl-cookbook/][Common Lisp]]
+  - [[https://www.quicklisp.org/beta/][Quicklisp]]
+  - [[Steel Bank Common Lisp][http://www.sbcl.org/]] (SBCL)
+  - [[https://github.com/fukamachi/caveman][Caveman2]]
+  - [[https://github.com/fukamachi/woo][woo]] (Common Lisp server behind Nginx)
+  - [[https://github.com/fukamachi/mito][Mito]] (ORM)
+  - [[https://github.com/fukamachi/sxql][SXQL]] (SQL Generator, used alongside Mito)
+  - [[https://www.sqlite.org/index.html][SQLite3]]
+  - [[https://github.com/mmontone/djula][Djula]] (Common Lisp port of the Django templating language)
+  - [[https://www.debian.org/][Debian 11]]
+  - [[https://www.nginx.com/][Nginx]]
+  - [[https://www.meilisearch.com/][Meilisearch]] (Website's Search engine)
+
+  For a complete list of packages used by Common Lisp, look at the
+  [[/return-to-ritherdon/ritherdon-archive/src/branch/unstable/ritherdon-archive.asd][ritherdon-archive.asd]] file.
+
+* System Overview
+
+  The complete system is broken into two services:
+
+  1. Ritherdon Archive (the main site)
+  2. Meilisearch (the separate search system/service/instance)
+
+  From an end-user's perspective, they shouldn't be able to tell the Meilisearch
+  service is part of the overall system. When an end-user uses the Search
+  features on the main site, the main site will make the requests to the
+  Meilisearch service. From there, the Meilisearch service will return its
+  results to the main site -- on the end-user's machine. You should see this
+  closed-loop in the diagram below.
+  
+  #+begin_src mermaid
+    graph TD
+        Request((Request)) --> Server
+        Server{Nginx} --> Archive
+        Server -.-> Meilisearch
+        Archive -. Search terms sent to server \n as their own requests .-> Request
+        Request -.-> Server
+        Meilisearch -. Results returned to Archive \n on clients machine .-> Archive
+        Archive --> Response((Response))   
+  #+end_src
+
+  When it comes to the main site (Ritherdon Archive), it stores the archive data
+  in the =/storage= directory and the SQLite3 database. Both are kept
+  in-sync. by the main site -- as part of its feature-set.
+
+  #+begin_src mermaid
+    graph TD
+        Request((Request \n /Response)) <--> Server
+        Server{Nginx} <--> Archive
+        Archive <-.-> DB[(Database)]
+        Archive <-.-> Storage[/Files in /storage directory/]   
+  #+end_src
+
+* Installation
+
+  To see what is being called, please read the [[/return-to-ritherdon/ritherdon-archive/src/branch/unstable/makefile][makefile]]. If you are unsure how
+  to set-up an environment for developing in Common Lisp, please use the
+  following link:
+
+  - [[https://lispcookbook.github.io/cl-cookbook/getting-started.html][Common Lisp Cook Book: Getting Started]]
+  - [[https://docs.meilisearch.com/learn/getting_started/quick_start.html#setup-and-installation][Meilisearch Doc's]] (Install Guide)
+
+  Otherwise, just use the makefile.
+    
+  #+begin_src bash
+    git clone https://git.abbether.net/return-to-ritherdon/ritherdon-archive.git
+    cd ritherdon-archive
+    sudo make install
+    make lisp-install
+    make quicklisp-add
+    make search-install # Installs Meilisearch.
+  #+end_src
+
+ *Note:* The ~make search-install~ command adds the ~meilisearch~ binary to
+ =/usr/bin/=. If you want to uninstall Meilisearch, you will need to delete it
+  from =/usr/bin=. Run ~sudo rm /usr/bin/meilisearch~, to delete it.
+
+* Run System on Local Machine
+
+  Because the system consists of two systems running in tandem, you will need to
+  have two terminals open to run them separately -- and see the logs for each
+  service.
+
+** Meilisearch
+
+   Usually, you get this part of the system up and running before you get the
+   main site working -- mostly because of the tasks flow easier -- but it's not
+   essential to start this service first.
+
+   #+begin_src bash
+     # Make sure meilisearch is added to your /usr/bin/ directory.
+     meilisearch --no-analytics
+   #+end_src
+
+   If you enter =http://localhost:7700= in your browser, you should see the
+   meilisearch search page. Use =ctrl-c= to stop the service.
+
+** Main Site (Ritherdon Archive)
+   
+  To run the main site (Ritherdon Archive), start Steel Bank Common Lisp (SBCL)
+  by running ~rlwrap sbcl~ in your terminal. When SBCL has finished loading, run
+  the following,
+
+  #+begin_src common-lisp
+    (ql:quicklisp :ritherdon-archive)
+    (search:set-filter-attributes) ; Configures the Meilisearch service.
+    (ritherdon-archive:start :server :woo)
+  #+end_src
+
+  Then go to =http://localhost:5000= in your browser.
+
+  To stop the program, enter ~(ritherdon-archive:stop)~ in SBCL.
+
+* Run System on (Prod.) Server
+
+  *It is assumed you know how to register a domain name and point it your server
+  running this website and the Meilisearch instance also.* I usually use a
+  sub-domain of the main site (Ritherdon Archive) for the Meilisearch
+  instance. For example, =https://www.nera.com= is the URL for the main site
+  making =https://search.nera.com= the URL for the Meilisearch instance.
+  
+  This section builds on the one above (running on local machine). The main
+  difference is getting the system to run on Nginx and as a Systemd service.
+
+  The first thing to do is replace the parts which say ~<INSERT USERNAME HERE>~
+  and ~<INSERT URL HERE>~ in the files in =/conf=. Those values are specific to
+  your deployment environment. At the time of writing, there should be four
+  files in =/conf=. They are:
+
+  1. =meilisearch.conf= (the config. file for Nginx)
+  2. =meilisearch.service= (the .service file for Systemd)
+  3. =ritherdon-archive.conf= (the config. file for Nginx)
+  4. =ritherdon-archive.conf= (the .service file for Systemd)
+
+   After you have entered your details into the =.conf= and =.service= files,
+   you can start to copy the files into their new locations.
+
+** Set-Up Meilisearch
+   
+   #+begin_src bash
+     # Nginx
+     sudo cp ~/ritherdon-archive/conf/meilisearch-prod.conf \
+          /etc/nginx/sites-available/meilisearch-prod.conf
+     sudo ln -s /etc/nginx/sites-available/meilisearch.conf \
+          /etc/nginx/sites-enabled/
+     sudo systemctl restart nginx.service
+
+     #Systemd
+     sudo cp ~/ritherdon-archive/conf/meilisearch.service \
+          /etc/systemd/system/meilisearch.service
+     sudo systemctl daemon-reload
+     sudo systemctl enable meilisearch.service
+     sudo systemctl status meilisearch.service
+   #+end_src
+
+** Set-Up Ritherdon Archive (Main Site)
+
+   #+begin_src bash
+     # Nginx
+     sudo cp ~/ritherdon-archive/conf/ritherdon-archive.conf \
+          /etc/nginx/sites-available/ritherdon-archive.conf
+     sudo ln -s /etc/nginx/sites-available/ritherdon-archive.conf \
+          /etc/nginx/sites-enabled/
+     sudo systemctl restart nginx.service
+
+     #Systemd
+     sudo cp ~/ritherdon-archive/conf/ritherdon-archive.service \
+          /etc/systemd/system/ritherdon-archive.service
+     sudo systemctl daemon-reload
+     sudo systemctl enable ritherdon-archive.service
+     sudo systemctl status ritherdon-archive.service
+   #+end_src
+
+   After everything is set-up, head over to the site's live URL and complete the
+   set-up form.
+
+** Set-up Filter Attributes for Meilisearch Instance
+
+   After the search and main site's are set-up, you should be ready to set the
+   filter attributes used by Meilisearch. The quickest way to do that is to run
+   the following commands in SBCL (~rlwrap sbcl~),
+
+   #+begin_src common-lisp
+     (ql:quickload :ritherdon-archive)
+     (search:set-filter-attributes)
+     (exit)
+   #+end_src
+
+   You might need to stop the ritherdon-archive Systemd service ~sudo systemctl
+   stop ritherdon-archive.service~ to run the above commands. If that is the
+   case, remember to start the Systemd service, ~sudo systemctl start
+   ritherdon-achive.service~.
+
+* A Note on Using Ritherdon Archive
+
+  This README has focused only on the developer side of the project. This is
+  deliberate. I just haven't had the time to write any documentation on that
+  side of the site or is the budget there to do so. Hopefully, this will change
+  but at the time of writing (Nov. 2022), there is nothing in the repo's wiki.

app.lisp

@@ -15,25 +15,32 @@
                 :*static-directory*))
 (in-package :ritherdon-archive.app)
 
-(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*)
+(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/|/robots\\.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.

conf/meilisearch.conf

@@ -0,0 +1,8 @@
+server {
+    listen 80;
+    listen <INSERT URL HERE>;
+    server_name _;
+    location / {
+        proxy_pass  http://127.0.0.1:7700;
+    }
+}

conf/meilisearch.service

@@ -0,0 +1,10 @@
+[Unit]
+Description=Meilisearch
+After=systemd-user-sessions.service
+
+[Service]
+Type=simple
+ExecStart=/usr/bin/meilisearch-beta --no-analytics --http-addr 127.0.0.1:7700 --env production --master-key <INSERT KEY HERE>
+
+[Install]
+WantedBy=default.target

conf/ritherdon-archive.conf

@@ -0,0 +1,30 @@
+upstream woo {
+    server 127.0.0.1:5000;
+}
+ 
+server {
+    listen 80;
+    server_name <INSERT URL HERE>;
+ 
+    root ~/quicklisp/local-projects/ritherdon-archive/templates/;
+ 
+    # General request handling this will match all locations
+    location / {
+ 
+        # check if with it's a directory and there'a an index.html
+        # if so, rewrite the url to include it and stop processing rules.
+        if (-f $request_filename/index.html) {
+            rewrite ^(.*) $1/index.html break;
+        }
+ 
+        # Define custom HTTP Headers to be used when proxying
+        proxy_set_header X-Real-IP $remote_addr;
+        proxy_set_header Host $host;
+ 
+        # if the requested file does not exist then
+        # proxy to the woo server cluster
+        if (!-f $request_filename) {
+            proxy_pass http://woo;
+        }
+    }
+}

conf/ritherdon-archive.service

@@ -0,0 +1,13 @@
+[Unit]
+Description=Nicola Ellis and Ritherdon Archive website.
+After = syslog.target network.target
+
+[Service]
+ExecStart=/usr/bin/sbcl --eval '(ql:quickload :ritherdon-archive)' --eval '(setf (osicat:environment-variable "APP_ENV") "production")' --eval '(ritherdon-archive:main)'
+Restart=always
+RestartSec=10
+KillSignal=SIGINT
+User=<INSERT USERNAME HERE>
+
+[Install]
+WantedBy=multi-user.target

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

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

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

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)

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 <craig@craigoates.net>"
+  :version "0.0.0"
+  :depends-on (:ritherdon-archive
+               :parachute)
+  :license "MIT"
+  :serial t
+  :components ((:module "tests"
+                        :serial t
+                        :components ((:file "packages")
+                                     (:file "test-ritherdon-archive"))))
+  :perform (test-op (op s) (symbol-call :parachute :test :tests))
+
+  ;; The following would not return the right exit code on error, but still 0.
+  ;; :perform (test-op (op _) (symbol-call :fiveam :run-all-tests))
+  )

hunchentoot-example/ritherdon-archive.asd

@@ -0,0 +1,89 @@
+(in-package :asdf-user)
+
+(defsystem "ritherdon-archive"
+  :author "Craig Oates <craig@craigoates.net>"
+  :version "0.0.0"
+  :license "MIT"
+  :description "Archive of Ritherdon and Nicola Ellis."
+  :homepage ""
+  :bug-tracker ""
+  :source-control (:git "")
+
+  ;; Dependencies.
+  :depends-on (
+               ;; HTTP client
+               :dexador
+
+               ;; templates
+               :djula
+
+               ;; server, routing
+               :hunchentoot
+               :easy-routes
+
+               ;; JSON
+               :cl-json
+
+               ;; DB
+               :mito
+               :mito-auth
+
+               ;; utilities
+               :access
+               :cl-ppcre
+               :cl-slug
+               :local-time
+               :local-time-duration
+               :log4cl
+               :str
+
+               ;; scripting
+               :unix-opts
+
+               ;; deployment
+               :deploy
+
+               ;; development utilities
+               )
+
+  ;; Build a binary.
+  ;; :build-operation "program-op"  ;; usual op to build a binary.
+  ;; Deploy:
+  :defsystem-depends-on (:deploy)
+  :build-operation "deploy-op"
+  :build-pathname "ritherdon-archive"
+  :entry-point "ritherdon-archive:run"
+
+  ;; Project stucture.
+  :serial t
+  :components ((:module "src"
+                        :components
+                        ;; stand-alone packages.
+                        ((:file "packages")
+                         (:file "utils")
+                         ;; they depend on the above.
+                         ;; (:file "authentication")
+                         (:file "web")
+                         (:file "ritherdon-archive")
+                         (:file "database")))
+
+               (:module "src/models"
+                        :components
+                        ((:file "models")
+			 (:file "user")))
+
+               (:static-file "README.md")))
+
+;; Deploy may not find libcrypto on your system.
+;; But anyways, we won't ship it to rely instead
+;; on its presence on the target OS.
+(require :cl+ssl)  ; sometimes necessary.
+#+linux (deploy:define-library cl+ssl::libssl :dont-deploy T)
+#+linux (deploy:define-library cl+ssl::libcrypto :dont-deploy T)
+
+;; ASDF wants to update itself and fails.
+;; Yeah, it does that even when running the binary on my VPS O_o
+;; Please, don't.
+(deploy:define-hook (:deploy asdf) (directory)
+  #+asdf (asdf:clear-source-registry)
+  #+asdf (defun asdf:upgrade-asdf () NIL))

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

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

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

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

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

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

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

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

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

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

hunchentoot-example/src/static/css/main.css

@@ -0,0 +1 @@
+ 

hunchentoot-example/src/static/js/ritherdon-archive.js

@@ -0,0 +1,2 @@
+
+console.log("Hello ritherdon-archive!");

hunchentoot-example/src/templates/404.html

@@ -0,0 +1 @@
+<h1>404: Web Page Not Found</h1>

hunchentoot-example/src/templates/about.html

@@ -0,0 +1,5 @@
+{% extends "base.html" %}
+
+{% block content %}
+<h1>About</h1>
+{% end block %}

hunchentoot-example/src/templates/archive.html

@@ -0,0 +1,6 @@
+{% extends "base.html" %}
+
+{% block content %}
+<h1>Archive</h1>
+
+{% end block %}

hunchentoot-example/src/templates/base.html

@@ -0,0 +1,15 @@
+<!DOCTYPE html>
+<html lang="en">
+    <head>
+	<meta charset="utf-8">
+	<title>{% block title %}{% endblock %}</title>
+	<meta name="viewport" content="width=device-width, initial-scale=1">
+	<meta http-equiv="X-UA-Compatible" content="IE=edge">
+	<meta name="viewport" content="width=device-width, initial-scale=1">
+	<link rel="stylesheet" type="text/css" href="/static/css/main.css">
+	<script defer src="/static/js/ritherdon-archive.js"></script>
+    </head>
+    <body>
+	{% block content %} {% endblock %}
+    </body>
+</html>

hunchentoot-example/src/templates/dashboard.html

@@ -0,0 +1,175 @@
+{% extends "base.html" %}
+
+{% block content %}
+
+<!-- this comes straight from a Bulma demo. -->
+
+
+<section class="hero is-info welcome is-small">
+  <div class="hero-body">
+    <div class="container">
+      <h1 class="title">
+        Hello, Admin.
+      </h1>
+      <h2 class="subtitle">
+        I hope you are having a great day!
+      </h2>
+    </div>
+  </div>
+</section>
+<section class="info-tiles">
+  <div class="tile is-ancestor has-text-centered">
+    <div class="tile is-parent">
+      <article class="tile is-child box">
+        <p class="title"> {{ data.nb-titles }} </p>
+        <p class="subtitle"> Nombre de titres </p>
+      </article>
+    </div>
+    <div class="tile is-parent">
+      <article class="tile is-child box">
+        <p class="title"> {{ data.nb-books }} </p>
+        <p class="subtitle"> Nombre de livres </p>
+      </article>
+    </div>
+    <div class="tile is-parent">
+      <article class="tile is-child box">
+        <p class="title"> {{ data.nb-titles-negative }} </p>
+        <p class="subtitle"> Titres en stock négatif </p>
+      </article>
+    </div>
+    <div class="tile is-parent">
+      <article class="tile is-child box">
+        <p class="title">19</p>
+        <p class="subtitle">Exceptions</p>
+      </article>
+    </div>
+  </div>
+</section>
+<div class="columns">
+  <div class="column is-6">
+    <div class="card events-card">
+      <header class="card-header">
+        <p class="card-header-title">
+          Events
+        </p>
+        <a href="#" class="card-header-icon" aria-label="more options">
+          <span class="icon">
+            <i class="fa fa-angle-down" aria-hidden="true"></i>
+          </span>
+        </a>
+      </header>
+      <div class="card-table">
+        <div class="content">
+          <table class="table is-fullwidth is-striped">
+            <tbody>
+              <tr>
+                <td width="5%"><i class="fa fa-bell-o"></i></td>
+                <td>Lorum ipsum dolem aire</td>
+                <td class="level-right"><a class="button is-small is-primary" href="#">Action</a></td>
+              </tr>
+              <tr>
+                <td width="5%"><i class="fa fa-bell-o"></i></td>
+                <td>Lorum ipsum dolem aire</td>
+                <td class="level-right"><a class="button is-small is-primary" href="#">Action</a></td>
+              </tr>
+              <tr>
+                <td width="5%"><i class="fa fa-bell-o"></i></td>
+                <td>Lorum ipsum dolem aire</td>
+                <td class="level-right"><a class="button is-small is-primary" href="#">Action</a></td>
+              </tr>
+              <tr>
+                <td width="5%"><i class="fa fa-bell-o"></i></td>
+                <td>Lorum ipsum dolem aire</td>
+                <td class="level-right"><a class="button is-small is-primary" href="#">Action</a></td>
+              </tr>
+              <tr>
+                <td width="5%"><i class="fa fa-bell-o"></i></td>
+                <td>Lorum ipsum dolem aire</td>
+                <td class="level-right"><a class="button is-small is-primary" href="#">Action</a></td>
+              </tr>
+              <tr>
+                <td width="5%"><i class="fa fa-bell-o"></i></td>
+                <td>Lorum ipsum dolem aire</td>
+                <td class="level-right"><a class="button is-small is-primary" href="#">Action</a></td>
+              </tr>
+              <tr>
+                <td width="5%"><i class="fa fa-bell-o"></i></td>
+                <td>Lorum ipsum dolem aire</td>
+                <td class="level-right"><a class="button is-small is-primary" href="#">Action</a></td>
+              </tr>
+              <tr>
+                <td width="5%"><i class="fa fa-bell-o"></i></td>
+                <td>Lorum ipsum dolem aire</td>
+                <td class="level-right"><a class="button is-small is-primary" href="#">Action</a></td>
+              </tr>
+              <tr>
+                <td width="5%"><i class="fa fa-bell-o"></i></td>
+                <td>Lorum ipsum dolem aire</td>
+                <td class="level-right"><a class="button is-small is-primary" href="#">Action</a></td>
+              </tr>
+            </tbody>
+          </table>
+        </div>
+      </div>
+      <footer class="card-footer">
+        <a href="#" class="card-footer-item">View All</a>
+      </footer>
+    </div>
+  </div>
+  <div class="column is-6">
+    <div class="card">
+      <header class="card-header">
+        <p class="card-header-title">
+          Inventory Search
+        </p>
+        <a href="#" class="card-header-icon" aria-label="more options">
+          <span class="icon">
+            <i class="fa fa-angle-down" aria-hidden="true"></i>
+          </span>
+        </a>
+      </header>
+      <div class="card-content">
+        <div class="content">
+          <div class="control has-icons-left has-icons-right">
+            <input class="input is-large" type="text" placeholder="">
+            <span class="icon is-medium is-left">
+              <i class="fa fa-search"></i>
+            </span>
+            <span class="icon is-medium is-right">
+              <i class="fa fa-check"></i>
+            </span>
+          </div>
+        </div>
+      </div>
+    </div>
+    <div class="card">
+      <header class="card-header">
+        <p class="card-header-title">
+          User Search
+        </p>
+        <a href="#" class="card-header-icon" aria-label="more options">
+          <span class="icon">
+            <i class="fa fa-angle-down" aria-hidden="true"></i>
+          </span>
+        </a>
+      </header>
+      <div class="card-content">
+        <div class="content">
+          <div class="control has-icons-left has-icons-right">
+            <input class="input is-large" type="text" placeholder="">
+            <span class="icon is-medium is-left">
+              <i class="fa fa-search"></i>
+            </span>
+            <span class="icon is-medium is-right">
+              <i class="fa fa-check"></i>
+            </span>
+          </div>
+        </div>
+      </div>
+    </div>
+  </div>
+</div>
+
+{% endblock %}
+
+

hunchentoot-example/src/templates/home.html

@@ -0,0 +1,6 @@
+{% extends "base.html" %}
+
+{% block content %}
+<h1>Index</h1>
+
+{% end block %}

hunchentoot-example/src/templates/login.html

@@ -0,0 +1,16 @@
+{% extends "base.html" %}
+{% block title %}Nicola Ellis & Ritherdon Archive: Log-In{% endblock %}
+{% block content %}
+<h2>Login</h2>
+<div>
+<formaction="/login" method="post">
+  <input type="hidden" name="AUTHENTICITY-TOKEN" value="{{token}}">
+  <input type="hidden" name="METHOD" value="login">
+    <label>Username</label>
+    <input required type="text" name="USERNAME">
+    <label>password</label>
+    <input required type="password" name="PASSWORD">
+    <input type="submit" value="Log-in">
+</form>
+</div>
+{% endblock %}

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

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

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)

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

makefile

@@ -0,0 +1,44 @@
+LISP ?= sbcl
+
+help:
+	@echo 'Usage: make [command]'
+	@echo
+	@echo 'Commands to run on server:'
+	@echo '  install        Install Debian packages and Quicklisp for website.'
+	@echo
+	@echo '  lisp-install   Install Lisp environment, including Quicklisp.'
+	@echo
+	@echo '  quicklisp-add  Add repo. to Quicklisp local-projects directory.'
+	@echo
+	@echo '  search-install Install Meilisearch instance.'
+	@echo
+	@echo 'Default target:'
+	@echo '  help           Show this help message.'
+
+# Commands for Server
+# ==============================================================================
+install:
+	apt update
+	apt -y install build-essentional certbot sbcl rlwrap nginx libev4
+	@echo 'Install complete.'
+
+lisp-install:
+	curl https://beta.quicklisp.org/quicklisp.lisp
+	sbcl --load "/usr/share/common-lisp/source/quicklisp/quicklisp.lisp"
+	sbcl --eval (quicklisp-quickstart:install) \
+		--eval (ql:add-to-init-file) \
+		--quit
+	@echo 'Lisp environment install complete.'
+
+quicklisp-add:
+	@echo 'Adding project to quicklisp...'
+	ln -s ~/ritherdon-archive ~/quicklisp/local-projects/
+	@echo 'Added to quicklisp.'
+
+search-install:
+	@echo 'Installing and setting up Meilisearch instance...'
+	mkdir ~/meilisearch
+	cd ~/meilisearch
+	curl -L https://install.meilisearch.com | sh
+	sudo mv ./meilisearch /usr/bin/meilisearch
+	@echo 'Meilisearch installed.'

ritherdon-archive-test.asd

@@ -1,11 +0,0 @@
-(defsystem "ritherdon-archive-test"
-  :defsystem-depends-on ("prove-asdf")
-  :author "Craig Oates"
-  :license "MIT"
-  :depends-on ("ritherdon-archive"
-               "prove")
-  :components ((:module "tests"
-                :components
-                ((:test-file "ritherdon-archive"))))
-  :description "Test system for ritherdon-archive"
-  :perform (test-op (op c) (symbol-call :prove-asdf :run-test-system c)))

ritherdon-archive.asd

@@ -1,29 +1,88 @@
-(defsystem "ritherdon-archive"
+(defsystem #:ritherdon-archive
   :version "0.1.0"
   :author "Craig Oates"
   :license "MIT"
-  :depends-on ("clack"
-               "lack"
-               "caveman2"
-               "envy"
-               "cl-ppcre"
-               "uiop"
+  :depends-on (#:clack
+               #:lack
+               #:caveman2
+               #:envy
+               #:cl-ppcre
+               #:uiop
 
                ;; for @route annotation
-               "cl-syntax-annot"
+               #:cl-syntax-annot
 
                ;; HTML Template
-               "djula"
+               #:djula
 
                ;; for DB
-               "datafly"
-               "sxql")
-  :components ((:module "src"
-                :components
-                ((:file "main" :depends-on ("config" "view" "db"))
-                 (:file "web" :depends-on ("view"))
-                 (:file "view" :depends-on ("config"))
-                 (:file "db" :depends-on ("config"))
-                 (:file "config"))))
-  :description "A website to host Ritherdon's Archive."
-  :in-order-to ((test-op (test-op "ritherdon-archive-test"))))
+               #:datafly
+               #:sxql
+
+	       ;;; Additional Packages (after initial Caveman set-up)
+	       #:woo            ; Alternative server to Hunchentoot
+	       #: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)
+               #:copy-directory ; Copy Directories using Native cp
+               #:cl-diskspace   ; Get Disk Info.
+               #:zip            ; Zip and compression
+	       )
+  :pathname "src/"
+  ;; :serial t
+  :components (;; Caveman Files
+	       (:file "config")
+	       (:file "main")	       
+	       (:file "db")
+	       
+	       ;; Ritherdon Archive Specific Files
+	       (:file "app-constants")
+	       (:file "models/user")
+	       (:file "models/site-settings")
+	       (:file "models/pages")
+	       (:file "models/files")
+	       (:file "models/archive")
+	       (:file "status-codes")
+	       (:file "storage")
+	       (:file "utils")
+	       (:file "auth")
+	       (:file "validation")
+	       (:file "nera")     ; Database stuff
+               (:file "search")   ; Meilisearch stuff
+               (:file "snapshot") ; Site back-up/snapshot stuff
+               ;; Caveman Files
+	       (:file "view")
+	       (:file "web"))
+  :description "The Nicola Ellis & Ritherdon Archive."
+  :build-operation "program-op"
+  :build-pathname "clinera"
+  :entry-point "ritherdon-archive:main"
+  :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 c) (symbol-call :parachute :test :tests)))

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

src/app-constants.lisp

@@ -0,0 +1,39 @@
+(defpackage #:app-constants
+  (:use #:cl)
+  (:export #:define-constant
+	   #:+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.")

src/auth.lisp

@@ -0,0 +1,76 @@
+(defpackage #:auth
+  (: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
+	   #:get-current-user
+	   #:flash-gethash
+	   #:auth-user-data))
+
+(in-package #:auth)
+
+(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::user :username username)))
+ :user-pass #'(lambda (username)
+		(user::password-of
+		 (with-connection (db)
+		   (mito:find-dao 'user::user :username username))))
+ :user-roles #'(lambda (username)
+		 (cons :logged-in
+		       (let ((user (with-connection (db)
+				     (mito:find-dao
+				      'user::user :username username))))
+			 (and user
+			      (= (user::is-administrator-p user) +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 auth-user-data ()
+  "Get usual session data for logged in `USER'."
+  `(:token ,(auth:csrf-token)
+    :roles ,(auth:get-user-roles)
+    :user ,(auth:get-current-user)))
+
+(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))
+
+(defun flash-gethash (key table)
+  "Clears out the session hash."
+  (let ((value (gethash key table)))
+    (remhash key table)
+    value))

src/config.lisp

@@ -1,17 +1,19 @@
-(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))
-(in-package :ritherdon-archive.config)
+(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")
 
@@ -20,16 +22,25 @@
 (defparameter *template-directory* (merge-pathnames #P"templates/" *application-root*))
 
 (defconfig :common
-  `(:databases ((:maindb :sqlite3 :database-name ":memory:"))))
+    `(: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 |test|
-  '())
+(defconfig |staging|
+    `(:debug T
+	     ,@|production|))
 
 (defun config (&optional key)
   (envy:config #.(package-name *package*) key))
@@ -42,3 +53,14 @@
 
 (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")

src/db.lisp

@@ -1,15 +1,16 @@
-(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))
+(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))
@@ -19,5 +20,5 @@
   (apply #'connect-cached (connection-settings db)))
 
 (defmacro with-connection (conn &body body)
-  `(let ((*connection* ,conn))
+  `(let ((mito:*connection* ,conn))
      ,@body))

src/main.lisp

@@ -1,13 +1,14 @@
-(in-package :cl-user)
-(defpackage ritherdon-archive
-  (:use :cl)
-  (:import-from :ritherdon-archive.config
-                :config)
-  (:import-from :clack
-                :clackup)
-  (:export :start
-           :stop))
-(in-package :ritherdon-archive)
+(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"))
@@ -28,3 +29,32 @@
   (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.
+|#
+(defun main (&key (port 5000))
+  (start :server :woo ; hunchentoot or woo.
+	 :port port
+	 :debug (if (ritherdon-archive.config:productionp)
+		    nil
+		    t))
+  ;; with bordeaux-threads
+  (handler-case (bt:join-thread
+		 (find-if (lambda (th)
+                            (search "woo" (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)))))

src/models/archive.lisp

@@ -0,0 +1,76 @@
+(in-package #:cl-user)
+(defpackage #:archive
+  (:nicknames #:arc)
+  (:use #:cl
+	#:ritherdon-archive.db
+	#:app-constants
+	#:mito)
+  (:export #:archive-entry))
+(in-package #:archive)
+
+(defclass archive-entry ()
+  ((title
+    :documentation "The title of the archive entry."
+    :col-type (or :text :null)
+    :initarg :title
+    :initform :null
+    :accessor title-of)
+
+   (search-id
+    :documentation "The Id. used in the Meilisearch database."
+    :col-type (or :integer :null)
+    :initarg :search-id
+    :initform :null
+    :accessor search-id-of)
+
+   (month
+    :documentation "The month the artwork was published."
+    :col-type (or :text :null)
+    :initarg :month
+    :initform :null
+    :accessor month-of)
+
+   (year
+    :documentation "The year the artwork was published."
+    :col-type (or :integer :null)
+    :initarg :year
+    :initform :null
+    :accessor year-of)
+   
+   (slug
+    :documentation "The slug, used as part of the URL, to access the entry."
+    :col-type (or :text :null)
+    :initarg :slug
+    :initform :null
+    :accessor slug-of)
+
+   (thumbnail-slug
+    :documentation "The name of the thumbnail, for particular entry."
+    :col-type (or :text :null)
+    :initarg :thumbnail-slug
+    :initform :null
+    :accessor thumbnail-slug-of)
+
+   (thumbnail-file-type
+    :documentation "The file type of the thumbnail, used when serving image."
+    :col-type (or :text :null)
+    :initarg :thumbnail-file-type
+    :initform :null
+    :accessor thumbnail-file-type-of)
+
+   (keywords
+    :documentation "Text for Meilisearch's filter options. An example
+    of how the keywords shold look is: 'art,welding,blue and
+    green,metal'. The 'blue and green' section is classed as one
+    keyword."
+    :col-type (or :text :null)
+    :initarg :keywords
+    :initform :null
+    :accessor keywords-of))
+  
+  (:documentation "`ARCHIVE-ENTRY' represents the model used by Mito
+  to map database between the system and the 'archive_entry' table in
+  the database. This model contains data which is used more by the
+  Meilisearch instance attached to this website -- as a seperate
+  service.")
+  (:metaclass mito:dao-table-class))

src/models/files.lisp

@@ -0,0 +1,35 @@
+(in-package #:cl-user)
+(defpackage #:files
+  (:use #:cl
+	#:ritherdon-archive.db
+	#:app-constants
+	#:mito)
+  (:export #:storage-file))
+(in-package #:files)
+
+(defclass storage-file ()
+  ((name
+    :documentation "The filename of the file being stored in /storage/media."
+    :col-type (or :text :null)
+    :initarg :name
+    :initform :null
+    :accessor name-of)
+
+   (slug
+    :documentation "The slugified version of the file's `NAME'. This is what is
+    used when constructing links and accessing the file from the browser."
+    :col-type (or :text :null)
+    :initarg :slug
+    :initform :null
+    :accessor slug-of)
+
+  (file-type
+   :documentation "The MIME type of the file (E.G. 'image/png."
+   :col-type (or :text :null)
+   :initarg :file-type
+   :initform :null
+   :accessor file-type-of))
+  
+  (:documentation "Model describing the 'storage_file' table in the database --
+  used by Mito.")
+  (:metaclass mito:dao-table-class))

src/models/pages.lisp

@@ -0,0 +1,48 @@
+(in-package #:cl-user)
+(defpackage #:pages
+  (:use #:cl
+	#:ritherdon-archive.db
+	#:mito
+	#:app-constants)
+  (:export #:page))
+(in-package #:pages)
+
+(defclass page ()
+  ((title
+    :documentation "The title of the page."
+    :col-type (or :text :null)
+    :initarg :title
+    :initform :title
+    :accessor title-of)
+   
+   (slug
+    :documentation "The slugified version of the page `TITLE'. This is what is
+    used when constructing links and accessing the page from the browser."
+    :col-type (or :text :null)
+    :initarg :slug
+    :initform :null
+    :accessor slug-of)
+
+   (enable-nav-menu
+    :documentation
+    "Boolean value stating if `PAGE' should be included on site's nav. menu."
+    :col-type (or :integer :null)
+    :initarg :enable-nav-menu
+    :initform +false+ ;SQLite 0 -> false 1 -> true.
+    :accessor enable-nav-menu-p)
+
+   (can-delete
+    :documentation
+    "Specifies if the page can be deleted from the database. This is for
+    'hard-coded' pages such as the 'archive' and 'pages'. The user won't make
+    these pages they come as part of the website which the use can add to the
+    nav. menu."
+    :col-type (or :integer :null)
+    :initarg :can-delete
+    :initform +false+ ;SQLite 0 -> false 1 -> true.
+    :accessor can-delete-p))
+  
+  (:documentation "`PAGE' represents the meta-data for the pages made by the
+  `USER' which are stored in the database. The actual pages are stored in the
+  /storage/pages directory.")
+  (:metaclass mito:dao-table-class))

src/models/site-settings.lisp

@@ -0,0 +1,50 @@
+(in-package #:cl-user)
+(defpackage #:site-settings
+  (:use #:cl
+	#:ritherdon-archive.db
+	#:mito
+	#:app-constants)
+  (:export #:site-settings
+	   #:nav-menu))
+
+(in-package #:site-settings)
+
+(defclass site-settings ()
+  ((enable-sign-up
+    :documentation "Allow non-registered users to create accounts."
+    :col-type (or :integer :null)
+    :initarg :enable-sign-up
+    :initform +true+ ; SQLite: 0 -> false 1 -> true.
+    :accessor enable-sign-up-p)
+
+   (enable-site-logo
+    :documentation "Show site logo in website's header."
+    :col-type (or :integer :null)
+    :initarg :enable-site-logo
+    :initform +true+ ; SQLite: 0 -> false 1 -> true.
+    :accessor enable-site-logo-p)
+
+   (site-name
+    :documentation "The name of the site, shown in website's header."
+    :col-type (or :text :null)
+    :initarg :site-name
+    :initform "NERA"
+    :accessor site-name-of)
+
+   (home-page
+    :documentation "The page (found in /storage/pages) which is rendered for '/' defroute."
+    :col-type (or :text :null)
+    :initarg :home-page
+    :initform "home"
+    :accessor home-page-of)
+
+   (search-url
+    :documentation "The URL for the Meilisearch instance this site calls out to
+    for it's search features."
+    :col-type (or :text :null)
+    :initarg :search-url
+    :initform "http://localhost:7700" ; Default Meilisearch URL.
+    :accessor search-url-of))
+  
+  (:documentation "Model used to track the site-wide settings -- stored in the database.")
+  (:metaclass mito:dao-table-class))

src/models/user.lisp

@@ -0,0 +1,41 @@
+(defpackage #:user
+  (:use #:cl
+	#:ritherdon-archive.db
+	#:mito
+	#:app-constants)
+  (:export #:user))
+(in-package #:user)
+
+(defclass user ()
+  ((username
+    :documentation "The name the user uses to log into the website."
+    :col-type :text
+    :initarg :username
+    :accessor username-of)
+   
+   (display-name
+    :documentation "The name used in the website GUI (the pretty name)."
+    :col-type :text
+    :initarg :display-name
+    :accessor display-name-of)
+
+   (password
+    :documentation "The user's password."
+    :col-type :text
+    :initarg :password
+    :accessor password-of)
+
+  (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))

src/nera.lisp

@@ -0,0 +1,416 @@
+(in-package #:cl-user)
+(defpackage #:nera-db
+  (:nicknames #:nera)
+  (:use #:cl
+	#:app-constants
+	#:hermetic
+	#:ritherdon-archive.db
+	#:utils
+        #:validation
+	#:user
+	#:pages
+	#:files
+	#:site-settings
+	#:archive)
+  (:export #:init-db
+	   #:update-user
+	   #:get-user
+	   #:get-user-id
+	   #:delete-user
+	   #:create-user
+	   #:get-site-settings
+	   #:migrate-all
+	   #:get-all-users
+	   #:update-enable-sign-on-settings
+	   #:set-home-page
+	   #:update-enable-site-logo-setting
+	   #:update-site-name
+           #:update-search-url
+	   #:create-page
+	   #:update-page
+	   #:get-page
+	   #:delete-page
+	   #:get-all-pages
+	   #:nav-menu-slugs
+	   #:update-nav-menu
+	   #:system-data
+	   #:add-storage-file
+	   #:get-storage-file
+	   #:get-all-storage-files
+	   #:rename-storage-file
+	   #:delete-storage-file
+	   #:get-all-archive-entries
+	   #:create-archive-entry
+	   #:get-archive-entry
+	   #:delete-archive-entry
+	   #:update-archive-entry-property
+	   #:latest-archive-editted-entries
+	   #:latest-editted-pages
+	   #:latest-storage-editted-files
+	   #:update-single-nav-menu-item
+           #:get-newer-archive-entries
+           #:get-older-archive-entries))
+(in-package #:nera-db)
+
+(defparameter *tables* '(user site-settings page storage-file archive-entry)
+  "List of the DB tables that need to be checked for migrations and DB setup.")
+
+(defun init-db (request)
+  "Creates the database and creates Admin. in `USER' table."
+  (destructuring-bind
+      (&key site-name allow-sign-up show-site-logo username display-name
+         password search-url &allow-other-keys)
+      (utils:request-params request)
+    (with-connection (db)
+      ;; Add to the list to add more tables.
+      (mapcar #'mito:ensure-table-exists *tables*)
+      (mito:create-dao 'user
+		       :username username
+		       :display-name display-name
+		       :password (hermetic::hash password)
+		       :administrator +true+)
+      (mito:create-dao 'site-settings
+                       :site-name site-name
+                       :search-url search-url
+		       :enable-sign-up (utils:checkbox-to-bool allow-sign-up)
+                       :enable-site-logo (utils:checkbox-to-bool show-site-logo))
+      (mito:create-dao 'page
+		       :title "Home"
+		       :slug "home"
+		       :enable-nav-menu +true+
+		       :can-delete +true+)
+      (mito:create-dao 'page
+		       :title "About"
+		       :slug "about"
+		       :enable-nav-menu +true+
+		       :can-delete +true+)
+      (mito:create-dao 'page
+		       :title "Contact"
+		       :slug "contact"
+		       :enable-nav-menu +true+
+		       :can-delete +true+)
+      (mito:create-dao 'page
+		       :title "Search"
+		       :slug "search"
+		       :enable-nav-menu +true+
+		       :can-delete +false+)
+      (mito:create-dao 'page
+		       :title "Pages"
+		       :slug "pages"
+		       :enable-nav-menu +true+
+		       :can-delete +false+)
+      (mito:create-dao 'page
+		       :title "Archive"
+		       :slug "archive"
+		       :enable-nav-menu +true+
+		       :can-delete +false+)
+      (mito:create-dao 'page
+		       :title "Sign-Up"
+		       :slug "sign-up"
+		       :enable-nav-menu +true+
+		       :can-delete +false+)
+      (mito:create-dao 'page
+		       :title "Log-In"
+		       :slug "login"
+		       :enable-nav-menu +true+
+		       :can-delete +false+))))
+
+(defun ensure-tables-exist ()
+  "Creates missing tables from the database."
+  (with-connection (db)
+    (mapcar #'mito:ensure-table-exists *tables*)))
+
+(defun migrate-all ()
+  "Migrate the tables after we changed the class definition."
+  (with-connection (db)
+    (ensure-tables-exist)
+    (mapcar #'mito:migrate-table *tables*)))
+
+(defun create-user (username display-name password administrator)
+  "Add a new `USER' to the database."
+  (with-connection (db)
+    (mito:create-dao 'user
+		     :username username
+		     :display-name display-name
+		     :administrator administrator
+		     :password (hermetic::hash password))))
+
+(defun delete-user (username)
+  "Deletes `USER' from the database."
+  (with-connection (db)
+    (mito:delete-by-values 'user:user :username username)))
+
+(defun update-user (username &key display-name new-password)
+  "Updates `USER' in database."
+  (with-connection (db)
+    (let ((user-to-update
+	    (mito:find-dao 'user:user :username username)))
+      (if (not (validation:string-is-nil-or-empty? display-name))
+	  (setf (user::display-name-of user-to-update) display-name))
+      (if (not (validation:string-is-nil-or-empty? new-password))
+	  (setf (user::password-of user-to-update) (hermetic::hash new-password)))
+      (mito:save-dao user-to-update))))
+
+(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 get-user (username)
+  "Returns a `USER' profile from the database."
+  (with-connection (db)
+    (mito:find-dao 'user :username username)))
+
+(defun get-all-users ()
+  "Returns a list of all `USER' entries in the database."
+  (with-connection (db)
+    (mito:select-dao 'user
+      (sxql:order-by (:asc :display-name)))))
+
+(defun get-page (slug)
+  "Returns a `PAGE' from the database."
+  (with-connection (db) (mito:find-dao 'page :slug slug)))
+
+(defun get-all-pages ()
+  "Returns a list of all `PAGE' entries in the database."
+  (with-connection (db)
+    (mito:select-dao 'page
+      (sxql:order-by (:asc :slug)))))
+
+(defun latest-editted-pages (amount &optional reverse)
+  "Gets the latest `AMOUNT' of edited entries from the database.
+`REVERSE' is an optional parameter which puts the most recently
+editted article entry as the first item in the list.."
+  (with-connection (db)
+    (mito:select-dao 'pages:page
+      (sxql:limit amount)
+      (if reverse
+	  (sxql:order-by (:desc 'pages::updated-at))
+	  (sxql:order-by 'pages::updated-at)))))
+
+(defun create-page (title slug nav-menu can-delete)
+  "Add a new `PAGE' to the database."
+  (with-connection (db)
+    (mito:create-dao 'page :title title :slug slug
+			   :enable-nav-menu nav-menu :can-delete can-delete)))
+
+(defun update-page (id title slug &optional nav-menu can-delete)
+  "Add a new `PAGE' to the database."
+  (with-connection (db)
+    (let ((page-to-update (mito:find-dao 'page :id id)))
+      (if (not (validation:string-is-nil-or-empty? title))
+	  (setf (pages::title-of page-to-update) title))
+      (if (not (validation:string-is-nil-or-empty? slug))
+	  (setf (pages::slug-of page-to-update) slug))
+      (if (not (null nav-menu))
+	  (setf (pages::enable-nav-menu-p page-to-update) nav-menu))
+      (if (not (null can-delete))
+	  (setf (pages::can-delete-p page-to-update) can-delete))
+      (mito:save-dao page-to-update))))
+
+(defun delete-page (&key id slug)
+  "Delete `PAGE' from the database."
+  (with-connection (db)
+    (cond ((not slug)
+	   (mito:delete-dao (mito:find-dao 'page :id id)))
+	  ((not id)
+	   (mito:delete-dao (mito:find-dao 'page :slug slug)))
+	  (t nil))))
+
+(defun get-site-settings ()
+  "Gets the settings for the website from the database."
+  (with-connection (db)
+    (mito:find-dao 'site-settings)))
+
+(defun update-enable-sign-on-settings (value)
+  "Updates the 'Enable Sign Up' setting in the database with `VALUE'."
+  (with-connection (db)
+    (let ((settings-to-update (mito:find-dao 'site-settings)))
+      (setf (site-settings::enable-sign-up-p settings-to-update)
+	    (utils:checkbox-to-bool value))
+      (mito:save-dao settings-to-update))))
+
+(defun update-enable-site-logo-setting (value)
+  "Updates the 'Enable Site Logo' setting in the database with `VALUE'."
+  (with-connection (db)
+    (let ((settings-to-update (mito:find-dao 'site-settings)))
+      (setf (site-settings::enable-site-logo-p settings-to-update)
+	    (utils:checkbox-to-bool value))
+      (mito:save-dao settings-to-update))))
+
+(defun set-home-page (value)
+  "Sets the page (in /storage/pages) to be displayed on the sites home page."
+  (with-connection (db)
+    (let ((settings-to-update (mito:find-dao 'site-settings)))
+      (setf (site-settings::home-page-of settings-to-update) value)
+      (mito:save-dao settings-to-update))))
+
+(defun update-search-url (search-url)
+  "Sets the page (in /storage/pages) to be displayed on the sites home page."
+  (with-connection (db)
+    (let ((settings-to-update (mito:find-dao 'site-settings)))
+      (setf (site-settings::search-url-of settings-to-update) search-url)
+      (mito:save-dao settings-to-update))))
+
+(defun update-site-name (name)
+  "Updates the website's `SITE-NAME' the database."
+  (with-connection (db)
+    (let ((settings-to-update (mito:find-dao 'site-settings)))
+      (setf (site-settings::site-name-of settings-to-update) name)
+      (mito:save-dao settings-to-update))))
+
+(defun update-nav-menu (selected-pages)
+  "Updates the `ENABLE-NAV-MENU' property in `PAGE' database."
+  (loop for page in selected-pages
+	do (with-connection (db)
+	     (let ((page-to-update (mito:find-dao 'page :slug (car page))))
+	       (setf (pages::enable-nav-menu-p page-to-update)
+		     (utils:checkbox-to-bool (cdr page)))
+	       (mito:save-dao page-to-update)))))
+
+(defun update-single-nav-menu-item (slug show-in-nav)
+  "Toggles a single page from the navigation menu."
+  (with-connection (db)
+    (let ((page-to-update (mito:find-dao 'page :slug slug)))
+      (setf (pages::enable-nav-menu-p page-to-update) show-in-nav)
+	    ;; (utils:checkbox-to-bool show-in-nav))
+      (mito:save-dao page-to-update))))
+
+(defun nav-menu-slugs ()
+  (with-connection (db)
+    (mito:select-dao 'page
+      (sxql:where (:= :enable-nav-menu +true+)))))
+
+(defun system-data ()
+  "Gets the website's settings and nav-menu from database."
+  (list (get-site-settings) (nav-menu-slugs)))
+
+(defun add-storage-file (filename slug file-type)
+  "Add a row to the 'storage_file' table in the database."
+  (with-connection (db)
+    (mito:create-dao 'storage-file
+		     :name filename
+		     :slug slug
+		     :file-type file-type)))
+
+(defun get-storage-file (&key filename slug)
+  "Returns a `STORAGE-FILE' row from the database. `NIL' if nothing found."
+  (with-connection (db)
+    (if (null slug)
+	(mito:find-dao 'files:storage-file :name filename)
+	(mito:find-dao 'files:storage-file :slug slug))))
+
+(defun latest-storage-editted-files (amount &optional reverse)
+  "Gets the latest `AMOUNT' of edited entries from the database.
+`REVERSE' is an optional parameter which puts the most recently
+editted article entry as the first item in the list.."
+  (with-connection (db)
+    (mito:select-dao 'storage-file
+      (sxql:limit amount)
+      (if reverse
+	  (sxql:order-by (:desc 'storage::updated-at))
+	  (sxql:order-by 'storage::updated-at)))))
+
+(defun get-all-storage-files ()
+  "Returns a list of all `STORAGE-FILES' entries in the database."
+  (with-connection (db)
+    (mito:select-dao 'storage-file
+      (sxql:order-by (:asc :name)))))
+
+(defun rename-storage-file (old-file-name new-file-name)
+  "Renames `STORAGE-FILE' in the database.
+The `NAME' is renamed from `OLD-FILE-NAME' to `NEW-FILE-NAME' and the
+slug is updated based on `NEW-FILE-NAME'."
+  (with-connection (db)
+    (let ((file-to-rename (mito:find-dao 'storage-file :name old-file-name)))
+      (setf (files::name-of file-to-rename) new-file-name
+	    (files::slug-of file-to-rename) (utils:slugify new-file-name))
+      (mito:save-dao file-to-rename))))
+
+(defun delete-storage-file (&key name slug)
+  "Delete `STORAGE-FILE' from database."
+  (with-connection (db)
+    (if (null slug)
+	(mito:delete-by-values 'files:storage-file :name name)
+	(mito:delete-by-values 'files:storage-file :slug slug))))
+
+(defun get-all-archive-entries ()
+  "Returns a list of all `ARCHIVE-ENTRY' entries in the database."
+  (with-connection (db)
+    (mito:select-dao 'archive:archive-entry
+      (sxql:order-by (:desc :created-at)))))
+
+(defun create-archive-entry
+    (title search-id slug pub-month pub-year thumbnail-slug thumbnail-file-type keywords)
+  "Add a new `ARCHIVE-ENTRY' to the database."
+  (with-connection (db)
+    (mito:create-dao 'archive:archive-entry
+		     :title title
+		     :search-id search-id
+		     :slug slug
+                     :month pub-month
+                     :year pub-year
+		     :thumbnail-slug thumbnail-slug
+		     :thumbnail-file-type thumbnail-file-type
+		     :keywords keywords)))
+
+(defun get-archive-entry (&key id title slug)
+  "Returns a `ARCHIVE-ENTRY' from the database."
+  (with-connection (db)
+    (cond ((and (not title) (not slug))
+	   (mito:find-dao 'archive:archive-entry :id id))
+	  ((and (not id) (not slug))
+	   (mito:find-dao 'archive:archive-entry :title title))
+	  ((and (not id) (not title))
+	   (mito:find-dao 'archive:archive-entry :slug slug))
+	  (t nil))))
+
+(defun latest-archive-editted-entries (amount &optional reverse)
+  "Gets the latest `AMOUNT' of edited entries from the database.
+`REVERSE' is an optional parameter which puts the most recently
+editted article entry as the first item in the list.."
+  (with-connection (db)
+    (mito:select-dao 'archive:archive-entry
+      (sxql:limit amount)
+      (if reverse
+	  (sxql:order-by (:desc 'archive::updated-at))
+	  (sxql:order-by 'archive::updated-at)))))
+
+(defun update-archive-entry-property (&key slug property value)
+  "Updates an `ARCHIVE-ENTRY' entry in database.
+An example of how to use this function is as follows (remove back-slashes):
+
+(nera:update-archive-entry-property
+  :slug \"edit-archive-test.html\"
+  :propery 'archive::keywords-of
+  :value \"test,image\")"
+  (with-connection (db)
+    (let ((entry-to-update
+	    (mito:find-dao 'archive:archive-entry :slug slug)))
+      (eval `(setf (,property ,entry-to-update) ,value))
+      (mito:save-dao entry-to-update))))
+
+(defun delete-archive-entry (&key id slug)
+  "Delete `ARCHIVE-ENTRY' from the database."
+  (with-connection (db)
+    (cond ((not slug)
+	   (mito:delete-dao (mito:find-dao 'archive:archive-entry :id id)))
+	  ((not id)
+	   (mito:delete-dao (mito:find-dao 'archive:archive-entry :slug slug))))))
+
+(defun get-newer-archive-entries (id amount)
+  "Returns `AMOUNT' of `ARCHIVE-ENTRY' objects relative to `ID' in database."
+  (with-connection (db)
+    (mito:select-dao 'archive:archive-entry
+      (sxql:where (:> :id id))
+      (sxql:order-by :id)
+      (sxql:limit amount))))
+
+(defun get-older-archive-entries (id amount)
+  "Returns `AMOUNT' of `ARCHIVE-ENTRY' objects relative to `ID' in database."
+  (with-connection (db)
+    (mito:select-dao 'archive:archive-entry
+      (sxql:where (:< :id id))
+      (sxql:order-by (:desc :id))
+      (sxql:limit amount))))

src/search.lisp

@@ -0,0 +1,185 @@
+(defpackage #:search
+  (:use #:cl
+	#:app-constants
+        #:archive
+	#:cl-json
+	#:local-time
+        #:utils
+        #:site-settings
+        #:nera)
+  (:import-from #:dexador
+		#:request)
+  (:export #:build-keywords-string
+	   #:build-payload
+	   #:delete-entry
+	   #:find-entry
+	   #:get-id
+	   #:get-keywords
+	   #:submit-entry
+           #:set-filter-attributes
+           #:delete-all-entries
+           #:create-dump
+           #:update-ranking-rules
+           #:repopulate-database
+           #:delete-index))
+(in-package #:search)
+
+;; Explains the "~{~A~^,~}" in the format call below. 
+;; https://stackoverflow.com/questions/8830888/whats-the-canonical-way-to-join-strings-in-a-list
+(defun build-keywords-string (id)
+  "Gets the keywords for `ID' in meilisearch DB and formats into a string.
+The string should look something like: 'art,blog post,testing,whatever'. One
+thing to note is meilisearch uses the comma to separate and create tokens of the
+string. So, the user can have spaces in their keywords but they cannot separate
+the keywords with a space. 'art blog post' is classed as three tokens and
+'art,blog post' is classes as two."
+  (format nil "~{~A~^,~}" (search:get-keywords (search:find-entry id))))
+
+(defun build-payload (id-value title-value relative-path-value
+                      thumbnail-path-value publish-month-value publish-year-value keywords-value)
+  "Creates a JSON object which reflects the schema in the meilsearch database.
+Note: The JSON object to encoded as a string."
+  (cl-json:encode-json-to-string
+   `((("id"             . ,id-value)
+      ("title"          . ,title-value)
+      ("relative-path"  . ,relative-path-value)
+      ("thumbnail-path" . ,thumbnail-path-value)
+      ("year"           . ,publish-year-value)
+      ("month"          . ,publish-month-value)
+      ("keywords"       . ,(cl-ppcre:split "," keywords-value))))))
+
+(defun build-search-url (path)
+  "Constructs the URL to connect to the meilisearch instance (beta or prod.)
+The function will check to see which environment the current instance of this
+site is running in and use the beta or prod. URL's to connect to meilisearch.
+`PATH' is the relative path which this function will concatenate onto the end of
+the base URL."
+
+  ;; (if (ritherdon-archive.config:developmentp)
+  ;;     (concatenate 'string "http://localhost:7700" path)
+  ;;     ;; (utils:build-url-root)
+  ;;     (concatenate 'string "https://www.nera.com" path))
+
+  (format nil "~a~a" (site-settings::search-url-of (nera:get-site-settings)) path))
+
+(defun delete-entry (id)
+  "Deletes and entry from the meilisearch database based on its `ID'.
+This does not affect this website's (nera) database -- only the meilisearch
+one."
+  (dexador:request 
+   (build-search-url
+    (format nil "/indexes/nera/documents/~a" id)); (get-id (find-entry id))))
+    :method :delete
+    :use-connection-pool nil
+    :headers `(("Authorization" . ,(meilisearch-api-key)))
+    :verbose nil))
+
+
+(defun documents-total ()
+  "Gets the total number of documents in the meilisearch database."
+  (rest
+   (second
+    (second
+     (assoc :indexes (cl-json:decode-json-from-string
+		      (dexador:request (build-search-url "/stats")
+				       :method :get
+				       :use-connection-pool nil
+				       :headers `(("Content-Type" . "application/json")
+						  ("Authorization" . ,(meilisearch-api-key)))
+				       :verbose nil)))))))
+
+(defun find-entry (title)
+  "Finds the entry in the meilisearch database by its `TITLE'."
+  (cl-json:decode-json-from-string
+   (dexador:request
+    (build-search-url "/indexes/nera/search")
+    :method :post
+    :use-connection-pool nil
+    :headers `(("Content-Type" . "application/json")
+	       ("Authorization" . ,(meilisearch-api-key)))
+    :content (format nil "{ \"q\": \"~a\", \"limit\": 1 }" title)
+    :verbose nil)))
+
+(defun get-id (payload)
+  "Gets the id from the JSON `PAYLOAD', make sure limit is set to 1."
+  (rest (third (second (first payload)))))
+
+(defun get-keywords (payload)
+  "Get the keywords from the JSON `PAYLOAD'."
+  (rest (first (last (last (second (first payload)))))))
+
+(defun meilisearch-api-key ()
+  "Returns either the beta or prod. API key for meilisearch.
+The API key is determined based on which environment this website is
+currently running in."
+  (if (ritherdon-archive.config:developmentp)
+      "Bearer meilisearch-beta-key"
+      "Bearer meilisearch-key"))
+
+(defun submit-entry (payload)
+  "Adds a new article to the meilisearch database."
+  (dexador:request ;;"http://127.0.0.1:7700/indexes/nera/documents"
+		   (build-search-url "/indexes/nera/documents")
+		   :method :post
+		   :use-connection-pool nil
+		   :headers `(("Content-Type" . "application/json")
+			      ("Authorization" . ,(meilisearch-api-key)))
+		   :content payload
+		   :verbose nil))
+
+(defun set-filter-attributes ()
+  "Sets the filter attributes in the Meilisearch database. 
+These values are hard-coded into the system because they are based on what Nic
+has requested. She would like the filtering to consist on years and months."
+  (utils:run-bash-command
+   (format nil "curl -X PATCH \'~a\' -H \'Authorization: ~a\' -H \'Content-Type: application/json\' --data-binary \'{ \"filterableAttributes\": [ \"year\", \"month\", \"keywords\" ]}\'"
+           (build-search-url "/indexes/nera/settings") (meilisearch-api-key))))
+
+(defun delete-all-entries ()
+  "Deletes all the archive entries in the Meilisearch database -- not the DB."
+  (utils:run-bash-command
+   (format nil "curl -X DELETE \'~a\'"
+           (build-search-url "/indexes/nera/documents"))))
+
+(defun create-dump ()
+  "Creates a dump of the Meilisearch database."
+  (utils:run-bash-command
+   (format nil "curl -X POST \'~a\'" (build-search-url "/dumps"))))
+
+(defun update-ranking-rules ()
+  "Updates the way Meilisearch ranks and orders the search results.
+The main intention for this function is to show the latest entries into the
+database first (when no search term is entered by the user)."
+  (utils:run-bash-command
+   (format nil "curl -X PATCH \'~a\' -H \'Authorization: ~a\' -H \'Content-Type: application/json\' --data-binary \'[ \"words\", \"typo\", \"proximity\", \"attribute\", \"sort\", \"exactness\",\"rank:asc\", \"year:desc\" ]\'"
+           (build-search-url "/indexes/nera/settings") (meilisearch-api-key))))
+
+(defun repopulate-database (archive-entries)
+  "Empties the Meilisearch database and populates it with `ARCHIVE-ENTRIES'."
+  (delete-all-entries)
+  (loop for entry in archive-entries
+        do
+           (submit-entry
+            (build-payload (archive::search-id-of entry)
+                           (archive::title-of entry)
+                           (format nil "view/archive/~a"
+                                   (archive::slug-of entry))
+                            (format nil "storage/thumb/archive/~a"
+                                    (archive::slug-of entry))
+                           (archive::month-of entry)
+                           (archive::year-of entry)
+                           (archive::keywords-of entry)))))
+
+(defun delete-index (index-name)
+  "Deletes `INDEX-NAME' in Meilisearch DB, doesn't need to be this project.
+Because Meilisearch is a seperate service running alongside this website, it can
+host searchable databases for other projects on the system. `INDEX-NAME' refers
+to those other databases.  
+
+I have not hard-coded this project's database name into this function out of
+convenience. I can call this function from SLIME/SLY and clean-up my Meilisearch
+dev. instance. It, also, helps if I've made botched this project's DB with an
+incorrect name and need to quickly delete it."
+  (utils:run-bash-command
+   (format nil "curl -X DELETE \'~a\'"
+           (build-search-url (format nil "/indexes/~a" index-name)))))

src/snapshot.lisp

@@ -0,0 +1,62 @@
+(in-package #:cl-user)
+(defpackage #:snapshot
+  (:use #:cl
+        #:utils
+        #:storage
+        #:nera)
+  (:export
+   #:take-snapshot
+   #:restore-from-snapshot
+   #:delete-snapshot
+   #:store-snapshot))
+(in-package #:snapshot)
+
+(defun take-snapshot ()
+  "Takes a Snapshot of the website's data and stores it in /snapshots.
+I've not included make a SQL dump of the Meilisearch database here because the
+user can repopulate that database after they have restored this website. The
+'repopulate' feature is built into the website already."
+  (let ((snapshot-directory
+          (format nil "~a_~a/"
+                  (utils:slugify
+                   (site-settings::site-name-of (nera:get-site-settings)))
+                  (utils:create-timestamp-text))))
+    (storage:ensure-raw-directory-exists
+     (format nil "snapshots/~a" snapshot-directory))
+    (storage:copy-storage-directory
+     (format nil "snapshots/~a/storage/" snapshot-directory))
+    (storage:copy-raw-directory
+     "db/" (format nil "snapshots/~a/db/" snapshot-directory))))
+
+(defun restore-from-snapshot (snapshot-name)
+  "Deletes the data in /storage and the DB and replaces it with `SNAPSHOT-NAME'."
+  (storage:remove-raw-directory "storage/")
+  (storage:remove-raw-directory "db/")
+  (storage:copy-raw-directory (format nil "snapshots/~a/storage/" snapshot-name) "storage/")
+  (storage:copy-raw-directory (format nil "snapshots/~a/db/" snapshot-name) "db/"))
+
+(defun delete-snapshot (snapshot-name)
+  "Deletes the snapshot in the /snapshots directory with `SNAPSHOT-NAME'."
+  (storage:remove-raw-directory (format nil "snapshots/~a/" snapshot-name)))
+
+(defun store-snapshot (filename data)
+  "Unzips `SNAPSHOT-FILE' and stores it in /snapshots directory.
+
+The .zip file is deleted after it has been un-zipped. I did think about moving
+the zipped version of the file into the /storage/media directory but there is
+too much second guessing going on. I found I was uploading .zip files from the
+/storage/media directory and I don't know if users will be uploading .zip files
+they had just downloaded from /storage/media. If that is the case, then there
+is:
+
+a.) No need to move it to /storage/madia;
+b.) Extra work regarding checks for duplicate entries; and,
+c.) I don't know if that is too much 'magic' for users and cause confusion.
+
+If the user is in a paniced state -- trying to restore their website, confusion
+is the thing I want to keep to a minimum for them."
+  (storage:store-with-raw-path (format nil "snapshots/~a" filename) data)
+  (zip:unzip (storage:make-raw-path (format nil"snapshots/~a" filename))
+             (storage:make-raw-path (format nil "snapshots/~a/"
+                                            (pathname-name filename))))
+  (storage:remove-file-with-raw-path (format nil "snapshots/~a" filename)))

src/status-codes.lisp

@@ -0,0 +1,498 @@
+(in-package #:cl-user)
+(defpackage #:status-codes
+  (:use #:cl
+	#:app-constants)
+  (:nicknames #:rfc2616-sec10)
+  (:export +continue+
+           +switching-protocols+
+           +ok+
+           +created+
+           +accepted+
+           +non-authoritative-information+
+           +no-content+
+           +reset-content+
+           +partial-content+
+           +multiple-choices+
+           +moved-permanently+
+           +found+
+           +see-other+
+           +not-modified+
+           +use-proxy+
+           +temporary-redirect+
+           +bad-request+
+           +unauthorized+
+           +payment-required+
+           +forbidden+
+           +not-found+
+           +method-not-allowed+
+           +not-acceptable+
+           +proxy-authentication-required+
+           +request-timeout+
+           +conflict+
+           +gone+
+           +length-required+
+           +precondition-failed+
+           +request-entity-too-large+
+           +request-uri-too-long+
+           +unsupported-media-type+
+           +requested-range-not-satisfiable+
+           +expectation-failed+
+           +internal-server-error+
+           +not-implemented+
+           +bad-gateway+
+           +service-unavailable+
+           +gateway-timeout+
+           +http-version-not-supported+))
+(in-package #:status-codes)
+
+#| On Using `DEFINE-CONSTANT' Macro
+================================================================================
+I've defined the `DEFINE-CONSTANT' in 'app-constants.lisp' I've explained the
+reason why I've using it instead of `DEFCONSTANT' there. The short-story is
+`DEFINE-CONSTANT' is easier to work with when using SBCL.
+|#
+
+(define-constant +continue+ 100
+  "The client SHOULD continue with its request. This interim response is
+   used to inform the client that the initial part of the request has
+   been received and has not yet been rejected by the server. The client
+   SHOULD continue by sending the remainder of the request or, if the
+   request has already been completed, ignore this response. The server
+   MUST send a final response after the request has been completed. See
+   section 8.2.3 for detailed discussion of the use and handling of this
+   status code.")
+(define-constant +switching-PROTOCOLS+ 101
+  "The server understands and is willing to comply with the client's
+   request, via the Upgrade message header field (section 14.42), for a
+   change in the application protocol being used on this connection. The
+   server will switch protocols to those defined by the response's
+   Upgrade header field immediately after the empty line which
+   terminates the 101 response.
+   The protocol SHOULD be switched only when it is advantageous to do
+   so. For example, switching to a newer version of HTTP is advantageous
+   over older versions, and switching to a real-time, synchronous
+   protocol might be advantageous when delivering resources that use
+   such features.")
+(define-constant +ok+ 200
+  "The request has succeeded. The information returned with the response
+   is dependent on the method used in the request, for example:
+   GET    an entity corresponding to the requested resource is sent in
+          the response;
+   HEAD   the entity-header fields corresponding to the requested
+          resource are sent in the response without any message-body;
+   POST   an entity describing or containing the result of the action;
+   TRACE  an entity containing the request message as received by the
+          end server.")
+(define-constant +created+ 201
+  "The request has been fulfilled and resulted in a new resource being
+   created. The newly created resource can be referenced by the URI(s)
+   returned in the entity of the response, with the most specific URI
+   for the resource given by a Location header field. The response
+   SHOULD include an entity containing a list of resource
+   characteristics and location(s) from which the user or user agent can
+   choose the one most appropriate. The entity format is specified by
+   the media type given in the Content-Type header field. The origin
+   server MUST create the resource before returning the 201 status code.
+   If the action cannot be carried out immediately, the server SHOULD
+   respond with 202 (Accepted) response instead.
+   A 201 response MAY contain an ETag response header field indicating
+   the current value of the entity tag for the requested variant just
+   created, see section 14.19.")
+(define-constant +accepted+ 202
+  "The request has been accepted for processing, but the processing has
+   not been completed.  The request might or might not eventually be
+   acted upon, as it might be disallowed when processing actually takes
+   place. There is no facility for re-sending a status code from an
+   asynchronous operation such as this.
+   The 202 response is intentionally non-committal. Its purpose is to
+   allow a server to accept a request for some other process (perhaps a
+   batch-oriented process that is only run once per day) without
+   requiring that the user agent's connection to the server persist
+   until the process is completed. The entity returned with this
+   response SHOULD include an indication of the request's current status
+   and either a pointer to a status monitor or some estimate of when the
+   user can expect the request to be fulfilled.")
+(define-constant +non-authoritative-information+ 203
+  "The returned metainformation in the entity-header is not the
+   definitive set as available from the origin server, but is gathered
+   from a local or a third-party copy. The set presented MAY be a subset
+   or superset of the original version. For example, including local
+   annotation information about the resource might result in a superset
+   of the metainformation known by the origin server. Use of this
+   response code is not required and is only appropriate when the
+   response would otherwise be 200 (OK).")
+(define-constant +no-content+ 204
+  "The server has fulfilled the request but does not need to return an
+   entity-body, and might want to return updated metainformation. The
+   response MAY include new or updated metainformation in the form of
+   entity-headers, which if present SHOULD be associated with the
+   requested variant.
+   If the client is a user agent, it SHOULD NOT change its document view
+   from that which caused the request to be sent. This response is
+   primarily intended to allow input for actions to take place without
+   causing a change to the user agent's active document view, although
+   any new or updated metainformation SHOULD be applied to the document
+   currently in the user agent's active view.
+   The 204 response MUST NOT include a message-body, and thus is always
+   terminated by the first empty line after the header fields.")
+(define-constant +reset-content+ 205
+  "The server has fulfilled the request and the user agent SHOULD reset
+   the document view which caused the request to be sent. This response
+   is primarily intended to allow input for actions to take place via
+   user input, followed by a clearing of the form in which the input is
+   given so that the user can easily initiate another input action. The
+   response MUST NOT include an entity.")
+(define-constant +partial-content+ 206
+  "The server has fulfilled the partial GET request for the resource.
+   The request MUST have included a Range header field (section 14.35)
+   indicating the desired range, and MAY have included an If-Range
+   header field (section 14.27) to make the request conditional.
+   The response MUST include the following header fields:
+      - Either a Content-Range header field (section 14.16) indicating
+        the range included with this response, or a multipart/byteranges
+        Content-Type including Content-Range fields for each part. If a
+        Content-Length header field is present in the response, its
+        value MUST match the actual number of OCTETs transmitted in the
+        message-body.
+      - Date
+      - ETag and/or Content-Location, if the header would have been sent
+        in a 200 response to the same request
+      - Expires, Cache-Control, and/or Vary, if the field-value might
+        differ from that sent in any previous response for the same
+        variant
+   If the 206 response is the result of an If-Range request that used a
+   strong cache validator (see section 13.3.3), the response SHOULD NOT
+   include other entity-headers. If the response is the result of an
+   If-Range request that used a weak validator, the response MUST NOT
+   include other entity-headers; this prevents inconsistencies between
+   cached entity-bodies and updated headers. Otherwise, the response
+   MUST include all of the entity-headers that would have been returned
+   with a 200 (OK) response to the same request.
+   A cache MUST NOT combine a 206 response with other previously cached
+   content if the ETag or Last-Modified headers do not match exactly,
+   see 13.5.4.
+   A cache that does not support the Range and Content-Range headers
+   MUST NOT cache 206 (Partial) responses.")
+(define-constant +multiple-choices+ 300
+  "The requested resource corresponds to any one of a set of
+   representations, each with its own specific location, and agent-
+   driven negotiation information (section 12) is being provided so that
+   the user (or user agent) can select a preferred representation and
+   redirect its request to that location.
+   Unless it was a HEAD request, the response SHOULD include an entity
+   containing a list of resource characteristics and location(s) from
+   which the user or user agent can choose the one most appropriate. The
+   entity format is specified by the media type given in the Content-
+   Type header field. Depending upon the format and the capabilities of
+   the user agent, selection of the most appropriate choice MAY be
+   performed automatically. However, this specification does not define
+   any standard for such automatic selection.
+   If the server has a preferred choice of representation, it SHOULD
+   include the specific URI for that representation in the Location
+   field; user agents MAY use the Location field value for automatic
+   redirection. This response is cacheable unless indicated otherwise.")
+(define-constant +moved-permanently+ 301
+  "The requested resource has been assigned a new permanent URI and any
+   future references to this resource SHOULD use one of the returned
+   URIs.  Clients with link editing capabilities ought to automatically
+   re-link references to the Request-URI to one or more of the new
+   references returned by the server, where possible. This response is
+   cacheable unless indicated otherwise.
+   The new permanent URI SHOULD be given by the Location field in the
+   response. Unless the request method was HEAD, the entity of the
+   response SHOULD contain a short hypertext note with a hyperlink to
+   the new URI(s).
+   If the 301 status code is received in response to a request other
+   than GET or HEAD, the user agent MUST NOT automatically redirect the
+   request unless it can be confirmed by the user, since this might
+   change the conditions under which the request was issued.
+      Note: When automatically redirecting a POST request after
+      receiving a 301 status code, some existing HTTP/1.0 user agents
+      will erroneously change it into a GET request.")
+(define-constant +found+ 302
+  "The requested resource resides temporarily under a different URI.
+   Since the redirection might be altered on occasion, the client SHOULD
+   continue to use the Request-URI for future requests.  This response
+   is only cacheable if indicated by a Cache-Control or Expires header
+   field.
+   The temporary URI SHOULD be given by the Location field in the
+   response. Unless the request method was HEAD, the entity of the
+   response SHOULD contain a short hypertext note with a hyperlink to
+   the new URI(s).
+   If the 302 status code is received in response to a request other
+   than GET or HEAD, the user agent MUST NOT automatically redirect the
+   request unless it can be confirmed by the user, since this might
+   change the conditions under which the request was issued.
+      Note: RFC 1945 and RFC 2068 specify that the client is not allowed
+      to change the method on the redirected request.  However, most
+      existing user agent implementations treat 302 as if it were a 303
+      response, performing a GET on the Location field-value regardless
+      of the original request method. The status codes 303 and 307 have
+      been added for servers that wish to make unambiguously clear which
+      kind of reaction is expected of the client.")
+(define-constant +see-other+ 303
+  "The response to the request can be found under a different URI and
+   SHOULD be retrieved using a GET method on that resource. This method
+   exists primarily to allow the output of a POST-activated script to
+   redirect the user agent to a selected resource. The new URI is not a
+   substitute reference for the originally requested resource. The 303
+   response MUST NOT be cached, but the response to the second
+   (redirected) request might be cacheable.
+   The different URI SHOULD be given by the Location field in the
+   response. Unless the request method was HEAD, the entity of the
+   response SHOULD contain a short hypertext note with a hyperlink to
+   the new URI(s).
+      Note: Many pre-HTTP/1.1 user agents do not understand the 303
+      status. When interoperability with such clients is a concern, the
+      302 status code may be used instead, since most user agents react
+      to a 302 response as described here for 303.")
+(define-constant +not-modified+ 304
+  "If the client has performed a conditional GET request and access is
+   allowed, but the document has not been modified, the server SHOULD
+   respond with this status code. The 304 response MUST NOT contain a
+   message-body, and thus is always terminated by the first empty line
+   after the header fields.
+   The response MUST include the following header fields:
+      - Date, unless its omission is required by section 14.18.1
+   If a clockless origin server obeys these rules, and proxies and
+   clients add their own Date to any response received without one (as
+   already specified by [RFC 2068], section 14.19), caches will operate
+   correctly.
+      - ETag and/or Content-Location, if the header would have been sent
+        in a 200 response to the same request
+      - Expires, Cache-Control, and/or Vary, if the field-value might
+        differ from that sent in any previous response for the same
+        variant
+   If the conditional GET used a strong cache validator (see section
+   13.3.3), the response SHOULD NOT include other entity-headers.
+   Otherwise (i.e., the conditional GET used a weak validator), the
+   response MUST NOT include other entity-headers; this prevents
+   inconsistencies between cached entity-bodies and updated headers.
+   If a 304 response indicates an entity not currently cached, then the
+   cache MUST disregard the response and repeat the request without the
+   conditional.
+   If a cache uses a received 304 response to update a cache entry, the
+   cache MUST update the entry to reflect any new field values given in
+   the response.")
+(define-constant +use-proxy+ 305
+  "The requested resource MUST be accessed through the proxy given by
+   the Location field. The Location field gives the URI of the proxy.
+   The recipient is expected to repeat this single request via the
+   proxy. 305 responses MUST only be generated by origin servers.
+      Note: RFC 2068 was not clear that 305 was intended to redirect a
+      single request, and to be generated by origin servers only.  Not
+      observing these limitations has significant security consequences.")
+(define-constant +temporary-redirect+ 307
+  "The requested resource resides temporarily under a different URI.
+   Since the redirection MAY be altered on occasion, the client SHOULD
+   continue to use the Request-URI for future requests.  This response
+   is only cacheable if indicated by a Cache-Control or Expires header
+   field.
+   The temporary URI SHOULD be given by the Location field in the
+   response. Unless the request method was HEAD, the entity of the
+   response SHOULD contain a short hypertext note with a hyperlink to
+   the new URI(s) , since many pre-HTTP/1.1 user agents do not
+   understand the 307 status. Therefore, the note SHOULD contain the
+   information necessary for a user to repeat the original request on
+   the new URI.
+   If the 307 status code is received in response to a request other
+   than GET or HEAD, the user agent MUST NOT automatically redirect the
+   request unless it can be confirmed by the user, since this might
+   change the conditions under which the request was issued.")
+(define-constant +bad-request+ 400
+  "The request could not be understood by the server due to malformed
+   syntax. The client SHOULD NOT repeat the request without
+   modifications.")
+(define-constant +unauthorized+ 401
+  "The request requires user authentication. The response MUST include a
+   WWW-Authenticate header field (section 14.47) containing a challenge
+   applicable to the requested resource. The client MAY repeat the
+   request with a suitable Authorization header field (section 14.8). If
+   the request already included Authorization credentials, then the 401
+   response indicates that authorization has been refused for those
+   credentials. If the 401 response contains the same challenge as the
+   prior response, and the user agent has already attempted
+   authentication at least once, then the user SHOULD be presented the
+   entity that was given in the response, since that entity might
+   include relevant diagnostic information. HTTP access authentication
+   is explained in \"HTTP Authentication: Basic and Digest Access
+   Authentication\" [43].")
+(define-constant +payment-required+ 402
+  "This code is reserved for future use.")
+(define-constant +forbidden+ 403
+  "The server understood the request, but is refusing to fulfill it.
+   Authorization will not help and the request SHOULD NOT be repeated.
+   If the request method was not HEAD and the server wishes to make
+   public why the request has not been fulfilled, it SHOULD describe the
+   reason for the refusal in the entity.  If the server does not wish to
+   make this information available to the client, the status code 404
+   (Not Found) can be used instead.")
+(define-constant +not-found+ 404
+  "The server has not found anything matching the Request-URI. No
+   indication is given of whether the condition is temporary or
+   permanent. The 410 (Gone) status code SHOULD be used if the server
+   knows, through some internally configurable mechanism, that an old
+   resource is permanently unavailable and has no forwarding address.
+   This status code is commonly used when the server does not wish to
+   reveal exactly why the request has been refused, or when no other
+   response is applicable.")
+(define-constant +method-not-allowed+ 405
+  "The method specified in the Request-Line is not allowed for the
+   resource identified by the Request-URI. The response MUST include an
+   Allow header containing a list of valid methods for the requested
+   resource.")
+(define-constant +not-acceptable+ 406
+  "The resource identified by the request is only capable of generating
+   response entities which have content characteristics not acceptable
+   according to the accept headers sent in the request.
+   Unless it was a HEAD request, the response SHOULD include an entity
+   containing a list of available entity characteristics and location(s)
+   from which the user or user agent can choose the one most
+   appropriate. The entity format is specified by the media type given
+   in the Content-Type header field. Depending upon the format and the
+   capabilities of the user agent, selection of the most appropriate
+   choice MAY be performed automatically. However, this specification
+   does not define any standard for such automatic selection.
+      Note: HTTP/1.1 servers are allowed to return responses which are
+      not acceptable according to the accept headers sent in the
+      request. In some cases, this may even be preferable to sending a
+      406 response. User agents are encouraged to inspect the headers of
+      an incoming response to determine if it is acceptable.
+   If the response could be unacceptable, a user agent SHOULD
+   temporarily stop receipt of more data and query the user for a
+   decision on further actions.")
+(define-constant +proxy-authentication-required+ 407
+  "This code is similar to 401 (Unauthorized), but indicates that the
+   client must first authenticate itself with the proxy. The proxy MUST
+   return a Proxy-Authenticate header field (section 14.33) containing a
+   challenge applicable to the proxy for the requested resource. The
+   client MAY repeat the request with a suitable Proxy-Authorization
+   header field (section 14.34). HTTP access authentication is explained
+   in \"HTTP Authentication: Basic and Digest Access Authentication\"
+   [43].")
+(define-constant +request-timeout+ 408
+  "The client did not produce a request within the time that the server
+   was prepared to wait. The client MAY repeat the request without
+   modifications at any later time.")
+(define-constant +conflict+ 409
+  "The request could not be completed due to a conflict with the current
+   state of the resource. This code is only allowed in situations where
+   it is expected that the user might be able to resolve the conflict
+   and resubmit the request. The response body SHOULD include enough
+   information for the user to recognize the source of the conflict.
+   Ideally, the response entity would include enough information for the
+   user or user agent to fix the problem; however, that might not be
+   possible and is not required.
+   Conflicts are most likely to occur in response to a PUT request. For
+   example, if versioning were being used and the entity being PUT
+   included changes to a resource which conflict with those made by an
+   earlier (third-party) request, the server might use the 409 response
+   to indicate that it can't complete the request. In this case, the
+   response entity would likely contain a list of the differences
+   between the two versions in a format defined by the response
+   Content-Type.")
+(define-constant +gone+ 410
+  "The requested resource is no longer available at the server and no
+   forwarding address is known. This condition is expected to be
+   considered permanent. Clients with link editing capabilities SHOULD
+   delete references to the Request-URI after user approval. If the
+   server does not know, or has no facility to determine, whether or not
+   the condition is permanent, the status code 404 (Not Found) SHOULD be
+   used instead. This response is cacheable unless indicated otherwise.
+   The 410 response is primarily intended to assist the task of web
+   maintenance by notifying the recipient that the resource is
+   intentionally unavailable and that the server owners desire that
+   remote links to that resource be removed. Such an event is common for
+   limited-time, promotional services and for resources belonging to
+   individuals no longer working at the server's site. It is not
+   necessary to mark all permanently unavailable resources as \"gone\" or
+   to keep the mark for any length of time -- that is left to the
+   discretion of the server owner.")
+(define-constant +length-required+ 411
+  "The server refuses to accept the request without a defined Content-
+   Length. The client MAY repeat the request if it adds a valid
+   Content-Length header field containing the length of the message-body
+   in the request message.")
+(define-constant +precondition-failed+ 412
+  "The precondition given in one or more of the request-header fields
+   evaluated to false when it was tested on the server. This response
+   code allows the client to place preconditions on the current resource
+   metainformation (header field data) and thus prevent the requested
+   method from being applied to a resource other than the one intended.")
+(define-constant +request-entity-too-large+ 413
+  "The server is refusing to process a request because the request
+   entity is larger than the server is willing or able to process. The
+   server MAY close the connection to prevent the client from continuing
+   the request.
+   If the condition is temporary, the server SHOULD include a Retry-
+   After header field to indicate that it is temporary and after what
+   time the client MAY try again.")
+(define-constant +request-uri-too-long+ 414
+  "The server is refusing to service the request because the Request-URI
+   is longer than the server is willing to interpret. This rare
+   condition is only likely to occur when a client has improperly
+   converted a POST request to a GET request with long query
+   information, when the client has descended into a URI \"black hole\" of
+   redirection (e.g., a redirected URI prefix that points to a suffix of
+   itself), or when the server is under attack by a client attempting to
+   exploit security holes present in some servers using fixed-length
+   buffers for reading or manipulating the Request-URI.")
+(define-constant +unsupported-media-type+ 415
+  "The server is refusing to service the request because the entity of
+   the request is in a format not supported by the requested resource
+   for the requested method.")
+(define-constant +requested-range-not-satisfiable+ 416
+  "A server SHOULD return a response with this status code if a request
+   included a Range request-header field (section 14.35), and none of
+   the range-specifier values in this field overlap the current extent
+   of the selected resource, and the request did not include an If-Range
+   request-header field. (For byte-ranges, this means that the first-
+   byte-pos of all of the byte-range-spec values were greater than the
+   current length of the selected resource.)
+   When this status code is returned for a byte-range request, the
+   response SHOULD include a Content-Range entity-header field
+   specifying the current length of the selected resource (see section
+   14.16). This response MUST NOT use the multipart/byteranges content-
+   type.")
+(define-constant +expectation-failed+ 417
+  "The expectation given in an Expect request-header field (see section
+   14.20) could not be met by this server, or, if the server is a proxy,
+   the server has unambiguous evidence that the request could not be met
+   by the next-hop server.")
+(define-constant +internal-server-error+ 500
+  "The server encountered an unexpected condition which prevented it
+   from fulfilling the request.")
+(define-constant +not-implemented+ 501
+  "The server does not support the functionality required to fulfill the
+   request. This is the appropriate response when the server does not
+   recognize the request method and is not capable of supporting it for
+   any resource.")
+(define-constant +bad-gateway+ 502
+  "The server, while acting as a gateway or proxy, received an invalid
+   response from the upstream server it accessed in attempting to
+   fulfill the request.")
+(define-constant +service-unavailable+ 503
+  "The server is currently unable to handle the request due to a
+   temporary overloading or maintenance of the server. The implication
+   is that this is a temporary condition which will be alleviated after
+   some delay. If known, the length of the delay MAY be indicated in a
+   Retry-After header. If no Retry-After is given, the client SHOULD
+   handle the response as it would for a 500 response.
+      Note: The existence of the 503 status code does not imply that a
+      server must use it when becoming overloaded. Some servers may wish
+      to simply refuse the connection.")
+(define-constant +gateway-timeout+ 504
+  "The server, while acting as a gateway or proxy, did not receive a
+   timely response from the upstream server specified by the URI (e.g.
+   HTTP, FTP, LDAP) or some other auxiliary server (e.g. DNS) it needed
+   to access in attempting to complete the request.
+      Note: Note to implementors: some deployed proxies are known to
+      return 400 or 500 when DNS lookups time out.")
+(define-constant +http-version-not-supported+ 505
+  "The server does not support, or refuses to support, the HTTP protocol
+   version that was used in the request message. The server is
+   indicating that it is unable or unwilling to complete the request
+   using the same major version as the client, as described in section
+   3.1, other than with this error message. The response SHOULD contain
+   an entity describing why that version is not supported and what other
+   protocols are supported by that server.")

src/storage.lisp

@@ -0,0 +1,317 @@
+(in-package #:cl-user)
+(defpackage #:storage
+  (:use #:cl
+        #:copy-directory)
+  (:export #:init-storage
+	   #:directory-exists-p
+	   #:ensure-directory-exists
+	   #:file-exists-p
+	   #:get-files-in-directory
+	   #:get-file-names
+	   #:make-path
+	   #:open-file
+	   #:open-binary-file
+	   #:open-text-file
+	   #:remove-directory
+	   #:remove-file
+	   #:rename-content-file
+	   #:rename-directory
+	   #:store-file
+	   #:store-text
+	   #:store-with-raw-path
+	   #:store-text-with-raw-path
+	   #:open-text-file-with-raw-path
+	   #:store-test
+           #:remove-file-with-raw-path
+           #:make-raw-path
+           #:ensure-raw-directory-exists
+           #:remove-raw-directory
+           #:copy-storage-directory
+           #:copy-raw-directory
+           #:get-files-in-raw-directory
+           #:get-raw-subdirectories
+           #:raw-directory-exists?))
+(in-package #:storage)
+
+(defun init-storage ()
+  "Copies the initial files into their default places.
+This is used as part of the /run-set defroute in web.lisp file."
+  (ensure-directory-exists "" "pages")
+  (uiop:copy-file (make-path "" "default-assets" "about")
+		  (make-path "" "pages" "about"))
+  
+  (uiop:copy-file (make-path "" "default-assets" "contact")
+		  (make-path "" "pages" "contact"))
+  
+  (uiop:copy-file (make-path "" "default-assets" "home")
+		  (make-path "" "pages" "home"))
+  
+  (uiop:copy-file (make-path "" "default-assets" "site-logo.png")
+		  (merge-pathnames "static/images/site-logo.png"
+				   ritherdon-archive.config:*application-root*))
+  (uiop:copy-file (make-path "" "default-assets" "favicon.png")
+		  (merge-pathnames "static/images/favicon.png"
+				   ritherdon-archive.config:*application-root*))
+  (ensure-directory-exists "" "snippets")
+  (uiop:copy-file (make-path "" "default-assets" "site-wide-snippet.html")
+		  (make-path "" "snippets" "site-wide-snippet.html"))
+  ;; Nothing is added to /storage/media yet, this is just prep. work.
+  (ensure-directory-exists "" "media")
+  (ensure-raw-directory-exists "snapshots/"))
+
+(defun copy-storage-directory (target-path)
+  "Copies the contents of /storage directory to `TARGET-PATH'.
+Make sure `TARGET-PATH' ends with a slash (E.G. snapshots/oct-2022/). Without
+it, the system will assume you're trying to work with a file and throw an
+error."
+  (copy-directory:copy (make-raw-path "storage/") (make-raw-path target-path)))
+
+(defun copy-raw-directory (source-path target-path)
+  "Copies a directory (`SOURCE-PATH') outside of /storage to `TARGET-PATH'."
+  (copy-directory:copy (make-raw-path source-path) (make-raw-path target-path)))
+
+(defun directory-exists-p (username directory)
+  "Checks to see if the specified diretory exists.
+The directories path is returned if it does exist and `NIL' is
+returned if the directory cannot be found."
+  (cl:probe-file (make-path username directory "")))
+
+(defun ensure-raw-directory-exists (directory-path)
+  "Creates directory if it doesn't exist (use for working outside of /storage).
+The directories path is returned if it does exist and `NIL' is returned if the
+directory cannot be found."
+  (ensure-directories-exist (make-raw-path directory-path)))
+
+(defun ensure-directory-exists (username directory)
+  "The project's standardised way to call `ENSURE-DIRECTORY-EXISTS'.
+If the directory exists, the full (absolute) path is
+returned (equating to `T', otherwiser `NIL' it returned."
+  ;; The empty string for `SLUG' (3rd arg.) is used because
+  ;; `MAKE-PATH' can form paths for files. In this instance, only the
+  ;; directory needs to be formed. The empty string kinda acts like
+  ;; `NIL' but it is a bit of a hack, I will admit.
+  (ensure-directories-exist (make-path username directory "")))
+
+(defun file-exists-p (username subdirectory slug)
+  "This project's standardised way to call `CL:PROBE-FILE'.
+If the file exists, the full (absolute) path is returned (equates to
+`T', otherwise `NIL' is returned."
+  (cl:probe-file (make-path username subdirectory slug)))
+
+(defun get-files-in-directory (username directory)
+  "Returns a list of paths for the files in `DIRECTORY' in the /storage directory.
+`USERNAME' is the subdirectory in /storage. If you are not implementing or have
+a need for creating sub-directories in /storage, pass in an empty string \"\" .
+Full directory structure: /storage/`USERNAME'/`DIRECTORY'
+
+When empty string used for 'username': /storage/`DIRECTORY'"
+  (uiop:directory-files (make-path username directory "")))
+
+(defun get-file-names (filenames)
+  "Returns a list of file names from a list of paths in `FILENAMES'.
+Make sure you call `STORAGE:GET-FILES-IN-DIRECTORY' and pass as `FILENAMES' when
+calling this function."
+  (mapcar #'(lambda (x) (file-namestring x)) filenames))
+
+(defun get-raw-directories (directory-path)
+  "Returns a list of paths for the files in `DIRECTORY-PATH' outside /storage directory."
+  (cl-fad:list-directory (make-raw-path directory-path)))
+
+(defun raw-directory-exists? (directory-path)
+  "Checks to see if directory at `DIRECTORY-PATH' (no directory make if none found)."
+  (cl-fad:directory-exists-p (make-raw-path directory-path)))
+
+(defun get-directory-names (directory-names)
+  "Returns the final part of a directories absolute path in `DIRECTORY-NAMES'.
+Make sure you use `GET-RAW-DIRECTORIES' to build the `DIRECTORY-NAMES' list."
+  (mapcar #'(lambda (x) (first (last (pathname-directory x)))) directory-names))
+
+(defun make-path (username subdirectory slug)
+  "Forms the path used to save a file.
+Storage path:
+`*APPLICATION-ROOT*'/storage/`USERNAME'/`SUBDIRECTORY'/`SLUG'
+Each user has their own directory in /storage. This is so I can build a media
+manager at a later date -- I had not got around to writing it at the time I
+implemented this function/feature. I decided to go with `USERNAME' and
+not (user-)`ID' is because I wanted to easily identify the directories in
+/storage."
+  (merge-pathnames (format nil "storage/~A/~A/~A"
+			   username subdirectory slug)
+		   ritherdon-archive.config:*application-root*))
+
+(defun make-raw-path (path)
+  "Make a file/directory path outsite of the /storage directory."
+  (merge-pathnames path ritherdon-archive.config:*application-root*))
+
+(defun open-binary-file (username subdirectory slug)
+  "Reads the file stored in the /storage directory."
+  (with-open-file (stream
+		   (make-path username subdirectory slug)
+		   :element-type '(unsigned-byte 8))
+    (let* ((length (file-length stream))
+	   (buffer (make-array length
+			       :element-type '(unsigned-byte 8))))
+      (read-sequence buffer stream)
+      (values buffer length))))
+
+(defun open-text-file (username subdirectory slug)
+  "Reads the text (.md) file stored in the /storage directory."
+  (with-open-file (stream (make-path username subdirectory slug))
+    (let ((data (make-string (file-length stream))))
+      (read-sequence data stream)
+      data)))
+
+(defun remove-raw-directory (directory-path)
+  "Removes directory at `DIRECTORY-PATH' when outside /storage directory."
+  (cl-fad:delete-directory-and-files (make-raw-path directory-path)))
+
+(defun remove-directory (username subdirectory)
+  "Deletes an directory in /storage.
+Path template: `*APPLICATION-ROOT*'/storage/`USERNAME'/`SUBDIRECTORY'/'
+- https://edicl.github.io/cl-fad/#delete-directory-and-files
+- https://stackoverflow.com/questions/24350183/how-do-i-delete-a-directory-in-common-lisp
+'cl-fad' (files and directories) is a wrapper package over the various
+Common Lisp implementions to aid in keeping your Common Lisp code
+portable. At the time of writing (February 2022), the website is using
+Steel Bank Common Lisp (SBCL) but this allow you to use something else
+if you want or need to switch."
+  (cl-fad:delete-directory-and-files (make-path username subdirectory "")))
+
+(defun rename-directory (username original-directory new-directory)
+  "Renames a sub-directory in the /storage directory.
+`USERNAME' is the directory holding the one which is to be
+changed. `ORIGINAL-DIRECTORY' is the 'source' (in the usual Linux/Bash
+CLI sense). `NEW-DIRECTORY' is the name the `ORIGINAL-DIRECTORY' will
+be changed to. There are various examples of the path
+structure/template in other comments in this file. Have a look
+around (don't want to repeat myself)."
+  (rename-file (make-path username original-directory "")
+	       (make-path username new-directory "")))
+
+(defun remove-file (username subdirectory slug)
+  "Deletes the specified file, stored in the /storage directory.
+Before calling this function, make sure the file exists. You should have
+'file-exists-p' available to you -- within this (storage) package."
+  (delete-file (make-path username subdirectory slug)))
+
+(defun rename-content-file (username subdirectory old-slug new-slug)
+  "This project's standardised way to call `RENAME-FILE'."
+  (rename-file (make-path username subdirectory old-slug)
+	       (make-path username subdirectory new-slug)))
+
+(defun store-file-old (username subdirectory filename data)
+  "OBSOLETE. USE `STORE-FILE'."
+  (let ((path (ensure-directories-exist
+	       (make-path username subdirectory filename))))
+    (cond ((or (string= (caddr data) "application/gzip")
+	       (string= (caddr data) "application/zip")
+	       (string= (caddr data) "application/epub+zip"))
+	   (uiop:copy-file (slot-value (car data) 'pathname) path))
+	  (t (with-open-file (stream
+			      path
+			      :direction :output
+			      :if-does-not-exist :create
+			      :element-type '(unsigned-byte 8)
+			      :if-exists :supersede)
+	       (write-sequence (slot-value (car data) 'vector) stream))))))
+
+(defun store-file (username subdirectory filename data)
+  "Stores the uploaded file to the /storage directory.
+Storage path: `*APPLICATION-ROOT*'/storage/`USERNAME'/`SUBDIRECTORY'/`FILENAME'
+`DATA' is the actual contents which will be written to the said path."
+  (let ((path (ensure-directories-exist
+	       (make-path username subdirectory filename))))
+    (cond ((equal (type-of (car data)) 'SB-SYS:FD-STREAM)
+	   (uiop:copy-file (slot-value (car data) 'pathname) path))
+	  (t
+	   (with-open-file (stream
+			    path
+			    :direction :output
+			    :if-does-not-exist :create
+			    :element-type '(unsigned-byte 8)
+			    :if-exists :supersede)
+	     (write-sequence (slot-value (car data) 'vector) stream))))))
+
+(defun store-text (username subdirectory filename data)
+  "Stores the plain text to the /storage directory.
+Storage path: `*APPLICATION-ROOT*'/storage/`USERNAME'/`SUBDIRECTORY'/`FILENAME'
+`DATA' is the actual text/data which will be written to the said path."
+  (let ((path (ensure-directories-exist
+	       (make-path username subdirectory filename))))
+	   (with-open-file (stream
+			    path
+			    :direction :output
+			    :if-does-not-exist :create
+			    :if-exists :supersede)
+	     (format stream "~a~%" data))))
+
+(defun store-with-raw-path (path data)
+  "Stores `DATA' at `PATH'. Use when storing data outsite of /storage directory."
+  (let ((path (ensure-directories-exist
+	       (merge-pathnames path
+				ritherdon-archive.config::*application-root*))))
+    (cond ((equal (type-of (car data)) 'SB-SYS:FD-STREAM)
+	   (uiop:copy-file (slot-value (car data) 'pathname) path))
+	  (t
+	   (with-open-file (stream
+			    path
+			    :direction :output
+			    :element-type '(unsigned-byte 8)
+			    :if-does-not-exist :create
+			    :if-exists :supersede)
+	     (write-sequence (slot-value (car data) 'vector) stream))))))
+
+(defun store-text-with-raw-path (path data)
+  "Stores the plain text `DATA' at `PATH'.
+Use when storing text outside of /storage direcory."
+  (let ((path (ensure-directories-exist
+	       (merge-pathnames path
+				ritherdon-archive.config::*application-root*))))
+	   (with-open-file (stream
+			    path
+			    :direction :output
+			    :if-does-not-exist :create
+			    :if-exists :supersede)
+	     (format stream "~a~%" data))))
+
+(defun open-text-file-with-raw-path (file-path)
+  "Reads the text file stored in the at `PATH'.
+Use when reading text outside the /storage directory."
+  (let ((path (ensure-directories-exist
+	       (merge-pathnames file-path
+				ritherdon-archive.config::*application-root*))))
+    (with-open-file (stream path)
+      (let ((data (make-string (file-length stream))))
+	(read-sequence data stream)
+	data))))
+
+
+(defun remove-file-with-raw-path (file-path)
+  "Deletes the specified file, at `PATH', use this to delete file outsite of /storage.
+Before calling this function, make sure the file exists. You should have
+'file-exists-p' available to you -- within this (storage) package."
+  (delete-file (merge-pathnames file-path ritherdon-archive.config::*application-root*)))
+
+;;; PORTED FROM RAILS-TO-CAVEMAN PROJECT (expect it to be deleted)
+;;; =============================================================================
+
+(defun prin1-to-base64-string (object)
+  (cl-base64:string-to-base64-string (prin1-to-string object)))
+
+(defun read-from-base64-string(string)
+  (values (read-from-string
+	   (cl-base64:base64-string-to-string string))))
+
+;;; This function requires ImageMagick so you will need to install it
+;;; with 'sudo apt install imagemagick' (assuming you are on a
+;;; Debian-based system).
+;; (defun convert (id subdirectory original-file converted-file)
+;;   (let ((command (format nil "convert -geometry ~A ~A ~A"
+;; 			 (file-size converted-file)
+;; 			 (make-storage-pathname id subdirectory original-file)
+;; 			 (make-storage-pathname id subdirectory converted-file))))
+;;     (let ((message (nth-value 1
+;; 			      (uiop:run-program command
+;; 						:ignore-error-status t
+;; 						:error-output :string))))
+;;       (when message (error message)))))

src/utils.lisp

@@ -0,0 +1,200 @@
+(in-package #:cl-user)
+(defpackage #:utils
+  (:use #:cl
+	#:caveman2
+	#:log4cl
+        #:xml-emitter
+	#:app-constants
+	#:storage)
+  (:export #:request-params
+	   #:separate-files-in-web-request
+	   #:set-alert
+	   #:get-alert
+	   #:get-and-reset-alert
+	   #:checkbox-to-bool
+	   #:asciify
+	   #:slugify
+	   #:get-image-dimensions
+	   #:run-bash-command
+	   #:create-thumbnail
+	   #:create-timestamp-id
+	   #:format-filename
+	   #:format-keywords
+	   #:build-alert-string
+           #:month-number-to-name
+           #:build-url-root
+           #:build-url
+           #:create-timestamp-text)
+  (:documentation "Utilities that do not depend on models."))
+
+(in-package #:utils)
+
+(defun asciify (string)
+  (str:downcase (slug:asciify string)))
+
+(defun slugify (string)
+  "Turns a string of text into a slug."
+  (str:downcase (slug:slugify string)))
+
+(defun format-filename (string)
+  "Changes the filename into the system's standard.
+Replaces whitespace with '-' and changes everything to lowecase."
+  (str:replace-all " " "-" (asciify string)))
+
+(defun format-keywords (string)
+  "Formats the keywords used in the `ARCHIVE-ENTRY' class.
+This is mostly just over-prep'ing the keywords assuming the user
+enters them in the incorrect format. Meilisearch exects something like
+'art,welding,green paint,ritherdon'. The comma is the seperator which
+allows each 'keyword' to have (white-)spaces."
+  (str:replace-all ", " "," (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 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))
+
+(defun set-alert (message &optional alert-type)
+  "Sets the alert `MESSAGE' stored in session, provide info. to users.
+The intention is store a `MESSAGE' across a redirect during a HTTP
+POST request."
+  (cond ((string= "error" alert-type)
+	 (setf (gethash :alert ningle:*session*)
+	       (build-alert-string alert-type "vomit-cat.png" message)))
+	((string= "success" alert-type)
+	 (setf (gethash :alert ningle:*session*)
+	       (build-alert-string alert-type "success-cat.png" message)))
+	((string= "missing-data" alert-type)
+	 (setf (gethash :alert ningle:*session*)
+	       (build-alert-string alert-type "sherlock-cat.png" message)))
+	((string= "invalid-data" alert-type)
+	 (setf (gethash :alert ningle:*session*)
+	       (build-alert-string alert-type "confused-cat.png" message)))
+	((string= "created" alert-type)
+	 (setf (gethash :alert ningle:*session*)
+	       (build-alert-string alert-type "disco-cat.png" message)))
+	((string= "warning" alert-type)
+	 (setf (gethash :alert ningle:*session*)
+	       (build-alert-string alert-type "workout-cat.png" message)))
+	(t (setf (gethash :alert ningle:*session*) message))))
+
+(defun build-alert-string (alert-text src-image message)
+  (format nil
+	  "<p class=\"~a\"><img alt=\"~a\" src=\"/images/alerts/~a\">~a</p>"
+	  alert-text
+	  alert-text
+	  src-image
+	  message))
+
+(defun get-alert ()
+  "Get alert message from session data."
+  (gethash :alert ningle:*session*))
+
+(defun get-and-reset-alert ()
+  "Returns the `ALERT' message and clears its content from the session hash."
+  (let ((message (get-alert)))
+    (set-alert nil)
+    message))
+
+(defun checkbox-to-bool (value)
+  "Converts a HTML Checkbox `VALUE' to a Boolean.
+The `VALUE' will either be 'on' or 'off'. 'Boolean' in this instance
+is assuming you are using SQLite and need to convert `VALUE' to an
+integer/number. If you are needing a traditional Boolean value, DO NOT USE
+THIS FUNCTION."
+  (cond ((or (string= "checked" value) (string= "on" value)) +true+)
+	((or (string= "off" value) (null value)) +false+)
+	((null value) +false+)))
+
+(defun get-image-dimensions (filepath)
+  "Uses Image Magick (via Bash) to get the resolution of an image as 'WxH'.
+The `FILEPATH' must be already merged with
+`ritherdon-archive.config::*application-root*' before you call this function."
+  (let* ((command
+	   (format nil "identify -format \"%wx%h\" ~a" filepath))
+	 (out-message (uiop:run-program command :output :string
+						:ignore-error-status t
+						:error-output :string)))
+    out-message))
+
+(defun run-bash-command (command)
+  "Runs the Bash command."
+  (uiop:run-program command :output :string
+			    :ignore-error-status t
+			    :error-output :string))
+
+(defun create-thumbnail (storage-sub-directory file-name &optional (overwrite t))
+  "Runs a Bash command to convert a file to a thumbnail  in /storage/media dir.
+The file is reduced to 512x512 pixels if bigger than that. A new file
+is then created with a 'thumbnail-' pre-fix. This process relies on
+Image Magick. So, it must be installed on the system for this function
+to operate properly."
+  (run-bash-command
+   (format nil "convert ~a -resize 512x512\\> ~a"
+	   (storage:file-exists-p "" storage-sub-directory file-name)
+	   (if (eq overwrite t)
+	       (storage:file-exists-p "" storage-sub-directory file-name)
+	       (storage:make-path "" storage-sub-directory
+				  (format nil "thumbnail-~a" file-name))))))
+
+(defun create-timestamp-id ()
+  "Creates a integer based on time the function is called, in YYYYMMDD format."
+  (multiple-value-bind
+	(second minute hour day month year)
+      (get-decoded-time)
+    (format nil "~d~2,'0d~d~2,'0d~2,'0d~2,'0d" year month day hour minute second)))
+
+(defun create-timestamp-text ()
+  "Creates a text-based timestamp (value being the time function was called)."
+  (multiple-value-bind
+	(second minute hour day month year)
+      (get-decoded-time)
+    (format nil "~d-~2,'0d-~d_~2,'0d-~2,'0d-~2,'0d" year month day hour minute second)))
+
+(defun month-number-to-name (month-number)
+  "Converts `MONTHS-NUMBER' to its name (E.G. 1 to 'January')."
+  (cond ((= 1 month-number) "January")
+        ((= 2 month-number) "February")
+        ((= 3 month-number) "March")
+        ((= 4 month-number) "April")
+        ((= 5 month-number) "May")
+        ((= 6 month-number) "June")
+        ((= 7 month-number) "July")
+        ((= 8 month-number) "August")
+        ((= 9 month-number) "September")
+        ((= 10 month-number) "October")
+        ((= 11 month-number) "November")
+        ((= 12 month-number) "December")
+        (t nil)))
+
+(defun build-url (request)
+  "Concatenates parts of the web request to form the full URL the user requested."
+  (format nil "~a://~a~a~a"
+          (lack.request:request-uri-scheme request)
+          (lack.request:request-server-name request)
+          (if (string= "localhost" (lack.request:request-server-name request))
+              (format nil ":~a" (lack.request:request-server-port request))
+              "")
+          (lack.request:request-uri request)))
+
+(defun build-url-root (request)
+  "Concatenates parts of the web request to form site's root URL.
+This is mostly used for generating the site map (XML file for crawlers)."
+  (format nil "~a://~a~a"
+          (lack.request:request-uri-scheme request)
+          (lack.request:request-server-name request)
+          (if (string= "localhost" (lack.request:request-server-name request))
+              (format nil ":~a" (lack.request:request-server-port request))
+              "")))

src/validation.lisp

@@ -0,0 +1,57 @@
+(in-package #:cl-user)
+(defpackage #:validation
+  (:use #:cl
+	#:app-constants)
+  (:export  #:has-static-assets-extention?
+	    #:is-valid-favicon-type?
+	    #:favicon-need-resizing?
+            #:string-is-nil-or-empty?)
+  (:documentation "Package for validating 'stuff'."))
+(in-package #:validation)
+
+(defun file-has-valid-static-assets-extention? (filename)
+  (cond ((or (string= "css" (pathname-type filename))
+	     (string= "js"  (pathname-type filename))
+	     (string= "png" (pathname-type filename))
+	     (string= "ico" (pathname-type filename))
+	     (string= "gif" (pathname-type filename))
+	     (string= "jpg" (pathname-type filename))
+	     (string= "svg" (pathname-type filename))
+	     (string= "txt" (pathname-type filename)))
+	 filename)
+	 (t nil)))
+
+(defun file-is-valid-favicon-type? (filename)
+  "Returns path of file if `FILE' is a valid favicon.
+Valid file types are 'ico', 'gif' and 'png'."
+  (cond ((or (string= "png" (pathname-type filename))
+	     (string= "ico" (pathname-type filename))
+	     (string= "gif" (pathname-type filename)))
+	 filename)
+	 (t nil)))
+
+(defun string-is-nil-or-empty? (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 favicon-need-resizing? (dimensions)
+  "Checks to see if the `WIDTH' or `HEIGHT' are greater than 192x192 pixels.
+`DIMENSIONS' is a cons list, with the `WIDTH' being first element and
+`HEIGHT' being the second. If either of them are, then you look into
+scaling down the image, using code in the `UTILS' package probably."
+  (cond ((or (< 192 (car dimensions)) (< 192 (cdr dimensions)))
+	 t) ; True as in the dimensions are valid
+	(t ;; Bit confusing with the use of `T' here but its standard
+	   ;; practice to end `COND' with a catch-all `T'. In this
+	   ;; case, `T' here means the dimensions are invalid, as in
+	   ;; 'yes' the favicon needs resizing. This is confusing
+	   ;; Boolean logic but when you call this function, the
+	   ;; return types make sense from that point-of-view.
+	 nil)))

src/view.lisp

@@ -1,21 +1,21 @@
-(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)
+(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*)
 
@@ -34,18 +34,100 @@
   (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))
+  (:use #:cl
+	#:storage)
+  (:import-from #:files
+		#:storage-file)
+  (:import-from #:ritherdon-archive.config
+		#:config
+                #:appenv
+		#:developmentp
+                #:productionp)
+  (:import-from #:caveman2
+		#:url-for))
+
+;; Added 'in-package' line after default Caveman2 set-up. Needed for custom
+;; functions. Not part of Caveman2 set-up.
+(in-package #:ritherdon-archive.djula)
 
 (setf djula:*djula-execute-package* (find-package :ritherdon-archive.djula))
+
+;; Custom filters and template code added below...
+;; =============================================================================
+
+;; This filter is for converting Integers used to store Boolean values
+;; in a SQLite database. The intended place you will use this filter
+;; is in the /software section. The most notable parts being the /add
+;; and /edit sections. In the SQLite database, I have set:
+;; - 0 => false
+;; - 1 => true.
+;; In this case, if the `VALUE' is not 1, it is always false (I.E. 0).
+(djula:def-filter :integer-to-checkbox (value)
+  (format nil "~S" (if (= 1 value) "on" "off")))
+
+(djula:def-filter :build-thumbnail-path (file)
+  (cond ((str:contains? "svg" (files::file-type-of file) :ignore-case t)
+	 (format nil  "/images/icons/svg.png"))
+        ((str:contains? "image" (files::file-type-of file) :ignore-case t)
+	 (format nil  "/storage/thumb/media/~a" (files::slug-of file)))	
+	((str:contains? "pdf" (files::file-type-of file) :ignore-case t)
+	 (format nil  "/images/icons/pdf.png"))	
+	((str:contains? "html" (files::file-type-of file) :ignore-case t)
+	 (format nil  "/images/icons/code.png"))
+	((str:contains? "text" (files::file-type-of file) :ignore-case t)
+	 (format nil  "/images/icons/txt.png"))
+	((str:contains? "css" (files::file-type-of file) :ignore-case t)
+	 (format nil  "/images/icons/code2.png"))
+	((str:contains? "video" (files::file-type-of file) :ignore-case t)
+	 (format nil  "/images/icons/video.png"))
+	((str:contains? "audio" (files::file-type-of file) :ignore-case t)
+	 (format nil  "/images/icons/audio.png"))
+	((str:contains? "zip" (files::file-type-of file) :ignore-case t)
+	 (format nil  "/images/icons/archive.png"))
+	(t (format nil  "/images/icons/file.png"))))
+
+(defun insert-snippet (snippet-name)
+  (if (storage:file-exists-p "" "snippets" snippet-name)
+      (format nil "~a" (storage:open-text-file "" "snippets" snippet-name))
+      (format nil "<!-- ~a not found -->" snippet-name)))
+
+(defun insert-dashboard-cat ()
+  (let ((timestamp (local-time:now)))
+    (cond ((and (= (local-time:timestamp-day timestamp) 8)
+                (= (local-time:timestamp-month timestamp) 2))
+           (format nil "/images/icons/birthday-cat.png"))
+          ((and (>= (local-time:timestamp-hour timestamp) 6)
+	        (< (local-time:timestamp-hour timestamp) 10))
+	   (format nil "/images/icons/morning-cat.png"))
+          ((and (>= (local-time:timestamp-hour timestamp) 10)
+	        (< (local-time:timestamp-hour timestamp) 12))
+           (format nil "/images/icons/coffee-cat.png"))
+          ((and (>= (local-time:timestamp-hour timestamp) 12)
+	        (< (local-time:timestamp-hour timestamp) 14))
+           (format nil "/images/icons/dinner-cat.png"))
+          ((and (>= (local-time:timestamp-hour timestamp) 14)
+	        (< (local-time:timestamp-hour timestamp) 18))
+           (format nil "/images/icons/study-cat.png"))
+          ((and (>= (local-time:timestamp-hour timestamp) 18)
+	        (< (local-time:timestamp-hour timestamp) 20))
+           (cond
+             ;; Sunday
+             ((= (local-time:timestamp-day-of-week timestamp) 0)
+	      (format nil "/images/icons/love-cat.png"))
+             ;; Monday - Friday
+             ((<= (local-time:timestamp-day-of-week timestamp) 5)
+	      (format nil "/images/icons/workout-cat.png"))
+             ;; Saturday
+             ((= (local-time:timestamp-day-of-week timestamp) 6)
+	      (format nil "/images/icons/rock-star-cat.png"))))
+          ((and (>= (local-time:timestamp-hour timestamp) 20)
+	        (< (local-time:timestamp-hour timestamp) 22))
+           (format nil "/images/icons/dinner-cat.png"))
+          ((and (>= (local-time:timestamp-hour timestamp) 22)
+	        (< (local-time:timestamp-hour timestamp) 24))
+           (format nil "/images/icons/bed-time-cat.png"))
+          (t (format nil "/images/icons/default-cat.png")))))

static/css/full-search.css

@@ -0,0 +1,294 @@
+.search-dashboard {
+    margin: 0px;
+    padding: 0px;
+    display: flex;
+    flex-direction: column;
+}
+
+.refinements-panel h2,
+.refinements-panel p {
+    padding: 0px;
+    margin: 12px 0px;
+}
+
+#clear-refinements {
+    margin-bottom: 20px;
+}
+
+.ais-ClearRefinements-button {
+    font-size: 16px;
+    height: 40px;
+    width: 100%;
+    margin: 0px;
+    font-family: 'main', sans-serif;
+    color: black;
+    background-color: white;
+    cursor: pointer;
+    border: none;
+    text-align: left;
+}
+
+.ais-ClearRefinements-button:hover {
+    text-decoration: underline;
+}
+
+.ais-ClearRefinements-button--disabled {
+    color: slategrey;
+}
+
+.ais-ClearRefinements-button--disabled:hover {
+    color: slategrey;
+    text-decoration: none;
+    cursor: initial;
+}
+
+.search-refinement-list {
+    /* margin: 20px 0px; */
+    /* border-bottom: 2px solid black; */
+}
+
+#searchbox {
+    width: 100%;
+    margin-top: 20px;
+    margin-bottom: 20px;
+    margin-left: auto;
+    margin-right: auto;
+}
+
+.ais-SearchBox,
+.ais-ClearRefinements-button {
+    max-width: 600px;
+}
+
+.search-results-container {
+    display: flex;
+    flex-direction: column;
+}
+
+.ais-SearchBox-form {
+    display: flex;
+    flex-wrap: nowrap;
+    justify-content: center;
+    align-items: center;
+}
+
+.ais-SearchBox-input {
+    box-sizing: border-box;
+    width: 100%;
+    margin-bottom: 15px;
+    padding: 10px;
+    border-radius: 8px;
+    border: 1px solid black;
+}
+
+.ais-SearchBox-input::placeholder {
+    /* font-family: 'main', sans-serif; */
+    /* font-size: 16px; */
+}
+
+.ais-SearchBox-form input:focus-visible {
+    /* outline: none; */
+}
+
+.ais-SearchBox-submitIcon,
+.ais-SearchBox-submit,
+.ais-SearchBox-reset {
+    display: none;
+}
+
+.ais-RefinementList-list {
+    list-style: none;
+    padding: 0px;
+    margin: 0px 0px 40px 0px;
+    display: flex;
+    flex-direction: row;
+    width: 100%;
+    overflow: scroll;
+}
+
+.ais-RefinementList-label {
+    display: flex;
+    align-items: center ;
+    width: max-content;
+    margin-right: 6px;
+}
+
+.ais-RefinementList-label > span {     
+    padding: 0px 2px;
+}
+
+.ais-RefinementList-checkbox {
+    width: 30px;
+    height: 30px;
+    margin: 0px;
+}
+
+.search-hits-panel {
+    width: -webkit-fill-available;
+}
+
+#hits {
+    width: 100%;
+    min-width: 350px;
+    display: flex;
+    flex-direction: row;
+}
+
+.ais-Hits-list {
+    padding: 0px;
+    margin: 0px;
+    display: flex;
+    flex-direction: column;
+    list-style: none;
+}
+
+.ais-Hits-item {
+    margin: 8px;
+    max-height: 400px;
+    border-radius: 4px;
+    overflow: hidden;
+    display: flex;
+    flex-direction: column;
+}
+
+.ais-Hits-item:hover {
+    /* border-color: lightblue; */
+    /* box-shadow: none; */
+}
+
+.fe-search-hit {
+    max-width: 375px;
+}
+
+.fe-search-hit-title {
+    font-weight: bold;
+}
+
+.fe-search-hit-secondary {
+    display: block;
+}
+
+.fe-search-hit-keywords {
+    display: block;
+    color: slategrey;
+    font-size: 11px;
+}
+
+.fe-search-hit img {
+    width: 375px;
+    height: 200px;
+    object-fit: cover;
+    overflow: hidden;
+}
+
+#pagination {
+    display: block;
+    margin: 40px 0px 40px 0px;
+    overflow: auto;
+    width: 100%;
+}
+
+.ais-Pagination-list {
+    list-style: none;
+    padding: 0px;
+    margin: 0px 12px;
+    display: flex;
+    justify-content: center;
+    align-items: center;
+}
+
+.ais-Pagination-item {
+    font-size: 22px;
+    margin: 6px;
+}
+
+.ais-Pagination-item--disabled {
+    color: slategrey;
+}
+
+/* @media (min-width:600px)  {
+   .ais-ClearRefinements-button {
+   max-width: 200px;
+   }
+   } */
+
+/* @media (min-width:961px)  { */
+@media (min-width: 600px) {
+    .search-results-container {
+	flex-direction: row;
+    }
+    
+    .refinements-panel {
+	max-width: 200px;
+	width: 100%;
+	margin-right: 20px;
+    }
+
+    .ais-RefinementList-list {
+	font-size: 12px;
+	flex-direction: column;
+	overflow: auto;
+    }
+
+    .ais-RefinementList-item {
+	margin: 2px 0px;
+    }
+
+    .ais-RefinementList-checkbox {
+	width: 20px;
+	margin-right: 4px;
+    }
+
+    #hits {
+	flex-direction: row;
+	flex-wrap: wrap;
+    }
+
+    .ais-Hits-list {
+	padding: 0px;
+	margin: 0px;
+	display: flex;
+	flex-direction: row;
+	flex-wrap: wrap;
+	list-style: none;
+    }
+
+    .ais-Hits-item {
+	/* width: 200px; */
+	/* height: 280px; */
+	/* margin: 12px; */
+	/* height: 100%; */
+	/* display: flex; */
+	/* flex-direction: column; */
+    }
+
+    .fe-search-hit {
+        max-width: 200px;
+    }
+
+    .fe-search-hit-title {
+        font-weight: bold;
+        display: -webkit-box;
+        -webkit-box-orient: vertical;
+        -webkit-line-clamp: 2;
+        overflow: hidden;
+    }
+
+    .fe-search-hit-secondary {
+        display: block;
+    }
+
+    .fe-search-hit-keywords {
+        display: block;
+        color: slategrey;
+        font-size: 11px;
+    }
+
+    .fe-search-hit img {
+        width: 200px;
+        height: 100px;
+        object-fit: cover;
+        overflow: hidden;
+    }
+
+}

static/css/main.css

@@ -1,21 +1,875 @@
 @charset "UTF-8";
 
+@font-face {
+    font-family: "main";
+    src: url("archivo/Archivo-Regular.otf") format("opentype");
+}
+
+/* smartphones, iPhone, portrait 480x320 phones */
+html, body {
+    /* height: 100%; */
+}
+
 body {
-  font-family: 'Myriad Pro', Calibri, Helvetica, Arial, sans-serif;
+    font-family: 'main', Calibri, Helvetica, Arial, sans-serif;
+    margin: 0px;
+    padding: 0px;
+}
+
+button {
+    font-family: 'main', Calibri, Helvetica, Arial, sans-serif;
 }
 
 a:link {
-  color: #005585;
-  text-decoration: none;
+    color: black;
+    text-decoration: none;
 }
+
 a:visited {
-  color: #485270;
+    color: black;
 }
+
 a:hover {
-  color: #b83800;
-  text-decoration: underline;
+    text-decoration: underline;
+}
+
+.fe-404 {
+    display: flex;
+    flex-direction: column;
+    align-items: center;
+    justify-content: center;
+    height: 100%;
+}
+
+.fe-404 img {
+    width: 300px;
+}
+
+.fe-404 p {
+    font-size: 20px;
+}
+
+input[type=file],
+input[type=text],
+input[type=password],
+input[type=number] {
+    border: 1px solid black;
+    border-radius: 8px;
+    margin: 0px;
+    padding: 4px;
+    display: inline-block;
+}
+
+.be-gui-form-row select {
+    width: 100%;
+    height: 38px;
+    border-radius: 8px;
 }
 
 #main {
   text-align: center;
 }
+
+.fr-main {
+    max-width: 880px;
+    margin: auto;
+    padding: 20px;
+}
+
+.fr-main h2 {
+    padding: 0px;
+    margin: 20px 0px 0px 0px;
+}
+
+.fr-main .be-gui-form-hint {
+    margin-bottom: 20px;
+}
+
+.fr-main .fr-gui-form-hint {
+    margin-bottom: 0px;
+    font-style: italic;
+    font-size: 12px;
+    padding: 0px;
+    margin: 0px;
+}
+
+.fr-main img {
+    max-width: 200px;
+    width: 100%;
+}
+
+.be-alert-container {
+    display: flex;
+    align-items: center;
+    position: fixed;
+    top: 60px;
+    left: 8px;
+    right: 8px;
+}
+
+.be-alert-container button {
+    position: fixed;
+    right: 15px;
+}
+
+.be-alert-container p {
+    padding: 0px 60px 0px 0px;
+    margin: 0px;
+    border-radius: 8px;
+    display: flex;
+    flex-direction: row;
+    align-items: center;
+    width: 100%;
+}
+
+.be-alert-container .success {
+    background: #adefad;
+}
+
+.be-alert-container .error {
+    background: #ff607c;
+}
+
+.be-alert-container .missing-data{
+    background: #ffaf8e;
+}
+
+.be-alert-container .invalid-data {
+    background: #efe1ad;
+}
+
+.be-alert-container .created {
+    background: #b0f3ff;
+}
+
+.be-alert-container .warning {
+    background: #ffe0c0;
+}
+
+.be-alert-container p img {
+    max-height: 75px;
+    padding: 12px 8px;
+}
+
+.be-login-container {
+    margin: 60px 0px;
+}
+
+.be-user-accounts-container {
+    display: flex;
+    flex-direction: column;
+    justify-content: flex-start;
+    /* margin-bottom: 20px; */
+}
+
+.be-user-accounts-container p,
+.be-user-accounts-container .be-gui-button-no-text {
+    display: inline;
+    padding: 4px;
+}
+
+.be-user-accounts-container p,
+.be-user-accounts-container label {
+    margin: 0px 4px;
+}
+
+.be-user-accounts-container p {
+    font-weight: bold;
+}
+
+.be-user-accounts-container input[type=password] {
+    height: 34px;
+    width: 100%;
+}
+
+.be-section-thumbnail-row {
+    display: flex;
+    flex-direction: row;
+    align-items: center;
+    justify-content: flex-start;
+    margin: 0px;
+    padding: 0px;
+    width: 100%;
+}
+
+.wrap-break-spaces {
+    white-space: break-spaces !important;
+}
+
+.be-gui-link:link,
+.be-gui-button:link,
+.be-gui-link-no-text,
+.be-gui-button-no-text {
+    background: #905da1;
+    color: white;
+}
+
+.be-gui-link-no-text {
+    width: 40px;
+    height: 40px;
+}
+
+.be-gui-button-no-text {
+    width: 40px;
+    height: 40px;
+}
+
+.be-gui-link-no-text img,
+.be-gui-button-no-text img {
+    width: 32px;
+}
+
+.be-gui-link-no-text,
+.be-gui-button-no-text {
+    padding: 2px 4px;
+    border-radius: 8px;
+    border: none;
+    color: white;
+    display: flex;
+    align-items: center;
+    justify-content: center;
+    margin: 4px;
+}
+
+.be-gui-link,
+.be-gui-button {
+    padding: 0px;
+    width: 100%;
+    height: 36px;
+    padding: 8px 0px;
+    border: none;
+    max-width: 600px;
+    background: #905da1;
+    color: white;
+    display: flex;
+    justify-content: flex-start;
+    align-items: center;
+    border-radius: 6px;
+    max-width: initial;
+    text-decoration: none;
+}
+
+.be-gui-button {
+    height: 42px;
+    font-size: 16px;
+}
+
+.be-gui-link:hover ,
+.be-gui-button:hover,
+.be-gui-link-no-text:hover,
+.be-gui-button-no-text:hover {
+    background: #473951;
+    text-decoration: none;
+    /* color: white; */
+}
+
+.be-gui-link:visited,
+.be-gui-button:visited {
+    /* background: #905da1; */
+    color: white;
+}
+
+.be-gui-link img,
+.be-gui-button img {
+    width: 34px;
+    padding: 5px;
+    margin-right: 12px;
+}
+
+.be-section-entry .be-gui-button-no-text {
+    padding: 22px;
+}
+
+.be-gui-button p {
+    padding: 0px 0px 0px 8px;
+    margin: 0px;
+    display: inline;
+    font-size: 18px;
+    font-family: 'main';
+}
+
+.be-gui-form {
+    display: flex;
+    flex-direction: column;
+    margin: 12px 0px;
+}
+
+.be-gui-form label,
+.be-gui-form input {
+    display: block;
+    /* width: 100%; */
+}
+
+.be-gui-form label {
+    text-transform: uppercase;
+    font-weight: bold;
+    margin-bottom: 4px;
+}
+
+hr {
+    margin: initial;
+}
+
+.be-gui-form input {
+    margin-bottom: 12px;
+    height: 24px;
+}
+
+.be-gui-form-inline {
+    display: inline;
+    align-items: center;
+}
+
+.be-gui-form-inline-flex{
+    display: flex;
+    align-items: center;
+}
+
+.be-gui-form input[type=checkbox] {
+    display: inline;
+}
+
+.be-gui-form input[type=file] {
+    padding: 12px;
+}
+
+.be-gui-form textarea {
+    margin-bottom: 20px;
+}
+
+.be-gui-form-hint {
+    font-style: italic;
+    font-size: 12px;
+    padding: 0px;
+    margin: 0px;
+}
+
+.be-gui-form-row {
+    display: flex;
+    flex-direction: row;
+    align-items: center;
+    justify-content: flex-start;
+    margin: 0px;
+    padding: 0px;
+}
+
+.be-gui-form-row input,
+.be-gui-form-row label {
+    margin: 0px 5px 0px 0px;
+    padding: 0px;
+}
+
+.be-gui-form-row input[type=number] {
+    padding: 6px;
+}
+
+.be-gui-form-row select {
+    margin: 0px 6px 0px 0px;
+}
+
+.be-gui-form-thumbnail {
+    max-height: 80px;
+    margin: 12px;
+    box-shadow: 1px 1px 7px 1px silver;
+    
+}
+
+.be-gui-form-row input[type=text] {
+    height: 30px;
+    padding: 4px;
+    width: 100%;
+}
+
+.be-site-header {
+    display: flex;
+    flex-direction: row;
+    justify-content: space-between;
+    align-items: center;
+    background: #2a0134;
+    height: 44px;
+    padding: 0px;
+    position: sticky;
+    top: 0;
+    z-index: 3;
+}
+
+.be-site-header button {
+    width: auto;
+    height: 32px;
+    background: #473951;
+    border: none;
+    color: white;
+    display: flex;
+    flex-direction: row;
+    align-items: center;
+    font-size: 18px;
+    margin: 0px 4px;
+    padding: 6px 12px;
+    border-radius: 6px;
+}
+
+.be-site-header button img {
+    width: 22px;
+    margin-right: 6px;
+}
+
+.be-user-info {
+    display: flex;
+    align-items: center;
+    padding-right: 12px;
+}
+
+.be-user-info p {
+    display: inline;
+    color: white;
+    padding-left: 6px;
+    font-weight: bold;
+}
+
+.be-user-info span {
+    font-weight: normal;
+}
+
+.be-site-side-menu {
+    display: none;
+    flex-direction: column;
+    justify-content: space-between;
+    background: #473951;
+    position: fixed;
+    width: 300px;
+    /* Based on the height of be-site-header. */
+    top: 0px;
+    padding-top: 86px;
+    left: 0;
+    bottom: 0px;
+    /* Stops the text editor rendering over it.  */
+    z-index: 2;
+    overflow-y: auto;
+}
+
+.be-site-side-menu h2 {
+    text-align: center;
+    color: white;
+    font-size: 16px;
+    border-bottom: 1px solid white;
+    padding-bottom: 6px;
+}
+
+.be-site-side-menu div {
+    display: flex;
+    flex-direction: column;
+    padding: 0px;
+    margin: 12px;
+}
+
+.be-site-side-menu .be-gui-link,
+.be-site-side-menu .be-gui-button {
+    padding: 8px;
+    margin: 0px;
+    width: auto;
+    background: #473951;
+}
+
+.be-site-side-menu .be-gui-button {
+    padding: 28px 8px;
+    width: 276px;
+    font-size: 16px;
+}
+
+.be-site-side-menu .be-gui-link:hover,
+.be-site-side-menu .be-gui-button:hover {
+    background: #905da1;;
+}
+
+.be-main {
+    max-width: 880px;
+    width: 100%;
+    display: flex;
+    justify-content: center;
+    flex-direction: column;
+    margin: 20px auto;
+}
+
+.be-dashboard-header {
+    display: flex;
+    flex-direction: column;
+    align-items: start;
+    justify-content: space-between;
+    padding: 0px;
+    margin: 0px;
+}
+
+.be-dashboard-header .profile-cat {
+    height: 75px;
+}
+
+.be-dashboard-header div {
+    display: flex;
+    flex-direction: row;
+    justify-content: flex-start;
+    margin: 0px;
+}
+
+.be-dashboard-header .be-gui-link,
+.be-dashboard-section .be-gui-link {
+    background: #905da1;
+}
+
+.be-dashboard-header .be-gui-link:hover,
+.be-dashboard-section .be-gui-link:hover{
+    background: #473951;
+}
+
+.be-dashboard-section {
+    display: flex;
+    flex-direction: column;
+    margin: 0px;
+    padding: 0px;
+}
+
+.be-dashboard-section form input[type=file] {
+    border: 1px solid silver;
+    border-radius: 8px;
+    margin: 4px 4px 4px 0px;
+    padding: 12px;
+    display: inline-block;
+}
+
+.be-dashboard-section h2 {
+    margin: 20px 0px 20px 0px;
+    padding: 0px;
+}
+
+.be-section-controls {
+    display: flex;
+    flex-direction: row;
+    justify-content: flex-start;
+    align-items: center;
+    margin-bottom: 20px;
+}
+
+.be-section-controls .be-gui-link {
+    margin-right: 6px;
+}
+
+.be-section-controls .be-gui-link {
+    max-width: 175px;
+}
+
+.be-section-entries {
+    display: flex;
+    flex-direction: column;
+}
+
+.be-section-entry,
+.be-section-image-title {
+    display: flex;
+    flex-direction: row;
+    justify-content: space-between;
+}
+
+.be-section-image-title {
+    display: flex;
+    flex-direction: row;
+    justify-content: flex-start;
+    max-width: 716px;
+    width: 100%;
+    margin: 4px 0px;
+}
+
+.be-section-image-title img {
+    max-height: 50px;
+    height: 100%;
+    margin-right: 6px;
+}
+
+.be-section-entry form {
+    display: flex;
+    flex-direction: row;
+    justify-content: space-between;
+    margin: 0px;
+}
+
+.be-section-entry img {
+    /* max-height: 80px; */
+    /* width: 100%; */
+}
+
+.be-section-entry p {
+    max-width: 800px;
+    white-space: nowrap;
+    overflow-x: clip;
+    text-overflow: ellipsis; 
+}
+
+.be-section-image-title p {
+    white-space: initial;
+}
+
+.be-section-entry:hover,
+.be-index-item:hover,
+.be-user-accounts-container:hover {
+    background: #fff6d2;
+}
+
+.be-entry-controls {
+    display: flex;
+    flex-direction: row;
+}
+
+.be-dashboard-section-list .be-gui-link {
+    margin: 6px 0px;
+}
+
+.be-quicklist {
+    display: flex;
+    flex-direction: row;
+    flex-wrap: wrap;
+    align-items: center;
+}
+
+.be-quicklist .be-gui-link {
+    max-width: 140px;
+    margin: 4px;
+}
+
+.be-quicklist .be-gui-link img {
+    margin-right: 0px;
+}
+
+.be-storage-section {
+    display: flex;
+    flex-direction: column;
+    justify-content: center;
+    align-items: center;
+}
+
+.be-storage-section-upload {
+    display: flex;
+    flex-direction: row;
+    align-items: center;
+    margin: 12px 0px;
+}
+
+.be-storage-section-upload form  {
+    display: flex;
+    flex-direction: row;
+    align-items: center;
+    justify-content: center;
+    width: 100%;
+}
+
+.be-storage-section-upload form [type=file]  {
+    padding: 10px 12px;
+}
+
+.be-storage-entry {
+    width: 100%;
+    display: flex;
+    flex-direction: row;
+    align-items: center;
+}
+
+.file-thumbnail {
+    max-width: 50px;
+    max-height: 50px;
+    width: 100%;
+    padding: 0px 4px;
+}
+
+.be-storage-rename {
+    display: flex;
+    flex-direction: row;
+    align-items: center;
+    width: 100%;
+}
+
+.be-storage-rename input[type=text] {
+    width: 100%;
+    height: 30px;
+}
+
+.be-warning {
+    color: red;
+}
+
+.be-gui-link.danger {
+    background: #ffa700;
+    color: black;
+}
+
+.be-gui-button.danger {
+    background: red;
+}
+
+.be-gui-button.danger:hover,
+.be-gui-link.danger:hover {
+    background: #473951;
+    text-decoration: none;
+    color: white;
+}
+
+.be-popup-container {
+    position: relative;
+    display: inline-block;
+}
+
+.be-popup {
+    background: palevioletred;
+    color: white;
+    padding: 8px;
+    border-radius: 8px;
+    visibility: hidden;
+    position: absolute;
+    left: 20px;
+    top: -20px;
+    z-index: 10;
+}
+
+.fe-site-header {
+    display: flex;
+    flex-direction: column;
+    background: white;
+    align-items: center;
+    padding: 8px;
+    text-align: center;
+    text-decoration: none;
+}
+
+.fe-site-header img {
+    max-height: 100px;
+    width: auto;
+    margin-right: 8px;
+}
+
+#fe-main {
+    margin: 8px;
+}
+
+#fe-main nav {
+    text-align: center;
+}
+
+.fe-index {
+    max-width: 880px;
+    width: 100%;
+    margin: 0px auto;
+}
+
+.fe-index-entry {
+    margin: 8px 0px;
+}
+
+/* Start of Index Filter */
+#fe-search-filter {
+  box-sizing: border-box;
+  width: 100%;
+  margin-bottom: 15px;
+  padding: 10px;
+}
+ 
+
+#fe-search-filter-list {
+  list-style: none;
+  margin: 0;
+  padding: 0;
+}
+
+#fe-search-filter-list li {
+  padding: 0px;
+}
+
+
+#fe-search-filter-list li.hide {
+    display: none;
+}
+/* End of Index Filter Stuff */
+
+.fe-index-entry img {
+    max-height: 100px;
+}
+
+.fe-hint {
+    margin: 0px;
+    padding: 0px;
+    font-size: 11px;
+    color: slategrey;
+}
+
+.fe-article {
+    display: flex;
+    justify-content: center;
+    flex-direction: column;
+    align-items: center;
+}
+
+.fe-article-header {
+    display: flex;
+    justify-content: center;
+    align-items: center;
+    flex-direction: column;
+    margin: 12px 0px;
+}
+
+.fe-article-header h1 {
+    padding: 0px;
+    margin: 0px;
+}
+
+.fe-article-header img {
+    /* max-width: 100px; */
+    height: 100px;
+}
+
+.flex-row {
+    display: flex;
+    flex-direction: row;
+    align-items: center;
+}
+
+.fe-article-header p {
+    padding: 0px;
+    margin: 0px;
+}
+
+.fe-article-body {
+    max-width: 880px;
+    width: 100%;
+}
+
+.fe-article-body img {
+    max-width: 350px;
+    height: auto;
+}
+
+.fe-article-nav {
+    width: 100%;
+}
+
+/* .fe-article-nav ul { */
+/*     padding: 0px; */
+/*     margin: 6px 0px; */
+/* } */
+
+.fe-article-nav ul li {
+    /* list-style: none; */
+    margin: 6px 0px;
+}
+
+/* big landscape tablets, laptops, and desktops */
+@media (min-width:880px) {
+
+    .fe-article-body img {
+    max-width: 880px;
+ 
+}
+
+/* big landscape tablets, laptops, and desktops */
+@media (min-width:1025px) {
+}
+/* hi-res laptops and desktops */
+@media (min-width:1281px) {
+}
+/* Anything bigger */
+@media (min-width:2100px) {
+}

static/css/search.css

@@ -0,0 +1,94 @@
+.fe-search-container {
+    margin: 0px;
+    display: flex;
+    flex-direction: column;
+    align-items: center;
+    height: 120px;
+}
+
+#searchbox {
+    position: relative;
+    top: 40px;
+    width: 100%;
+    max-width: 600px;
+}
+
+.ais-SearchBox-form {
+    display: flex;
+    flex-wrap: nowrap;
+    justify-content: center;
+    align-items: center;
+}
+
+.ais-SearchBox-input {
+    width: 100%;
+    height: 40px;
+    padding: 10px;
+    border: 1px solid black;
+    border-radius: 8px;
+}
+
+.ais-SearchBox-submitIcon,
+.ais-SearchBox-submit,
+.ais-SearchBox-reset,
+#hits {
+    display: none;
+}
+
+#hits {
+    position: relative;
+    top:40px;
+    background: white;
+    width: calc(100% - 4px);
+    max-width: calc(600px - 4px);
+    border-right: 2px solid black;
+    border-bottom: 2px solid black;
+    border-left: 2px solid black;
+    border-radius: 0px 0px 4px 4px;
+}
+
+.ais-Hits-list {
+    list-style: none;
+    padding: 0px 2px;
+    margin: 0px;
+}
+
+.ais-Hits-list:first-child {
+    display: flex;
+    flex-wrap: nowrap;
+    flex-direction: column;
+    justify-content: flex-start;
+}
+
+
+.ais-Hits-item {
+    margin: 4px 0px 0px 0px;
+}
+
+.fe-search-hit {
+    overflow: hidden;
+    white-space: nowrap;
+    text-overflow: ellipsis;
+    width: 100%;
+}
+
+.fe-search-hit:link {
+    text-decoration: none;
+    float: left;
+    border-radius: 0px;
+    padding: 4px 0px;
+}
+
+.fe-search-hit img {
+    width: 30px;
+    height: 30px;
+    display: inline;
+    float: left;
+    padding: 0px 6px;
+}
+
+.fe-search-hit span {
+    vertical-align: middle;
+}
+
+