From 14750a6c0cf61c7d8765e83072fbd6888204c506 Mon Sep 17 00:00:00 2001
From: Craig Oates <craig@craigoates.net>
Date: Tue, 25 Oct 2022 04:38:02 +0100
Subject: [PATCH] implement /danger/upload-snapshot defroute in web.lisp file.

I, also, replaced some 'logged-in' permission checks to 'administrator' in
several defroutes (mostly 'danger-zone' routes).

This is the back-end functionality which allows users to upload Snapshots (in
.zip files) to the /snapshot directory.

The route accepts multi-file uploads and ignores files which are not either a
.zip file or if a file has the same name as one of the Snapshots already in the
/snapshots directory.

Technically, the user can upload several files at once which are not .zip files
and the alert-message will relay a 'success' message, even when nothing was
added to the system. This is because the system is relaying the upload went
without errors and not how valid each file was. The system doesn't have anything
built-in which allows the multi-faceted alert-message approach to work.

Another thing to note here is the lack of checks for the contents within a .zip
Snapshot file. Basically, there isn't any. I am unsure how many moving parts are
going to be in these Snapshots in the future and hard-coding checks for
directories and file names seems a bit premature (maybe unpredictable?). The
HTML template responsible for dealing with the front-end of the Snapshot
features clearly state it is a 'danger zone' section of the site. So, there is
an expectation (hopefully) of 'if you don't know what you're doing, then don't
touch it'. Hello, person of the future. I was really wrong with that assumption,
wasn't I?
---
 src/web.lisp | 38 ++++++++++++++++++++++++++++++++++++--
 1 file changed, 36 insertions(+), 2 deletions(-)

diff --git a/src/web.lisp b/src/web.lisp
index f34938c..d477c44 100644
--- a/src/web.lisp
+++ b/src/web.lisp
@@ -1491,7 +1491,7 @@
 
 (defroute ("/danger/manage-files" :method :GET) ()
   (hermetic:auth
-   (:logged-in)
+   (:administrator)
    ;; Authorised
    (let ((alert (utils:get-and-reset-alert)))
      (render "/danger/manage-files.html"
@@ -1540,7 +1540,7 @@
 
 (defroute ("/danger/manage-database-entries" :method :GET) ()
   (hermetic:auth
-   (:logged-in)
+   (:administrator)
    ;; Authorised
    (let ((alert (utils:get-and-reset-alert)))
      (render "/danger/manage-db-entries.html"
@@ -1796,6 +1796,40 @@
                             "You are not authorised to delete page." "error")
 		           (redirect "/login")))))))
 
+(defroute ("/danger/upload-snapshot" :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"))
+	 (let ((files (utils:separate-files-in-web-request
+		       (lack.request:request-body-parameters ningle:*request*)
+		       "SNAPSHOT-FILES")))
+	   (hermetic:auth
+	    (:administrator)
+	    ;; Authorised
+	    (cond ((validation:string-is-nil-or-empty? (caddr (car files)))
+		   (utils:set-alert "No Snapshots provided." "missing-data")
+		   (redirect "/danger/manage-snapshots"))
+		  (t (loop
+		       :for item :in files
+		       :do (when (and (not (storage:raw-directory-exists?
+                                            (storage:make-raw-path
+                                             (format
+                                              nil "snapshots/~a/"
+                                              (pathname-name (caddr item))))))
+                                      (string= "zip" (pathname-type (caddr item))))
+                             (snapshot:store-snapshot
+                              (utils:format-filename (caddr item)) (cdr item))))
+		     (utils:set-alert "Snapshot upload complete." "success")
+		     (redirect "/danger/manage-snapshots")))
+	    ;; Not Authorised
+	    (progn
+	      (utils:set-alert "You are not authorised to view this page."
+			       "error")
+	      (redirect "/login")))))))
+
 ;;
 ;; Error pages