Public archive for the Return to Ritherdon project.
https://www.nicolaellisandritherdon.com
You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
266 lines
8.7 KiB
266 lines
8.7 KiB
(in-package #:cl-user) |
|
(defpackage #:ritherdon-archive.web |
|
(:use #:cl |
|
#:caveman2 |
|
#:ritherdon-archive.config |
|
#:ritherdon-archive.view |
|
#:ritherdon-archive.db |
|
#:datafly |
|
#:sxql |
|
#:cl-pass |
|
#:app-constants |
|
#:status-codes ; (HTTP Status Codes) |
|
#:hermetic |
|
#:auth |
|
#:utils |
|
#:user |
|
#:nera-db) |
|
(:export #:*web*)) |
|
(in-package #:ritherdon-archive.web) |
|
|
|
;; for @route annotation |
|
(syntax:use-syntax :annot) |
|
|
|
;; |
|
;; Application |
|
|
|
(defclass <web> (<app>) ()) |
|
(defvar *web* (make-instance '<web>)) |
|
(clear-routing-rules *web*) |
|
|
|
;; |
|
;; Routing rules |
|
|
|
(defroute "/" () |
|
(let ((alert (utils:get-and-reset-alert))) |
|
(hermetic:auth (:logged-in) |
|
(render #P"index.html" |
|
(append (auth:auth-user-data) |
|
`(:alert ,alert))) |
|
(render #P"index.html" `(:alert ,alert))))) |
|
|
|
(defroute "/setup" () |
|
;; If there is no database, there is no user, hence no more checks. |
|
(cond ((not (uiop:file-exists-p (ritherdon-archive.config:database-name))) |
|
(render #P"initial-setup.html" `(:token ,(auth:csrf-token)))) |
|
(t `(,+service-unavailable+ (:location "/"))))) |
|
|
|
(defroute ("/run-setup" :method :POST) () |
|
(destructuring-bind (&key authenticity-token &allow-other-keys) |
|
(utils:request-params |
|
(lack.request:request-body-parameters ningle:*request*)) |
|
(cond ((not (string= authenticity-token (auth:csrf-token))) |
|
`(,+forbidden+ (:content-type "text/plain") ("Denied"))) |
|
((uiop:file-exists-p (ritherdon-archive.config:database-name)) |
|
`(,+service-unavailable+ (:location "/"))) |
|
(t (nera-db:init-db |
|
(lack.request:request-body-parameters ningle:*request*)) |
|
;; Redirect to /setup-complete? |
|
(utils:set-alert "All set-up. Log-in to continue.") |
|
(redirect "/login"))))) |
|
|
|
(defroute ("/sign-up" :method :GET) () |
|
(if (= +false+ (site-settings::enable-sign-up-p (nera:get-site-settings))) |
|
(progn |
|
(utils:set-alert "This feature has been disabled.") |
|
(redirect "/")) |
|
(hermetic:auth (:logged-in) |
|
;; Hermetic Authorised (Logged in users can't sign-up). |
|
(progn |
|
(utils:set-alert |
|
"You need to be signed out to create a new account.") |
|
(redirect "/dashboard")) |
|
;; Hermetic Not Authorised |
|
(let ((alert (utils:get-and-reset-alert))) |
|
(render "sign-up.html" |
|
`(:token ,(auth:csrf-token) |
|
:alert ,alert)))))) |
|
|
|
(defroute ("/sign-up" :method :POST) () |
|
(destructuring-bind |
|
(&key username display-name password password-check |
|
authenticity-token &allow-other-keys) |
|
(utils:request-params |
|
(lack.request:request-body-parameters ningle:*request*)) |
|
(cond ((not (string= authenticity-token (auth:csrf-token))) |
|
`(,+forbidden+ (:content-type "text/plain") ("Denied"))) |
|
((not (string= password password-check)) |
|
(utils:set-alert "Passwords don't match.") |
|
(redirect "/sign-up")) |
|
((find t (mapcar |
|
#'utils:string-is-nil-or-empty? |
|
`(,username ,display-name ,password))) |
|
(utils:set-alert "Incomplete form. Please fill out every section.") |
|
(redirect "/sign-up")) |
|
(t (hermetic:auth |
|
(:logged-in) |
|
;; Authorised (Logged in user can't sign-up). |
|
(progn (utils:set-alert "Logged in users are not allowed to create account.") |
|
(redirect "/dashboard")) |
|
;; Not Authorised |
|
(progn |
|
(nera-db:create-user username display-name password +false+) |
|
(utils:set-alert "Account created.") |
|
(redirect "/login"))))))) |
|
|
|
|
|
(defroute ("/login" :method :GET) () |
|
(hermetic:auth (:logged-in) |
|
;; Authorised |
|
(redirect "/dashboard") |
|
;; Not Authorised |
|
(let ((alert (utils:get-and-reset-alert))) |
|
(render "user/log-in.html" |
|
`(:token ,(auth:csrf-token) |
|
:alert ,alert))))) |
|
|
|
(defroute ("/login" :method :POST) () |
|
(destructuring-bind |
|
(&key username password authenticity-token &allow-other-keys) |
|
(utils:request-params |
|
(lack.request:request-body-parameters ningle:*request*)) |
|
(if (not (string= authenticity-token (csrf-token))) |
|
`(,+forbidden+ (:content-type "text/plain") ("Denied")) |
|
(let ((params (list :|username| username :|password| password))) |
|
(hermetic:login |
|
params |
|
;; Successful log-in attempt. |
|
(progn |
|
(setf |
|
;; Set session Id. to the logged in user. |
|
(gethash :id ningle:*session*) (nera:get-user-id username) |
|
;; Set the users password (for session) |
|
(gethash :password ningle:*session*) password) |
|
(redirect "/dashboard")) |
|
;; Failed log-in attempt. |
|
(progn (utils:set-alert "Incorrect details provided.") |
|
(redirect "/login")) |
|
;; No user found. |
|
(progn (utils:set-alert "Can't find that user.") |
|
(redirect "/login"))))))) |
|
|
|
(defroute ("/logout" :method :POST) () |
|
(destructuring-bind |
|
(&key authenticity-token &allow-other-keys) |
|
(utils:request-params |
|
(lack.request:request-body-parameters ningle:*request*)) |
|
(if (not (string= authenticity-token (auth:csrf-token))) |
|
`(,+forbidden+ (:content-type "text/plain") ("Denied")) |
|
(hermetic:auth (:logged-in) |
|
(hermetic:logout |
|
;; Successful log-out. |
|
(progn (auth:flash-gethash :id ningle:*session*) |
|
(redirect "/")) |
|
;; Failed log-out |
|
(progn (utils:set-alert "Error: Unable to log out.") |
|
(redirect "/"))))))) |
|
|
|
(defroute ("/dashboard" :method :GET) () |
|
(hermetic:auth (:logged-in) |
|
;; Authorised |
|
(let ((alert (utils:get-and-reset-alert))) |
|
(render #P"user/dashboard.html" |
|
(append (auth:auth-user-data) |
|
`(:alert ,alert)))) |
|
;; Not Authorised |
|
(progn (utils:set-alert "You are not logged in.") |
|
(redirect "/login")))) |
|
|
|
(defroute ("/site-settings" :method :GET) () |
|
(hermetic:auth (:administrator) |
|
;; Authorised |
|
(let ((alert (utils:get-and-reset-alert))) |
|
(render #P"user/site-settings.html" |
|
(append (auth:auth-user-data) |
|
`(:alert ,alert)))) |
|
;; Not Authorised |
|
(progn |
|
(utils:set-alert "You are not authorised to view this page.") |
|
(redirect "/")))) |
|
|
|
(defroute ("/users" :method :GET) () |
|
(hermetic:auth (:administrator) |
|
;; Authorised |
|
(let ((alert (utils:get-and-reset-alert))) |
|
(render #P"user/index.html" |
|
(append (auth:auth-user-data) |
|
`(:alert ,alert |
|
:users ,(nera:get-all-users))))) |
|
;; Not Authorised |
|
(progn |
|
(utils:set-alert "You are not authorised to view this page.") |
|
(redirect "/login")))) |
|
|
|
(defroute ("/user/admin/create" :method :POST) () |
|
(destructuring-bind |
|
(&key username display-name password password-check |
|
authenticity-token &allow-other-keys) |
|
(utils:request-params |
|
(lack.request:request-body-parameters ningle:*request*)) |
|
(cond ((not (string= authenticity-token (auth:csrf-token))) |
|
`(,+forbidden+ (:content-type "text/plain") ("Denied"))) |
|
((not (string= password password-check)) |
|
(utils:set-alert "Passwords don't match.") |
|
(redirect "/users")) |
|
((find t (mapcar |
|
#'utils:string-is-nil-or-empty? |
|
`(,username ,display-name ,password))) |
|
(utils:set-alert "Incomplete form. Please fill out every section.") |
|
(redirect "/users")) |
|
((not (null (nera:get-user username))) |
|
(utils:set-alert "Username already taken.") |
|
(redirect "/users")) |
|
(t (hermetic:auth |
|
(:administrator) |
|
;; Authorised |
|
(progn |
|
(nera-db:create-user username display-name password +false+) |
|
(utils:set-alert "Account created.") |
|
(redirect "/users")) |
|
;; Not Authorised |
|
(progn |
|
(utils:set-alert "You are not authorised to view that page.") |
|
(redirect "/"))))))) |
|
|
|
(defroute ("/user/edit" :method :GET) () |
|
(hermetic:auth (:logged-in) |
|
;; Authorised |
|
(let ((alert (utils:get-and-reset-alert))) |
|
(render #P"user/edit.html" |
|
(append (auth:auth-user-data) |
|
`(:alert ,alert)))) |
|
;; Not Authorised |
|
(progn (utils:set-alert "You are not logged in.") |
|
(redirect "/login")))) |
|
|
|
(defroute ("/user/edit" :method :POST) () |
|
(destructuring-bind |
|
(&key display-name new-password password-check |
|
authenticity-token &allow-other-keys) |
|
(utils:request-params |
|
(lack.request:request-body-parameters ningle:*request*)) |
|
(cond ((not (string= authenticity-token (auth:csrf-token))) |
|
`(,+forbidden+ (:content-type "text/plain") ("Denied"))) |
|
((not (string= new-password password-check)) |
|
(utils:set-alert "Passwords don't match.") |
|
(redirect "/user/edit")) |
|
(t (hermetic:auth |
|
(:logged-in) |
|
;; Authorised |
|
(progn |
|
(nera-db:update-user |
|
(user::username-of (auth:get-current-user)) |
|
display-name new-password) |
|
(utils:set-alert "User details updated.") |
|
(redirect "/dashboard")) |
|
;; Not Authorised |
|
(progn (utils:set-alert "You are not logged in.") |
|
(redirect "/login"))))))) |
|
|
|
;; |
|
;; Error pages |
|
|
|
(defmethod on-exception ((app <web>) (code (eql 404))) |
|
(declare (ignore app)) |
|
(merge-pathnames #P"_errors/404.html" |
|
*template-directory*))
|
|
|