backend: template (from swlkup)

TODO:
* debug why http://localhost:4000/graphiql/index.html doesn't load
* adapt tests from swlkup
* adapt flake from swlkup and test build pipeline
This commit is contained in:
Johannes Lötzsch 2022-03-06 23:09:59 +01:00
parent d6c6687823
commit 7e8daca015
42 changed files with 1089 additions and 0 deletions

View File

@ -0,0 +1,4 @@
{:lint-as {mount.core/defstate clojure.core/declare
specialist-server.type/defscalar clojure.core/declare
specialist-server.type/defobject clojure.core/declare
#_#_orchestra.core/defn-spec clojure.core/declare}}

3
backend/.gitattributes vendored Normal file
View File

@ -0,0 +1,3 @@
**/mvn2nix-lock.json linguist-generated
target linguist-generated

15
backend/.gitignore vendored Normal file
View File

@ -0,0 +1,15 @@
/target
/lib
/classes
/checkouts
pom.xml.asc
*.jar
*.class
/.lein-env
/.lein-repl-history
/.lein-failures
/.nrepl-port
/.lsp
/.clj-kondo/.cache
result
data

23
backend/DB.md Normal file
View File

@ -0,0 +1,23 @@
# Access via repl:
```bash
lein repl ## from somewhere within the `backend` directory
```
```clojure-repl
(require '[beherbergung.db.state :refer [db_ctx]]) ;; get a database context
(require '[clojure.pprint :refer [pprint]])
;; This example queries all offers
(pprint ((:q db_ctx) '{:find [(pull ?e [*])]
:where [[?e :xt/spec :beherbergung.model.offers/record]]}))
```
To learn more about the datalog query syntax, please use the [XTDB language reference](https://docs.xtdb.com/language-reference/datalog-queries/).
# Web UI
If you are looking for a Web UI for inspecting the XTDB database, you may want use [XTDB inspector](https://github.com/tatut/xtdb-inspector).
It is a separate project and not bundled into beherbergung. To connect to your database, you will need to adjust `dev-src/user.clj`.

View File

@ -0,0 +1,63 @@
{ pkgs ? import <nixpkgs> {},
buildMavenRepositoryFromLockFile ? (import (fetchTarball "https://github.com/johannesloetzsch/mvn2nix/archive/master.tar.gz") {}).buildMavenRepositoryFromLockFile,
patchPublic ? null
}:
let
inherit (pkgs) lib stdenv jdk11_headless maven makeWrapper leiningen;
inherit (stdenv) mkDerivation;
mavenRepository = buildMavenRepositoryFromLockFile { file = ./deps/mvn2nix-lock.json; };
src = mkDerivation {
name = "beherbergung-backend-src";
src = lib.cleanSource ./..;
installPhase = ''
cp -r . $out
'';
};
version = "0.0.1";
pname = "beherbergung-backend";
name = "${pname}-${version}";
beherbergung-backend-jar = mkDerivation rec {
inherit src version pname name;
buildInputs = [ jdk11_headless maven leiningen ];
patchPhase = if isNull patchPublic
then ""
else "cp -r ${patchPublic}/* resources/public/";
buildPhase = ''
echo "Building with maven repository ${mavenRepository}"
export HOME=`pwd`
mkdir .lein
echo '{:user {:offline? true :local-repo "${mavenRepository}"}}' > ~/.lein/profiles.clj
lein uberjar
'';
doCheck = true;
checkPhase = ''
lein test
'';
installPhase = ''
mkdir $out
cp target/${name}-standalone.jar $out/
'';
};
in
lib.mergeAttrs
(pkgs.writeScriptBin "${pname}" ''
#!${pkgs.runtimeShell}
${pkgs.which}/bin/which mail || export PATH=./backend/resources/mock:$PATH
## TODO: JAVA_TOOL_OPTIONS should be generated from jvm-opts in project.clj and also update beherbergung.service
export MALLOC_ARENA_MAX=2
export JAVA_TOOL_OPTIONS='-Dclojure.tools.logging.factory=clojure.tools.logging.impl/slf4j-factory -Dorg.slf4j.simpleLogger.defaultLogLevel=warn -Dlog4j2.formatMsgNoLookups=true'
${jdk11_headless}/bin/java -jar ${beherbergung-backend-jar}/${name}-standalone.jar $@ &
## We write a pid-file, so the integration test knows how to kill the server
echo $! > .pid
'')
{ inherit mavenRepository; jar = beherbergung-backend-jar; }

View File

@ -0,0 +1,16 @@
{ pkgs ? import <nixpkgs> {},
mvn2nix ? (import (fetchTarball "https://github.com/johannesloetzsch/mvn2nix/archive/master.tar.gz") {}).mvn2nix
}:
(pkgs.writeScriptBin "backendUpdatedDeps" ''
#!${pkgs.runtimeShell} -e
## TODO
#${pkgs.leiningen}/bin/lein pom
echo 'Call `lein pom` yourself and than add explicitly add maven-compiler-plugin in an up to date version'
echo
echo 'When you changed dependencies, you also want run nvd-check'
echo
echo "Generating mvn2nix-lock.json, please wait"
${mvn2nix}/bin/mvn2nix --repositories https://clojars.org/repo https://repo.maven.apache.org/maven2 > nix/deps/mvn2nix-lock.json
'')

52
backend/project.clj Normal file
View File

@ -0,0 +1,52 @@
(defproject beherbergung-backend "0.0.1"
:description "beherbergung (private hosting of refugees) backend"
:min-lein-version "2.0.0"
:dependencies [;; core
[org.clojure/clojure "1.10.3"]
[yogthos/config "1.2.0"]
[mount "0.1.16"]
[spootnik/signal "0.2.4"]
;; db
[com.xtdb/xtdb-core "1.20.0"]
[com.xtdb/xtdb-rocksdb "1.20.0"]
;; graphql + http
[org.clojars.johannesloetzsch/specialist-server "0.7.0" :exclusions [com.ibm.icu/icu4j]]
[compojure "1.6.2"]
[ring/ring-core "1.9.5"]
[ring/ring-jetty-adapter "1.9.5"]
[ring/ring-devel "1.9.5"]
[ring-cors "0.1.13"]
[ring/ring-json "0.5.1" :exclusions [cheshire]]
[cheshire "5.10.2"]
[ring-json-response "0.2.0"]
[co.deps/ring-etag-middleware "0.2.1"]
;; auth + mail
[cryptohash-clj "0.1.10"]
[likid_geimfari/secrets "1.1.1"]
[crypto-random "1.2.1"]
[buddy/buddy-sign "3.4.333"]
#_[com.draines/postal "2.0.4"]
;; graphiql ;; TODO not required for productive build
[ring-webjars "0.2.0" :exclusions [org.webjars/webjars-locator]]
[org.webjars/webjars-locator "0.45"]
[org.webjars/graphiql "0.11.11"]
[org.webjars.npm/react "18.0.0-rc.1" :exclusions [org.webjars.npm/loose-envify org.webjars.npm/js-tokens org.webjars.npm/object-assign]]
[org.webjars.npm/react-dom "17.0.2" :exclusions [org.webjars.npm/loose-envify org.webjars.npm/js-tokens org.webjars.npm/object-assign org.webjars.npm/scheduler]]
;; logging
[org.clojure/tools.logging "1.2.4"]
[org.slf4j/slf4j-api "2.0.0-alpha6"]
[org.slf4j/slf4j-simple "2.0.0-alpha6"]
]
:main beherbergung.webserver.state
:profiles {:dev {:dependencies [;; helpers for testing
[javax.servlet/servlet-api "2.5"]
[ring/ring-mock "0.4.0"]
;; additional deps to run `lein test`
[nrepl/nrepl "0.9.0"]
[clojure-complete/clojure-complete "0.2.5"]]
#_#_:jvm-opts ["-Dverbose=true"]}
:test {:jvm-opts ["-Ddb-inmemory=true" "-Ddb-export-prefix="]}
:uberjar {:aot :all}}
:jvm-opts ["-Dclojure.tools.logging.factory=clojure.tools.logging.impl/slf4j-factory" ;; used by yogthos/config and com.xtdb/xtdb-core
"-Dorg.slf4j.simpleLogger.defaultLogLevel=warn" ;; usded by jetty (via ring/ring-jetty-adapter)
"-Dlog4j2.formatMsgNoLookups=true"]) ;; not required, since log4j is no runtime dependency, but for defense-in-depth

9
backend/resources/mock/mail Executable file
View File

@ -0,0 +1,9 @@
#!/usr/bin/env bash
## During development and testing you can use this mock as a replacement for GNU Mailutils.
## Just set: PATH=$PATH:backend/resources/mock
FILE="/tmp/mail.log"
echo $@ >> $FILE
cat >> $FILE
echo >> $FILE

View File

@ -0,0 +1,60 @@
<!DOCTYPE html>
<html>
<head>
<meta charset="UTF-8">
<style>
body {
height: 100%;
margin: 0;
width: 100%;
overflow: hidden;
}
#graphiql {
height: 100vh;
}
</style>
<link rel="stylesheet" href="/assets/graphiql/graphiql.css">
<script src="/assets/react/umd/react.development.js"></script>
<script src="/assets/react-dom/umd/react-dom.development.js"></script>
<script src="/assets/graphiql/graphiql.js"></script>
</head>
<body>
<div id="graphiql">Loading...</div>
<script>
function graphQLFetcher(graphQLParams) {
// This example expects a GraphQL server at the path /graphql.
// Change this to point wherever you host your GraphQL server.
return fetch('/graphql', {
method: 'post',
headers: {
'Accept': 'application/json',
'Content-Type': 'application/json',
},
body: JSON.stringify(graphQLParams),
credentials: 'include',
}).then(function (response) {
return response.text();
}).then(function (responseBody) {
try {
return JSON.parse(responseBody);
} catch (error) {
return responseBody;
}
});
}
// Render <GraphiQL /> into the body.
// See the GraphiQL project page for more info on different options.
ReactDOM.render(
React.createElement(GraphiQL, {
fetcher: graphQLFetcher
}),
document.getElementById('graphiql')
);
</script>
</body>
</html>

View File

@ -0,0 +1,10 @@
(ns beherbergung.auth.admin
(:require [beherbergung.config.state :refer [env]]))
(defn admin?
"For now, we require only one administrator login.
It can be configured by the environmment variable ADMIN_PASSPHRASE
"
[passphrase]
(and (:admin-passphrase env)
(= passphrase (:admin-passphrase env))))

View File

@ -0,0 +1,19 @@
(ns beherbergung.auth.core
(:require [beherbergung.auth.password.verify-db :refer [login->id id->roles+entities]]
[beherbergung.auth.jwt.login :refer [jwt->id]]))
(defn auth->id [ctx auth]
(cond (:jwt auth)
(jwt->id (:jwt auth))
(and (:mail auth) (:password auth))
(login->id ctx (:mail auth) (:password auth))))
(defn auth+role->entity
[ctx auth role]
(let [login:id (auth->id ctx auth)
roles+entities (id->roles+entities ctx login:id)
entities (->> (filter #(= role (:role %)) roles+entities)
(map :entity))]
(when (and login:id
(<= (count entities) 1))
[(first entities) login:id])))

View File

@ -0,0 +1,19 @@
(ns beherbergung.auth.jwt.defaults
(:require [beherbergung.auth.jwt.state :refer [secret]]
[buddy.sign.jwt]
[buddy.sign.util :refer [now]]))
(def default_validity:seconds (* 24 60 60)) ;; 1 Day
(defn sign
"Wrap around buddy.sign.jwt/sign, using the secret provided by mount and adds an expiration date."
([data]
(sign data default_validity:seconds))
([data validity]
(when (< (count secret) beherbergung.auth.jwt.state/secret_length:bytes)
(throw (Exception. "Secret too short")))
(buddy.sign.jwt/sign (assoc data :exp (+ (now) validity))
secret)))
(defn unsign [jwt]
(buddy.sign.jwt/unsign jwt secret))

View File

@ -0,0 +1,11 @@
(ns beherbergung.auth.jwt.login
(:require [beherbergung.auth.password.verify-db :refer [login->id]]
[beherbergung.auth.jwt.defaults :refer [sign unsign]]))
(defn login [ctx mail password]
(let [login:id (login->id ctx mail password)]
(when login:id
(sign {:sub login:id}))))
(defn jwt->id [jwt]
(:sub (unsign jwt)))

View File

@ -0,0 +1,10 @@
(ns beherbergung.auth.jwt.state
(:require [crypto.random]
[mount.core :as mount :refer [defstate]]
[beherbergung.config.state]))
(def secret_length:bytes 64) ;; recommended by https://cheatsheetseries.owasp.org/cheatsheets/JSON_Web_Token_for_Java_Cheat_Sheet.html#weak-token-secret
(defstate secret
:start (or (:jwt-secret beherbergung.config.state/env)
(crypto.random/bytes secret_length:bytes)))

View File

@ -0,0 +1,11 @@
(ns beherbergung.auth.mail.local.mailutils
(:require [clojure.java.shell :refer [sh]]))
(defn send-message
"A plugin replacement for com.draines/postal to be used with GNU Mailutils"
([_server msg] (send-message msg))
([msg]
(sh "mail" "-s" (str (:subject msg))
(str "-aFrom:" (:from msg))
(str (:to msg))
:in (str (:body msg)))))

View File

@ -0,0 +1,16 @@
(ns beherbergung.auth.mail.send
(:require ;[postal.core :refer [send-message]]
[beherbergung.auth.mail.local.mailutils :refer [send-message]]
[beherbergung.config.state :refer [env]]))
(defn send-mail [msg*]
(let [server {:host (:mail-host env)
:user (:mail-user env)
:pass (:mail-pass env)
:port (:mail-port env)
:tls true}
msg (assoc msg* :from (or (:mail-from env)
(:mail-user-from env)))
result (send-message server msg)]
(or (= :SUCCESS (:error result))
(= 0 (:exit result)))))

View File

@ -0,0 +1,10 @@
(ns beherbergung.auth.password.generate
(:require [secrets.core :refer [choices]]
[secrets.constants :refer [ascii-letters digits punctuation]]
[clojure.string :refer [join]]))
(defn generate-password []
(let [length 20
characters (str ascii-letters digits punctuation)]
(->> (choices characters length)
(join ""))))

View File

@ -0,0 +1,13 @@
(ns beherbergung.auth.password.hash
(:require [cryptohash-clj.api :refer [hash-with verify-with]]))
(defn hash-password [password]
(let [algo :argon2
args {}]
(hash-with algo password args)))
(defn verify-password [password pwhash]
(if (empty? pwhash)
false
(let [algo :argon2]
(verify-with algo password pwhash))))

View File

@ -0,0 +1,24 @@
(ns beherbergung.auth.password.verify-db
(:require [beherbergung.auth.password.hash :refer [verify-password]]))
(defn login->id [ctx mail password]
(let [{:keys [q_id]} (:db_ctx ctx)
[login:id password:hash] (q_id '{:find [<-login:id <-password:hash]
:where [[?l :xt/spec :beherbergung.model.login/record]
[?l :mail ->mail]
[?l :xt/id <-login:id]
[?l :password-hash <-password:hash]]
:in [->mail]}
mail)
valid (verify-password password password:hash)]
(when valid login:id)))
(defn id->roles+entities [ctx login:id]
(let [{:keys [q]} (:db_ctx ctx)]
(q '{:keys [role entity]
:find [<-role <-entity:id]
:where [[?e :beherbergung.model.login/login:ids <-login:id]
[?e :xt/spec <-role]
[?e :xt/id <-entity:id]]
:in [<-login:id]}
login:id)))

View File

@ -0,0 +1,11 @@
(ns beherbergung.auth.token.generate
(:require [crypto.random :refer [base32]]))
(defn generate-token
"A 8 character base32 string should be user friendly.
It gives us an entropy of 40 Bit = 5 Byte.
We never use it as cryptographic secret for encryption or signing or any other function that can be bruteforced locally by an attacker.
The entrophy is therefore only relevant for the expected amount of requests to the server an attacker would need to try."
[]
(base32 5))

View File

@ -0,0 +1,6 @@
(ns beherbergung.auth.uuid.core)
(defn uuid
"Using version 4 (random) UUIDs, we avoid exposing the creation date of database records."
[]
(str (java.util.UUID/randomUUID)))

View File

@ -0,0 +1,68 @@
(ns beherbergung.config.state
"Wrapping yogthos/config with defstate allows overwriting the config at runtime and checking it at startup against a spec"
(:require [clojure.spec.alpha :as s]
[mount.core :refer [defstate args]]
[config.core]
[clojure.string]))
(s/def ::verbose boolean?)
(s/def ::port number?) ;; the webserver port
(s/def ::validate-output boolean?) ;; should specialist ensure type correctness
(s/def ::db-inmemory boolean?) ;; we run unit tests in an in-memory instance, otherwise the default db would be looked
(s/def ::db-dir string?) ;; ignored when ::db-inmemory
(s/def ::db-seed string?) ;; an edn-file to be used for seeding
(s/def ::db-export-prefix (s/nilable string?)) ;; path where during startup an export should be written
(s/def ::db-validate boolean?)
(s/def ::mail-host string?)
(s/def ::mail-user string?)
(s/def ::mail-pass string?)
(s/def ::mail-port number?)
(s/def ::mail-from (s/nilable string?))
(s/def ::admin-passphrase (s/nilable string?)) ;; allows setting up ngo logins and encrypted downloads of db exports
(s/def ::admin-gpg-id string?)
(s/def ::frontend-base-url string?)
(s/def ::frontend-backend-base-url string?)
(s/def ::env (s/keys :req-un [::verbose
::port
::validate-output
::db-inmemory ::db-dir
::db-seed ::db-export-prefix
::db-validate
;::mail-host ::mail-user ::mail-pass ::mail-port ::mail-from
::admin-passphrase
::admin-gpg-id
::frontend-base-url
::frontend-backend-base-url]))
(defn strip-secrets [env]
(assoc env :mail-pass "*"
:admin-passphrase "*"))
(defn filter-defined [keys-spec m]
(let [req-un (last (s/form keys-spec))
unnamespaced-keys (map #(-> (clojure.string/replace %
(if-let [n (namespace %)]
(str n "/")
"")
"")
(clojure.string/replace ":" "")
keyword)
req-un)]
(select-keys m (into [] unnamespaced-keys))))
(defstate env
:start (let [env (->> (merge (config.core/load-env)
(args)) ;; allows: (mount/start-with-args {…})
(filter-defined ::env))
config-errors (s/explain-data ::env env)]
(when (:verbose env)
(println (strip-secrets env)))
(assert (not config-errors) (with-out-str (s/explain-out config-errors)))
env))

View File

@ -0,0 +1,25 @@
(ns beherbergung.db.export
(:require [clojure.pprint :refer [pprint]]
[clojure.edn]))
(defn all_docs [db_ctx]
(let [{:keys [sync q_unary]} db_ctx]
(sync)
(q_unary '{:find [(pull ?e [*])] :where [[?e :xt/id]]})))
(defn edn->pprint [edn]
(with-out-str (pprint edn)))
(defn write-edn [file docs]
(->> (edn->pprint docs)
(spit file)))
(defn export [file db_ctx]
(->> (all_docs db_ctx)
(write-edn file)))
(defn seed [file db_ctx]
(let [{:keys [tx_sync]} db_ctx]
(->> (clojure.edn/read-string (slurp file))
(map (fn [entry] [:xtdb.api/put entry]))
tx_sync)))

View File

@ -0,0 +1,23 @@
[
{:xt/id "lifeline"
:xt/spec :beherbergung.model.ngo/record
:name "Mission Lifeline"
:beherbergung.model.login/login:ids ["login_crewing"]}
{:xt/id "warhelp"
:xt/spec :beherbergung.model.ngo/record
:name "Warhelp.eu"
:beherbergung.model.login/login:ids ["login_max_mueller"]}
{:xt/id "zentralwerk"
:xt/spec :beherbergung.model.ngo/record
:name "Zentralwerk e.V."}
{:xt/id "login_max_mueller"
:xt/spec :beherbergung.model.login/record
:mail "praxis@max.mueller.de"
:password-hash "100$12$argon2id$v13$hq47jacLIYoiNMD9kdyy+w$ISDi+bSSTmsgqu648LQLv7ySU+lG2VGKRfa06HNfjzk$$$" #_"i!A;z\"'^G3Q)w])%83)" }
{:xt/id "login_crewing"
:xt/spec :beherbergung.model.login/record
:mail "crewing@example-ngo.com"
:password-hash "100$12$argon2id$v13$lWXab18B+9b79jAk7noAwg$01ak9vbuyxhuKDvBnWV8wuwxIJ5GR6zjz/lJhdw1s+I$$$" #_"Vr(+cFtUG=rsj2:/]*uR" }
]

View File

@ -0,0 +1,81 @@
(ns beherbergung.db.state
(:require[xtdb.api :as xtdb]
[clojure.java.io :as io]
[beherbergung.db.export :refer [export seed ]]
[mount.core :as mount :refer [defstate]]
[beherbergung.config.state :refer [env]]
[beherbergung.db.validate :refer [validate-db validate-tx]]))
(defn export-named-by-date [db_ctx cause]
(when (:db-export-prefix env)
(let [date (.format (java.text.SimpleDateFormat. "yyyy-MM-dd_HH:mm:ss")
(.getTime (java.util.Calendar/getInstance)))
file (str (:db-export-prefix env) date "_" cause ".edn")]
(when (:verbose env)
(println "Export database to:" file))
(io/make-parents file)
(export file db_ctx))))
(defn submit-tx [node tx-ops]
(xtdb/submit-tx node (validate-tx tx-ops)))
(defn q [node & args]
(apply xtdb/q (xtdb/db node) args))
(defn ->db_ctx []
(let [node (xtdb/start-node (when-not (:db-inmemory env)
{:my-rocksdb {:xtdb/module 'xtdb.rocksdb/->kv-store
:db-dir (clojure.java.io/file (:db-dir env))
:sync? true}
:xtdb/tx-log {:kv-store :my-rocksdb}
:xtdb/document-store {:kv-store :my-rocksdb}})) ;; To optimize for read performance, we might switch to LMDB (B-Tree instead of LSM-Tree)
;; But for our workload it doesn't matter much
db_ctx {:node node
:tx (fn [tx-ops]
(submit-tx node tx-ops))
:tx_sync (fn [tx-ops]
(->> (submit-tx node tx-ops)
(xtdb.api/await-tx node)))
:tx-committed? (fn [transaction]
#_(println "synced" (xtdb/sync node))
#_(println "awaited" (xtdb/await-tx node transaction))
(xtdb/tx-committed? node transaction))
:tx-fn-put (fn [fn-name quoted-fn]
;; In future we may want add transaction functions only once (at startup)
(xtdb/submit-tx node [[::xtdb/put {:xt/id fn-name :xt/fn quoted-fn}]]))
:tx-fn-call (fn [fn-name & args]
(xtdb/submit-tx node [(concat [::xtdb/fn fn-name] args)]))
:sync (fn [] (xtdb/sync node))
:q (fn [& args]
(apply q node args))
:q_unary (fn [& args]
;; A query returning unary results
(->> (apply q node args)
(map first)))
:q_id (fn [& args]
;; A query returning only 1 result
(-> (apply q node args)
first))
:q_id_unary (fn [& args]
;; A query returning only 1 unary result
(-> (apply q node args)
ffirst))}]
(export-named-by-date db_ctx "start") ;; before seeding
(let [seed-file (if (not-empty (:db-seed env))
(:db-seed env)
(io/resource "beherbergung/db/seed/example.edn"))]
(when (:verbose env)
(println "Seed the database from:" seed-file))
(seed seed-file db_ctx))
(if (:db-validate env)
(or (validate-db db_ctx)
(System/exit 1))
db_ctx)))
(defstate db_ctx
:start (->db_ctx)
:stop (do (export-named-by-date db_ctx "stop")
(.close (:node db_ctx))))

View File

@ -0,0 +1,46 @@
(ns beherbergung.db.validate
(:require [clojure.spec.alpha :as s]
[beherbergung.db.export :refer [all_docs write-edn]]
[clojure.pprint :refer [pprint]]
[clojure.tools.logging :refer [error]]))
(defn validate
"Validate a xtdb-document or a collection of documents.
When not conforming to the spec, an explaination is associated."
[doc]
(if (map? doc)
(when-not (:xt/fn doc)
(let [spec (:xt/spec doc)]
(when-not spec
(error ":xt/spec must not be empty!" doc))
(if (s/valid? spec doc)
doc
(assoc doc :explain (s/explain-data spec doc)))))
(map validate doc)))
(defn validate-db
"Validate the database.
The db_ctx is only returned, when all documents have been confirmed."
[db_ctx]
(let [validated-docs (validate (all_docs db_ctx))
errors (filter :explain validated-docs)
file "/tmp/validation-errors"]
(if (not-empty errors)
(do
(println "There have been validation errors in" (count errors) "database documents.")
(println "It seems that the latest update changed this specs:" (into [] (keys (group-by :xt/spec errors))))
(write-edn file errors)
(println "Details have been written to:" file))
db_ctx)))
(defn validate-tx
"Validate docs before they are written to the database."
[tx-ops]
(let [docs (->> tx-ops
(filter #(= :xtdb.api/put (first %)))
(map second))
errors (filter :explain (validate docs))]
(if (not-empty errors)
(do (println "Transaction canceled due to validiation errors:")
(pprint errors))
tx-ops)))

View File

@ -0,0 +1,12 @@
(ns beherbergung.model.auth
(:require [clojure.spec.alpha :as s]
[specialist-server.type :as t]
[beherbergung.model.login :as login]))
(s/def ::jwt t/string)
(t/defobject Auth {:name "Auth" :kind t/input-object-kind :description "Authentication requires either a valid mail+password combination or a jwt obtained by an earlier login."}
:opt-un [::login/mail ::login/password
::jwt])
(s/def ::auth Auth)

View File

@ -0,0 +1,7 @@
(ns beherbergung.model.export
(:require [clojure.spec.alpha :as s]
[specialist-server.type :as t]))
(s/def ::exit t/int)
(s/def ::result (s/keys :req-un [::exit ::out ::err]))

View File

@ -0,0 +1,20 @@
(ns beherbergung.model.login
(:require [clojure.spec.alpha :as s]
[specialist-server.type :as t]))
(s/def ::mail t/string) ;; Used as login-name
(s/def ::password-hash t/string)
(s/def ::invited-by t/string)
(s/def ::record (s/keys :req-un [::mail ::password-hash] :opt-un [::invited-by]))
(s/def ::login (s/keys :req-un [::mail ::password-hash]))
(s/def ::login:id t/string)
(s/def ::password t/string) ;; The unhashed password is not part of the login schema
(s/def ::login:ids (s/or :1 ::login:id
:* (s/* ::login:id)))

View File

@ -0,0 +1,20 @@
(ns beherbergung.model.ngo
(:require [clojure.spec.alpha :as s]
[specialist-server.type :as t]))
(s/def ::ngo (s/keys :req-un [::id ::name]))
(s/def ::ngo:id t/id)
(t/defscalar NgoRefs
{:name "NgoRefs" :description "Either a collection of ngo-ids or `any`"}
(s/conformer #(cond (coll? %) (set %)
(= "any" (name %)) :any
:else :clojure.spec.alpha/invalid)))
(s/def ::record (s/keys :req-un [::name]))
(defn db->graphql [record]
(some-> record
(select-keys [:xt/id :name])
(assoc :id (:xt/id record))))

View File

@ -0,0 +1,40 @@
(ns beherbergung.resolver.core
(:require [specialist-server.core :refer [executor]]
[mount.core :as mount :refer [defstate]]
[beherbergung.config.state :refer [env]]
[beherbergung.db.state :refer [->db_ctx db_ctx]]
;; public
;; any login
[beherbergung.resolver.root.login :refer [login]]
;; ngo login
[beherbergung.resolver.root.ngo.ngo-example :refer [ngo_example]]
;; admin passphrase
[beherbergung.resolver.root.admin.export :refer [export]]))
(def graphql* (executor {:query {:login #'login
:ngo_example #'ngo_example
:export #'export}
:mutation {}}))
(defn ->graphql
"Create a wrapped graphql-executor, that merges context into the request.
For default usage in the app, the db_ctx should be a singleton handled by mount.
When {:singleton? true} is used, closing the db (deleting the lock) is provided by mount.
Since all testcases within a file run in parallel, several db instances are wanted to avoid race conditions.
It's easy to get an executor with a new db-instance by (->graphql) for testcases with mutations.
The easiest way of having several instances without worrying about locks is using the config option {:db-inmemory true}."
[& {:keys [singleton?] :or {singleton? false}}]
(let [db_ctx (if singleton? db_ctx (->db_ctx))]
(fn [query]
(graphql* (-> query
(assoc-in [:context :db_ctx]
db_ctx)
(assoc-in [:context :validate-output?]
(or (get-in query [:context :validate-output?])
(:validate-output env))))))))
(defstate graphql
:start (beherbergung.resolver.core/->graphql :singleton? true))

View File

@ -0,0 +1,10 @@
This can be used for debugging or to test with a dump of the productive database before releasing a new software version:
```sh
curl 'https://URL/graphql' -H 'Content-Type: application/json' --data '{"query": "query Export{ export(password: \"ADMIN_PASSPHRASE\"){out err} }"}' | jq '.data.export.out' -r > /tmp/export.gpg
```
```sh
cd backend
gpg --decrypt /tmp/export.gpg | DB_SEED=/dev/stdin DB_INMEMORY=true lein run
```

View File

@ -0,0 +1,23 @@
(ns beherbergung.resolver.root.admin.export
(:require [clojure.spec.alpha :as s]
[specialist-server.type :as t]
[beherbergung.model.login :as login]
[beherbergung.model.export :as export]
[beherbergung.auth.admin :refer [admin?]]
[beherbergung.db.export :refer [all_docs edn->pprint]]
[beherbergung.security.encryption.gpg :refer [encrypt]]
[beherbergung.config.state :refer [env]]))
(s/fdef export
:args (s/tuple map? (s/keys :req-un [::login/password]) map? map?)
:ret (s/nilable ::export/result))
(defn export
"Export an encrypted database dump"
[_node opt ctx _info]
(when (admin? (:password opt))
(-> (all_docs (:db_ctx ctx))
(edn->pprint)
(encrypt (:admin-gpg-id env)))))
(s/def ::export (t/resolver #'export))

View File

@ -0,0 +1,17 @@
(ns beherbergung.resolver.root.login
(:require [clojure.spec.alpha :as s]
[specialist-server.type :as t]
[beherbergung.model.auth :as auth]
[beherbergung.auth.jwt.login]))
(s/fdef login
:args (s/tuple map? (s/keys :req-un [::auth/auth]) map? map?)
:ret (s/keys :opt-un [:auth/jwt]))
(defn login
"For a username+password get a jwt containing the login:id"
[_node opt ctx _info]
(let [auth (:auth opt)]
{:jwt (beherbergung.auth.jwt.login/login ctx (:mail auth) (:password auth))}))
(s/def ::login (t/resolver #'login))

View File

@ -0,0 +1,22 @@
(ns beherbergung.resolver.root.ngo.ngo-example
(:require [clojure.spec.alpha :as s]
[specialist-server.type :as t]
[beherbergung.auth.core :refer [auth+role->entity]]
[beherbergung.model.auth :as auth]
[beherbergung.model.ngo :as ngo]))
(s/def ::my_result_type t/string)
(s/fdef ngo_example
:args (s/tuple map? (s/keys :req-un [::auth/auth]) map? map?)
:ret (s/nilable ::my_result_type))
(defn ngo_example
"For an ngo login, we get a greeting"
[_node opt ctx _info]
(let [{:keys [_TODO]} (:db_ctx ctx)
[ngo:id] (auth+role->entity ctx (:auth opt) ::ngo/record)]
(when ngo:id
"hallo welt :)")))
(s/def ::ngo_example (t/resolver #'ngo_example))

View File

@ -0,0 +1,17 @@
(ns beherbergung.security.encryption.gpg
(:require [clojure.java.shell :refer [sh]]))
(defn encrypt
"Requires `gpg` to be installed and the keyid to be in the keyring"
[plaintext keyid]
(sh "gpg" "--batch" "--encrypt" "--recipient" keyid "--armor"
:in plaintext))
#_(defn encrypt
"This version should better be audited before using it"
[plaintext keyids]
(let [recipient_args (interleave (repeatedly (constantly "--recipient"))
(map str keyids))
sh_options [:in plaintext]
args (concat ["gpg" "--batch" "--encrypt"] recipient_args ["--armor"] sh_options)]
(apply sh args)))

View File

@ -0,0 +1,42 @@
(ns beherbergung.webserver.handler
(:require [compojure.core :refer [defroutes GET POST]]
[compojure.route :as route]
[ring.util.response :refer [response]]
[ring.middleware.cors :refer [wrap-cors]]
[beherbergung.webserver.middleware :refer [wrap-graphql wrap-graphiql wrap-nextjs-frontend wrap-frontend-config wrap-defaults]]
[beherbergung.resolver.core :refer [graphql]]
[beherbergung.config.state :refer [env]]))
(def frontend-url (:frontend-base-url env))
(defroutes app-routes
(GET "/" [] ;; When using a fullstack-build, this route is overwritten by `wrap-nextjs-frontend`
(str "<p>The backend takes care of data storage and securing its access.<br/>"
" It provides a <a href=\"/graphql\">Graphql-API Endpoint</a>.<br/>"
" You may want explore the schema and send queries using <a href=\"/graphiql/index.html\">GraphiQL</a>."
"</p>"
"<p>This build doesn't include the frontend.<br/>"
" You may want start it independently and open <a href=\"" frontend-url "\">" frontend-url "</a>.</br>"
" Alternatively production builds including the frontend are available via nix."
"</p/>"))
(->
(POST "/graphql" req
(response (graphql (:body req))))
wrap-graphql
wrap-graphiql)
(route/not-found "Not Found"))
(def app
(-> app-routes
(wrap-nextjs-frontend)
(wrap-frontend-config)
(wrap-defaults)
(wrap-cors :access-control-allow-origin [#"http://localhost:3000"]
:access-control-allow-methods [:get :put :post :delete])))

View File

@ -0,0 +1,102 @@
(ns beherbergung.webserver.middleware
(:require [beherbergung.config.state :refer [env]]
[ring.middleware.resource :refer [wrap-resource]]
[ring.middleware.webjars :refer [wrap-webjars]]
[ring.middleware.json :refer [wrap-json-response wrap-json-body]]
[ring.middleware.content-type :refer [wrap-content-type]]
[ring.middleware.not-modified :refer [wrap-not-modified]]
[ring.util.json-response :refer [json-response]]
[ring.util.response :refer [resource-response content-type]]
[lib.graphql.middleware :refer [wrap-graphql-error]]
[co.deps.ring-etag-middleware :as etag]
[lib.resources.list-resources :refer [list-resources]]
[clojure.string :as string :refer [ends-with?]]))
(defn wrap-debug
[handler]
(fn [req]
(let [res (handler req)
selected_headers ["if-modified-since" "if-none-match"]]
(when (:verbose env)
(prn)
(println (:uri req))
(prn (keys (sort (:headers req))))
(prn (select-keys (:headers req) selected_headers))
(prn (:status res) (:headers res)))
res)))
(defn wrap-graphiql
"Add graphqli using org.webjars/graphiql and resources/public/graphiql/index.html"
[handler]
(-> handler
(wrap-webjars)
(wrap-resource "public")))
(defn wrap-graphql
"Handle Content-Type and Errors of graphql-endpoint"
[handler]
(-> handler
(wrap-graphql-error)
(wrap-json-body {:keywords? true :bigdecimals? false}) ;; java.math.BigDecimal doesn't conform to t/float or float?
(wrap-json-response)))
#_(defn wrap-rest
"Use the same error handling as for graphql"
[handler]
(-> handler
(wrap-graphql-error)))
(defn wrap-nextjs-frontend
"Serve the frontend:
1. Everything from the backend that is not the mocked /
2. Any directory should serve the index.html when existing
3. Serve an .html file instead of a requested file without extension
4. When a not existing file is accessed in a directory with only 1 .html (probably a route with a variable), serve that instead
5. If all attempts failed, pass the 404"
[handler]
(fn [req]
(let [res (handler req)
path (string/replace (:uri req) #"/[^/]*$" "/")
file (string/replace (:uri req) #".*/" "")
html (->> (list-resources (str "public" path))
(remove #(re-matches #".+[/].*" %)) ;; Only files that are not in a subdirectory
(filter #(re-matches #".*\.html" %)))]
(cond (not (or (= 404 (:status res))
(= "/" (:uri req))))
res
(and (ends-with? (:uri req) "/")
(some #{"index.html"} html))
{:status 302
:headers {"Location" (str (:uri req) "index.html")}
:body ""}
(some #{(str file ".html")} html)
{:status 302
:headers {"Location" (str (:uri req) ".html")}
:body ""}
(= 1 (count html))
(-> (resource-response (str "public" path (first html)))
(content-type "text/html"))
:else
res))))
(defn wrap-frontend-config
"Provide config for static build of frontend"
[handler]
(fn [req]
(if (= "/config.json" (:uri req))
;; If the config would become larger, we should calc an ETag header
;; For using `etag/wrap-file-etag`, body would need to be of instance? File
(json-response {:base_url (:frontend-base-url env)
:backend_base_url (:frontend-backend-base-url env)})
(handler req))))
(defn wrap-defaults [handler]
(-> handler
(wrap-content-type)
(wrap-json-response)
(etag/wrap-file-etag)
(wrap-not-modified)
(wrap-debug)))

View File

@ -0,0 +1,25 @@
(ns beherbergung.webserver.state
(:gen-class) ;; this Class contains our -main function
(:require [ring.adapter.jetty]
[ring.middleware.reload]
[beherbergung.webserver.handler]
[mount.core :as mount :refer [defstate]]
[beherbergung.config.state]
[signal.handler :refer [with-handler]]))
(defstate ^{:on-reload :noop} ;; When the app is recompiled, mount should not care, but we use ring.middleware.reload/wrap-reload
webserver
:start (do (println (str "Start server at http://localhost:" (:port beherbergung.config.state/env)))
(ring.adapter.jetty/run-jetty (ring.middleware.reload/wrap-reload #'beherbergung.webserver.handler/app)
{:port (:port beherbergung.config.state/env) :join? false}))
:stop (.stop webserver))
(defn -main [& _args]
(mount/start)
(let [finaly (fn [] (mount/stop) ;; Export the database
(System/exit 0))]
(with-handler :term (finaly)) ;; kill
(with-handler :int (finaly))) ;; Ctrl+C
(mount.core/running-states)) ;; Return value for debugging when called on repl

24
backend/src/config.edn Normal file
View File

@ -0,0 +1,24 @@
{:verbose false
:port 4000
:validate-output true
:db-inmemory false
:db-dir "./data/xtdb/rocksdb"
:db-seed ""
:db-export-prefix "./data/export/"
:db-validate true
;:mail-host ""
;:mail-user ""
;:mail-pass ""
;:mail-port 587
;:mail-from nil
:admin-passphrase nil
:admin-gpg-id "9EA68B7F21204979645182E4287B083353C3241C"
:frontend-base-url "http://localhost:4000"
:frontend-backend-base-url "http://localhost:4000"
}

View File

@ -0,0 +1,19 @@
(ns lib.graphql.middleware
(:require [ring.util.response :refer [status]]
[ring.util.json-response :refer [json-response]]
[clojure.stacktrace :refer [print-stack-trace]]))
(defn wrap-graphql-error
"An alternative to ring.middleware.stacktrace/wrap-stacktrace, but more compliant with graphql.
The response is a json datastructure with an `errors` key.
specialist-server.core only catches ExceptionInfo"
[handler]
(fn [request]
(try
(handler request)
(catch Throwable e
(-> (json-response {:errors [{:message (ex-message e)
:trace (with-out-str (print-stack-trace e))}]})
(status 500))))))

View File

@ -0,0 +1,41 @@
(ns lib.resources.list-resources
(:require [clojure.java.io :as io]
[clojure.string :as s]
[clojure.set :refer [subset?]]))
(def ^:private running-jar
(-> :keyword class (.. getProtectionDomain getCodeSource getLocation getPath)))
(defn list-jar-resources [prefix]
(let [jar (java.util.jar.JarFile. running-jar)
entries (.entries jar)
entries-rec (loop [result []]
(if (.hasMoreElements entries)
(recur (conj result (.. entries nextElement getName)))
result))]
(->> entries-rec
(filter #(s/starts-with? % prefix))
(drop 1)
(map #(s/replace % prefix "")))))
(defn getPath [f]
(when f (.getPath f)))
(defn list-dev-resources [prefix]
(let [root-path (getPath (io/resource prefix))]
(some->> (io/file (io/resource prefix))
file-seq
(drop 1)
(map #(if (.isDirectory %)
(str (getPath %) "/")
(getPath %)))
(map #(s/replace % root-path "")))))
(defn list-resources [prefix]
(try (list-dev-resources prefix)
(catch java.lang.IllegalArgumentException _
(list-jar-resources prefix))))
(defn selftest []
(and (subset? #{"/graphiql/" "/graphiql/index.html"} (set (list-resources "public")))
(subset? #{"graphiql/" "graphiql/index.html"} (set (list-resources "public/")))))