|
|
|
(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 "/")))
|
|
|
|
;; (render #P"initial-setup.html" `(:token ,(auth:csrf-token))))
|
|
|
|
(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)
|
|
|
|
;; 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"))
|
|
|
|
;; 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 ("/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*))
|