host-routes.lisp

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
;; Copyright (c) 2024, SWGY, Inc. <ron@sw.gy>
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3 of the License, or (at
;; your option) any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software Foundation, Inc.,
;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
;;
(in-package :swtx)

(defun put-host (request-params)
  "Creates a new host."
  (with-persistent-auth ((list *role-admin* *role-host*) request-params)
    (format T "PUT host Params:~%~S~%" request-params)
    (handler-case
        (let* ((new-host-id (generate-id))
               (new-host (host-from-alist new-host-id request-params)))
          ; TODO: Trigger email validation
          (write-to-db *people-db* new-host)
          `(200 () (,(st-json:write-json-to-string (to-hash new-host)))))
      (bad-attribute-value-error (c)
        `(400 () (,(st-json:write-json-to-string (to-hash c))))))))

(defun list-hosts (request-params)
  "Lists all registered hosts."
  (with-persistent-auth ((list *role-admin* *role-host*) request-params)
    (format T "GET hosts Params:~%~S~%" request-params)
    (let* ((host-list (load-all-hosts *people-db*)))
      `(200 () (,(st-json:write-json-to-string
                  (mapcar #'(lambda (h) (to-hash h)) host-list)))))))

(defun auth-host (request-params)
  (with-oneshot-auth *auth-db* (host-email)
    (with-txn (:write nil)
      (let* ((host-id (param-val :host-id request-params *max-id-length*))
             (host (load-host *people-db* host-id)))
        (format T "AUTH Host params ~%~S~%" request-params)
        (format T "AUTH Host, host: ~A~%" host)
        (if host
            `(200 () (,(st-json:write-json-to-string
                        (generate-jwt host-email *role-host*
                                      :person-id host-id
                                      :minutes *host-auth-minutes*))))
            `(404 () ("Host not found")))))))

(defun get-host (request-params)
  "As a ningle handler, retrieve the host requested with the :host-id
route parameter."
  (with-persistent-auth ((list *role-admin* *role-host*) request-params)
    (format T "GET host Params:~%~S~%" request-params)
    (with-txn (:write nil)
      (let* ((host-id (param-val :host-id request-params *max-id-length*))
             (host (load-host *people-db* host-id)))
        (if host
            `(200 () (,(st-json:write-json-to-string (to-hash host))))
            `(404 () ("Not found")))))))

(defun update-host (request-params)
  "As a ningle handler, update the host requested with the :host-id
route parameter."
  (with-persistent-auth ((list *role-admin* *role-host*) request-params)
    (format T "PUT host Params:~%~S~%" request-params)
    (handler-case
        (let* ((id (param-val :host-id request-params *max-id-length*))
               (host (load-host *people-db* id)))
          (if host
              (let ((updated-host (update host request-params)))
                (write-to-db *people-db* updated-host :overwrite t)
                `(200 () (,(st-json:write-json-to-string
                            (to-hash updated-host)))))
              `(404 () ("Not found"))))
      (bad-attribute-value-error (c)
        `(400 () (,(st-json:write-json-to-string (to-hash c))))))))

(defun check-auth-host (request-params)
  "Check that the persistent auth is valid and allowed for this host."
  (with-persistent-auth ((list *role-admin* *role-host*) request-params)
    `(200 () (,(format nil "\"Auth valid for host ~A\""
                       (param-val :host-id request-params *max-id-length*))))))