Compare commits

...

4 Commits

Author SHA1 Message Date
Craig Oates bc7a34ed6b snapshot 09.05.2023.1 1 year ago
Craig Oates 7475f129c8 snapshot 09.05.2023.0 1 year ago
Craig Oates d9ea17fc6e snapshot 22.11.2022.0 1 year ago
Craig Oates 9650008ce9 snapshot 19.11.2022.0 2 years ago
  1. 30
      .gitignore
  2. 2
      LICENSE
  3. 216
      README.org
  4. 51
      app.lisp
  5. 8
      conf/meilisearch.conf
  6. 10
      conf/meilisearch.service
  7. 30
      conf/ritherdon-archive.conf
  8. 13
      conf/ritherdon-archive.service
  9. 0
      db/schema.sql
  10. 16
      hunchentoot-example/Makefile
  11. 101
      hunchentoot-example/README.md
  12. 9
      hunchentoot-example/README.org
  13. BIN
      hunchentoot-example/bin/libz.so.1.2.11
  14. BIN
      hunchentoot-example/bin/ritherdon-archive
  15. 12
      hunchentoot-example/config-example.lisp
  16. 18
      hunchentoot-example/ritherdon-archive-tests.asd
  17. 89
      hunchentoot-example/ritherdon-archive.asd
  18. 37
      hunchentoot-example/roswell/README.md
  19. 28
      hunchentoot-example/roswell/ritherdon-archive.ros
  20. 9
      hunchentoot-example/run-tests.lisp
  21. 25
      hunchentoot-example/run.lisp
  22. 39
      hunchentoot-example/scripts/create-user.sh
  23. 30
      hunchentoot-example/src/database.lisp
  24. 61
      hunchentoot-example/src/models/models.lisp
  25. 26
      hunchentoot-example/src/models/user.lisp
  26. 41
      hunchentoot-example/src/packages.lisp
  27. 105
      hunchentoot-example/src/ritherdon-archive.lisp
  28. 1
      hunchentoot-example/src/static/css/main.css
  29. 2
      hunchentoot-example/src/static/js/ritherdon-archive.js
  30. 1
      hunchentoot-example/src/templates/404.html
  31. 5
      hunchentoot-example/src/templates/about.html
  32. 6
      hunchentoot-example/src/templates/archive.html
  33. 15
      hunchentoot-example/src/templates/base.html
  34. 175
      hunchentoot-example/src/templates/dashboard.html
  35. 6
      hunchentoot-example/src/templates/home.html
  36. 16
      hunchentoot-example/src/templates/login.html
  37. 9
      hunchentoot-example/src/utils.lisp
  38. 135
      hunchentoot-example/src/web.lisp
  39. 8
      hunchentoot-example/tests/packages.lisp
  40. 16
      hunchentoot-example/tests/test-ritherdon-archive.lisp
  41. 44
      makefile
  42. 11
      ritherdon-archive-test.asd
  43. 99
      ritherdon-archive.asd
  44. 39
      scripts/create-user.sh
  45. 39
      src/app-constants.lisp
  46. 76
      src/auth.lisp
  47. 60
      src/config.lisp
  48. 27
      src/db.lisp
  49. 50
      src/main.lisp
  50. 76
      src/models/archive.lisp
  51. 35
      src/models/files.lisp
  52. 48
      src/models/pages.lisp
  53. 50
      src/models/site-settings.lisp
  54. 41
      src/models/user.lisp
  55. 416
      src/nera.lisp
  56. 185
      src/search.lisp
  57. 62
      src/snapshot.lisp
  58. 498
      src/status-codes.lisp
  59. 317
      src/storage.lisp
  60. 200
      src/utils.lisp
  61. 57
      src/validation.lisp
  62. 136
      src/view.lisp
  63. 1852
      src/web.lisp
  64. BIN
      static/css/archivo/Archivo-Bold.otf
  65. BIN
      static/css/archivo/Archivo-BoldItalic.otf
  66. BIN
      static/css/archivo/Archivo-Italic.otf
  67. BIN
      static/css/archivo/Archivo-Medium.otf
  68. BIN
      static/css/archivo/Archivo-MediumItalic.otf
  69. BIN
      static/css/archivo/Archivo-Regular.otf
  70. BIN
      static/css/archivo/Archivo-SemiBold.otf
  71. BIN
      static/css/archivo/Archivo-SemiBoldItalic.otf
  72. 294
      static/css/full-search.css
  73. 866
      static/css/main.css
  74. 94
      static/css/search.css
  75. BIN
      static/images/alerts/art-cat.png
  76. BIN
      static/images/alerts/confused-cat.png
  77. BIN
      static/images/alerts/disco-cat.png
  78. BIN
      static/images/alerts/pending-cat.png
  79. BIN
      static/images/alerts/sherlock-cat.png
  80. BIN
      static/images/alerts/success-cat.png
  81. BIN
      static/images/alerts/vomit-cat.png
  82. BIN
      static/images/alerts/workout-cat.png
  83. BIN
      static/images/icons-1/ai.png
  84. BIN
      static/images/icons-1/cad.png
  85. BIN
      static/images/icons-1/css.png
  86. BIN
      static/images/icons-1/docx.png
  87. BIN
      static/images/icons-1/gif.png
  88. BIN
      static/images/icons-1/html.png
  89. BIN
      static/images/icons-1/jpg.png
  90. BIN
      static/images/icons-1/mp4.png
  91. BIN
      static/images/icons-1/png.png
  92. BIN
      static/images/icons-1/pptx.png
  93. BIN
      static/images/icons-1/psd.png
  94. BIN
      static/images/icons-1/rar.png
  95. BIN
      static/images/icons-1/txt.png
  96. BIN
      static/images/icons-1/xlsx.png
  97. BIN
      static/images/icons-1/zip.png
  98. BIN
      static/images/icons/add-circle.png
  99. BIN
      static/images/icons/add-square.png
  100. BIN
      static/images/icons/ai.png
  101. Some files were not shown because too many files have changed in this diff Show More

30
.gitignore vendored

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

2
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:

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

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

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

10
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

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

13
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

0
db/schema.sql

16
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

101
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

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

BIN
hunchentoot-example/bin/libz.so.1.2.11

Binary file not shown.

BIN
hunchentoot-example/bin/ritherdon-archive

Binary file not shown.

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

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

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

37
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

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

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

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

39
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

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

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

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

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

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

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

@ -0,0 +1 @@

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

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

1
hunchentoot-example/src/templates/404.html

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

5
hunchentoot-example/src/templates/about.html

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

6
hunchentoot-example/src/templates/archive.html

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

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

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

6
hunchentoot-example/src/templates/home.html

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

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

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

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

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

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

44
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.'

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

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

39
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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

1852
src/web.lisp

File diff suppressed because it is too large Load Diff

BIN
static/css/archivo/Archivo-Bold.otf

Binary file not shown.

BIN
static/css/archivo/Archivo-BoldItalic.otf

Binary file not shown.

BIN
static/css/archivo/Archivo-Italic.otf

Binary file not shown.

BIN
static/css/archivo/Archivo-Medium.otf

Binary file not shown.

BIN
static/css/archivo/Archivo-MediumItalic.otf

Binary file not shown.

BIN
static/css/archivo/Archivo-Regular.otf

Binary file not shown.

BIN
static/css/archivo/Archivo-SemiBold.otf

Binary file not shown.

BIN
static/css/archivo/Archivo-SemiBoldItalic.otf

Binary file not shown.

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

866
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) {
}

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

BIN
static/images/alerts/art-cat.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 42 KiB

After

Width:  |  Height:  |  Size: 42 KiB

BIN
static/images/alerts/confused-cat.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 44 KiB

After

Width:  |  Height:  |  Size: 44 KiB

BIN
static/images/alerts/disco-cat.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 46 KiB

After

Width:  |  Height:  |  Size: 46 KiB

BIN
static/images/alerts/pending-cat.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 37 KiB

After

Width:  |  Height:  |  Size: 37 KiB

BIN
static/images/alerts/sherlock-cat.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 44 KiB

After

Width:  |  Height:  |  Size: 44 KiB

BIN
static/images/alerts/success-cat.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 41 KiB

After

Width:  |  Height:  |  Size: 41 KiB

BIN
static/images/alerts/vomit-cat.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 43 KiB

After

Width:  |  Height:  |  Size: 43 KiB

BIN
static/images/alerts/workout-cat.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 43 KiB

After

Width:  |  Height:  |  Size: 43 KiB

BIN
static/images/icons-1/ai.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 14 KiB

After

Width:  |  Height:  |  Size: 14 KiB

BIN
static/images/icons-1/cad.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 20 KiB

After

Width:  |  Height:  |  Size: 20 KiB

BIN
static/images/icons-1/css.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 20 KiB

After

Width:  |  Height:  |  Size: 20 KiB

BIN
static/images/icons-1/docx.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 22 KiB

After

Width:  |  Height:  |  Size: 22 KiB

BIN
static/images/icons-1/gif.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 27 KiB

After

Width:  |  Height:  |  Size: 27 KiB

BIN
static/images/icons-1/html.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 15 KiB

After

Width:  |  Height:  |  Size: 15 KiB

BIN
static/images/icons-1/jpg.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 24 KiB

After

Width:  |  Height:  |  Size: 24 KiB

BIN
static/images/icons-1/mp4.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 21 KiB

After

Width:  |  Height:  |  Size: 21 KiB

BIN
static/images/icons-1/png.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 19 KiB

After

Width:  |  Height:  |  Size: 19 KiB

BIN
static/images/icons-1/pptx.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 22 KiB

After

Width:  |  Height:  |  Size: 22 KiB

BIN
static/images/icons-1/psd.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 26 KiB

After

Width:  |  Height:  |  Size: 26 KiB

BIN
static/images/icons-1/rar.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 22 KiB

After

Width:  |  Height:  |  Size: 22 KiB

BIN
static/images/icons-1/txt.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 18 KiB

After

Width:  |  Height:  |  Size: 18 KiB

BIN
static/images/icons-1/xlsx.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 22 KiB

After

Width:  |  Height:  |  Size: 22 KiB

BIN
static/images/icons-1/zip.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 20 KiB

After

Width:  |  Height:  |  Size: 20 KiB

BIN
static/images/icons/add-circle.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 17 KiB

After

Width:  |  Height:  |  Size: 17 KiB

BIN
static/images/icons/add-square.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 13 KiB

After

Width:  |  Height:  |  Size: 13 KiB

BIN
static/images/icons/ai.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 14 KiB

After

Width:  |  Height:  |  Size: 14 KiB

Some files were not shown because too many files have changed in this diff Show More

Loading…
Cancel
Save