backend: template (from swlkup)

* debug why http://localhost:4000/graphiql/index.html doesn't load
* adapt tests from swlkup
* adapt flake from swlkup and test build pipeline
Johannes Lötzsch 1 year ago
parent d6c6687823
commit 7e8daca015

@ -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}}

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

backend/.gitignore vendored

@ -0,0 +1,15 @@

@ -0,0 +1,23 @@
# Access via repl:
lein repl ## from somewhere within the `backend` directory
(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](
# Web UI
If you are looking for a Web UI for inspecting the XTDB database, you may want use [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`.

@ -0,0 +1,63 @@
{ pkgs ? import <nixpkgs> {},
buildMavenRepositoryFromLockFile ? (import (fetchTarball "") {}).buildMavenRepositoryFromLockFile,
patchPublic ? null
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/
(pkgs.writeScriptBin "${pname}" ''
${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 JAVA_TOOL_OPTIONS=' -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; }

@ -0,0 +1,16 @@
{ pkgs ? import <nixpkgs> {},
mvn2nix ? (import (fetchTarball "") {}).mvn2nix
(pkgs.writeScriptBin "backendUpdatedDeps" ''
#!${pkgs.runtimeShell} -e
#${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 'When you changed dependencies, you also want run nvd-check'
echo "Generating mvn2nix-lock.json, please wait"
${mvn2nix}/bin/mvn2nix --repositories > nix/deps/mvn2nix-lock.json

@ -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 []]
[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 ["" ;; 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

@ -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
echo $@ >> $FILE
cat >> $FILE
echo >> $FILE

@ -0,0 +1,60 @@
<!DOCTYPE html>
<meta charset="UTF-8">
body {
height: 100%;
margin: 0;
width: 100%;
overflow: hidden;
#graphiql {
height: 100vh;
<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>
<div id="graphiql">Loading...</div>
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.
React.createElement(GraphiQL, {
fetcher: graphQLFetcher

@ -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
(and (:admin-passphrase env)
(= passphrase (:admin-passphrase env))))

@ -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])))

@ -0,0 +1,19 @@
(ns beherbergung.auth.jwt.defaults
(:require [beherbergung.auth.jwt.state :refer [secret]]
[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."
(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))
(defn unsign [jwt]
(buddy.sign.jwt/unsign jwt secret))

@ -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)))

@ -0,0 +1,10 @@
(ns beherbergung.auth.jwt.state
(:require [crypto.random]
[mount.core :as mount :refer [defstate]]
(def secret_length:bytes 64) ;; recommended by
(defstate secret
:start (or (:jwt-secret beherbergung.config.state/env)
(crypto.random/bytes secret_length:bytes)))

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

@ -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)))))

@ -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 ""))))

@ -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)
(let [algo :argon2]
(verify-with algo password pwhash))))

@ -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]}
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]}

@ -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))

@ -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)))

@ -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]]
(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
::db-inmemory ::db-dir
::db-seed ::db-export-prefix
;::mail-host ::mail-user ::mail-pass ::mail-port ::mail-from
(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 ":" "")
(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)))

@ -0,0 +1,25 @@
(ns beherbergung.db.export
(:require [clojure.pprint :refer [pprint]]
(defn all_docs [db_ctx]
(let [{:keys [sync q_unary]} db_ctx]
(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]))

@ -0,0 +1,23 @@
{:xt/id "lifeline"
:name "Mission Lifeline"
:beherbergung.model.login/login:ids ["login_crewing"]}
{:xt/id "warhelp"
:name ""
:beherbergung.model.login/login:ids ["login_max_mueller"]}
{:xt/id "zentralwerk"
:name "Zentralwerk e.V."}
{:xt/id "login_max_mueller"
:xt/spec :beherbergung.model.login/record
:mail ""
: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 ""
:password-hash "100$12$argon2id$v13$lWXab18B+9b79jAk7noAwg$01ak9vbuyxhuKDvBnWV8wuwxIJ5GR6zjz/lJhdw1s+I$$$" #_"Vr(+cFtUG=rsj2:/]*uR" }

@ -0,0 +1,81 @@
(ns beherbergung.db.state
(:require[xtdb.api :as xtdb]
[ :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 ( (: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)
:q_id_unary (fn [& args]
;; A query returning only 1 unary result
(-> (apply q node args)
(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))
(defstate db_ctx
:start (->db_ctx)
:stop (do (export-named-by-date db_ctx "stop")
(.close (:node db_ctx))))

@ -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]]
[ :refer [error]]))
(defn validate
"Validate a xtdb-document or a collection of documents.
When not conforming to the spec, an explaination is associated."
(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)
(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."
(let [validated-docs (validate (all_docs db_ctx))
errors (filter :explain validated-docs)
file "/tmp/validation-errors"]
(if (not-empty errors)
(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))
(defn validate-tx
"Validate docs before they are written to the database."
(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))

@ -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
(s/def ::auth Auth)

@ -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]))

@ -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)))

@ -0,0 +1,20 @@
(: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))))

@ -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
[ :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]
(assoc-in [:context :validate-output?]
(or (get-in query [:context :validate-output?])
(:validate-output env))))))))
(defstate graphql
:start (beherbergung.resolver.core/->graphql :singleton? true))

@ -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:
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
cd backend
gpg --decrypt /tmp/export.gpg | DB_SEED=/dev/stdin DB_INMEMORY=true lein run

@ -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]]
[ :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))
(encrypt (:admin-gpg-id env)))))
(s/def ::export (t/resolver #'export))

@ -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]
(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))

@ -0,0 +1,22 @@
(:require [clojure.spec.alpha :as s]
[specialist-server.type :as t]
[beherbergung.auth.core :refer [auth+role->entity]]
[beherbergung.model.auth :as auth]
[ :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))

@ -0,0 +1,17 @@
(:require [ :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)))

@ -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>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."
(POST "/graphql" req
(response (graphql (:body req))))
(route/not-found "Not Found"))
(def app
(-> app-routes
(wrap-cors :access-control-allow-origin [#"http://localhost:3000"]
:access-control-allow-methods [:get :put :post :delete])))

@ -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
(fn [req]
(let [res (handler req)
selected_headers ["if-modified-since" "if-none-match"]]
(when (:verbose env)
(println (:uri req))
(prn (keys (sort (:headers req))))
(prn (select-keys (:headers req) selected_headers))
(prn (:status res) (:headers res)))
(defn wrap-graphiql
"Add graphqli using org.webjars/graphiql and resources/public/graphiql/index.html"
(-> handler
(wrap-resource "public")))
(defn wrap-graphql
"Handle Content-Type and Errors of graphql-endpoint"
(-> handler
(wrap-json-body {:keywords? true :bigdecimals? false}) ;; java.math.BigDecimal doesn't conform to t/float or float?
#_(defn wrap-rest
"Use the same error handling as for graphql"
(-> handler
(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"
(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))))
(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"))
(defn wrap-frontend-config
"Provide config for static build of frontend"
(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

@ -0,0 +1,25 @@
(ns beherbergung.webserver.state
(:gen-class) ;; this Class contains our -main function
(:require [ring.adapter.jetty]
[mount.core :as mount :refer [defstate]]
[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
: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]
(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

@ -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"

@ -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"
(fn [request]
(handler request)
(catch Throwable e
(-> (json-response {:errors [{:message (ex-message e)
:trace (with-out-str (print-stack-trace e))}]})
(status 500))))))

@ -0,0 +1,41 @@
(ns lib.resources.list-resources
(:require [ :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)))
(->> 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))
(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/")))))