First commit. Taken from open source branch of internal sample-tracking application.

This commit is contained in:
Robert Schiemann
2023-03-08 10:11:42 -07:00
parent fa491f63de
commit fe0946c53a
220 changed files with 15808 additions and 0 deletions

32
.gitignore vendored Normal file
View File

@@ -0,0 +1,32 @@
pom.xml
pom.xml.asc
*.jar
*.class
/lib/
/classes/
/target/
/checkouts/
/.lein-*
.lein-deps-sum
.lein-repl-history
.lein-plugins/
.lein-failures
.nrepl-port
.cpcache/
/.idea
/*.iml
/*.log
/*-init.clj
/resources/public/cljs-out
out
.vscode
.rebel_readline_history
.clj-kondo/.cache
figwheel_server.log
node_modules
dist
secrets
.DS_Store
.calva
.lsp
/deploy/datomic/releases/

12
CHANGELOG.md Executable file
View File

@@ -0,0 +1,12 @@
# Change Log
Follows conventions in
[keepachangelog.com](http://keepachangelog.com/en/1.0.0/).
## Unreleased
## 0.1 - 2018-02-08
### Added
* Initial release

14
Dockerfile Executable file
View File

@@ -0,0 +1,14 @@
FROM openjdk:11
LABEL maintainer="rschiemann@parkerici.org"
EXPOSE 8989
WORKDIR /sample-tracking
COPY resources resources
COPY target/sample-tracking-standalone.jar .
# $PORT didn't work
# get config from kub env vars
ENTRYPOINT ["java", "-jar", "sample-tracking-standalone.jar", "server", "-p", "8989"]

View File

1
Procfile Executable file
View File

@@ -0,0 +1 @@
web: java $JVM_OPTS -cp target/starter.jar clojure.main -m starter.server

389
README.md Normal file
View File

@@ -0,0 +1,389 @@
# sample-tracking
## Admin Console Documentation
Instructions for the usage of the admin console can be found on the [eReq Admin Console page](docs/console.md).
## Tech Stack
Server side [ring](https://github.com/ring-clojure/ring) app:
* Static asset serving
* JSON REST API with echo endpoint for prototyping
* Hot code reloading
Client side [re-frame](https://github.com/Day8/re-frame) app:
* Routing using [bidi](https://github.com/juxt/bidi) and [pushy](https://github.com/clj-commons/pushy)
* Event interceptor that validates app DB against spec in development
* Components structured into separate namespaces each with their own db spec, event handlers, subscriptions, and views.
Namespaced using the
re-frame [synthetic namespace](https://github.com/Day8/re-frame/blob/master/docs/Namespaced-Keywords.md) pattern
* Pages separated out with potential to use parallel structure to components as their complexity grows
To demonstrate things a homepage with a sign up form that POSTs to an API which just echo's back the response is
provided.
## Development Mode
Start figwheel-main:
```bash
$ lein fig:build
```
This should start a ring server and automatically building your application. Once it's ready, it should open a new
browser window with the application for you.
## Node packages and interop
Setup using this guide: [Figwheel-main and NPM Modules](https://figwheel.org/docs/npm.html)
To add new modules, add them to npm
```bash
$ npm install --save <package>
```
And then import the package add it to the window in src/js/index.js. Before starting the webserver, run the following
commands to update the bundle of external modules:
```bash
$ npm install
$ npx webpack --mode=development
```
## Creating and serving the database
Download Datomic Pro and run the following commands from within the unzipped folder.
Start the transactor with your license in the properties in one terminal.
```bash
./bin/transactor ../dev-transactor.properties
```
In s separate terminal, start the repl and delete any existing databases and recreate them. You can skip the
delete-database step if this is your first time creating them.
```bash
./bin/repl
Clojure 1.10.1
```
```clojure
user=> (require 'datomic.api)
nil
user=> (datomic.api/delete-database "datomic:dev://localhost:4334/ereq-dev")
true
user=> (datomic.api/create-database "datomic:dev://localhost:4334/ereq-dev")
true
user=> (datomic.api/delete-database "datomic:dev://localhost:4334/ereq-test")
true
user=> (datomic.api/create-database "datomic:dev://localhost:4334/ereq-test")
true
```
Start serving the databases in separate terminals.
```bash
./bin/run -m datomic.peer-server -h localhost -p 8998 -a myaccesskey,mysecret -d ereq-dev,datomic:dev://localhost:4334/ereq-dev
```
```bash
./bin/run -m datomic.peer-server -h localhost -p 9119 -a myaccesskey,mysecret -d ereq-test,datomic:dev://localhost:4334/ereq-test
```
## Populating the database
### Initializing the database
You can run the following command to transact the schema and add initial form data:
```bash
lein run test-setup
```
### Editing and transacting the schema
This project uses Datomic as its database. Datomic configuration defaults are stored in `resources/config/datomic.edn`,
and can be overridden by environment variables defined in the same file. The database schema is stored
in `src/clj/org/parkerici/sample_tracking/db/schema.clj`.
If you make changes to the schema, run `lein run transact-schema` to generate a new Datomic schema file
at `resources/schema.edn` and to transact the changes to the configured database.
### Populating roles
To add new roles from the configuration files to the database run the following command. You only need to do this if you
are adding new roles.
```bash
lein run create-roles
```
### Adding admin users
To add an admin user from the CLI run the following command.
```bash
lein run add-admin user@gsuite.com
```
## Running Tests
The test database ereq-test must be running for tests to run successfully.
Before running tests for the first time you must populate the test database.
```bash
lein with-profile test run test-setup
```
Sometimes with-profile doesn't work. If this is the case you can manually set the environment variables.
```bash
export DATOMIC_ENDPOINT=localhost:9119
export DATOMIC_DB_NAME=ereq-test
export SEND_MANIFEST_EMAILS=false
```
Once you've done this you can run the tests with the following command.
```bash
lein test
```
## Creating new Forms
The process for creating new forms can be found [here](docs/forms.md).
## Deploying on GCS
### Create a k8s cluster
Make sure it's VPC native
### Create a Postgres database
https://console.cloud.google.com/sql/instances
Record name and password: sample-tracking / <pwd>
This can take over a half hour to complete....but you can get IP address first
Give it a Private IP address Use Connections Tab, Turn on the required API. etc
### Create Datomic DB
See https://docs.datomic.com/on-prem/storage.html
Connect to the database:
```bash
$ gcloud sql connect <cloudsql-db-name> --user=postgres
```
Copy and paste the Postgres datomic `postgres-db.sql` scripts into the prompt. You have to delete the TABLESPACE
argument from the db creation script.
After you create the database, connect to it by running \c datomic in the psql command line.
Next, run the `postgres-table.sql` and the `postgres-user.sql` in the `datomic` db.
### Create App DB
[ don՚t do this if you are restoring from backup! ]
Setup and create the transactor pod:
```bash
$ kubectl --namespace=default create secret generic datomic-transactor-properties --from-file=transactor.properties=./secrets/transactor.properties
$ kubectl apply -f ./deploy/k8s/datomic/transactor.yaml
```
Attach to the pod and create the DB in Datomic. Make sure to substitute the IP of the postgres instance it should be
same as in transactor.properties.
```bash
$ kubectl get pods
$ kubectl exec -it $(kubectl get pods --selector=app=datomic-transactor -o jsonpath={.items..metadata.name}) -- /bin/bash
$ bin/repl
> (require '[datomic.api :as d])
> (def db-uri "datomic:sql://sample-tracking?jdbc:postgresql://<DB-IP>:5432/datomic?user=datomic&password=datomic")
> (d/create-database db-uri)
```
## CI Deploy
The `.circleci` folder contains the `config.yaml` file that describes the deployment to the previously configured
cluster.
It requires a public IP for each environment `ereq-dev` and `ereq-prod`. Non `master` branches will be deployed to `dev`
for every commit, and `master` deploys to `prod`.
Each environment requires the environment variables in CircleCI to be configured appropriately. These are in the
CircleCI Contexts and Project Environment Variables.
The CI deploy uses [Google managed certificates](https://cloud.google.com/kubernetes-engine/docs/how-to/managed-certs)
and a [Google Ingress](https://cloud.google.com/kubernetes-engine/docs/how-to/load-balance-ingress) (as opposed to the
Nginx Ingress)
The HTTP-to-HTTPS redirect feature of the Ingress is still in beta and only available in GKE 1.18+. 1.18+ is still on
the Rapid release channel which can have some instability. To avoid that, we are using
a [manual partial LB](https://cloud.google.com/load-balancing/docs/https/setting-up-http-https-redirect#partial-http-lb)
. The summarized steps to setup this partial LB are:
* Ensure HTTP is not served on the Ingress using the annotiation `kubernetes.io/ingress.allow-http: "false"` on the
Ingress
* Manually create a load balancer on the same IP as the Ingress with the HTTP-to-HTTPS redirect as described in the
linked doc above.
## Non-CI Deploy
### Manually building Docker image
To build and package into Docker for dev:
```bash
$ npx webpack && lein package && docker build -t gcr.io/dev-project/sample-tracking:0.1.0 .
```
And for prod:
```bash
$ npx webpack && lein package && docker build -t gcr.io/production-project/sample-tracking:0.1.0 .
```
To push to GCR:
```bash
$ docker push <image-tag>
```
### Deploy the Peer Server and Datomic Services
```bash
$ kubectl apply -f ./deploy/k8s/datomic/transactor-service.yaml
$ kubectl apply -f ./deploy/k8s/datomic/peer.yaml
$ kubectl apply -f ./deploy/k8s/datomic/peer-service.yaml
```
### Run the Deploy Job
As of now this job transacts the schema to the database.
```bash
$ kubectl apply -f deploy/k8s/sample-tracking/deploy-job.yaml
```
To get the results of the job:
```bash
$kubectl get jobs
NAME COMPLETIONS DURATION AGE
deploy-tasks 1/1 21s 55s
```
To get the pod name or check on the logs:
```bash
$ kubectl get pods
NAME READY STATUS RESTARTS AGE
datomic-peer-cb5cfc5b6-5shhm 1/1 Running 0 51m
datomic-transactor-c69857949-6cj6m 1/1 Running 0 71m
deploy-tasks-gjqg4 1/1 Running 0 16s
```
```bash
$ kubectl logs deploy-tasks-gjqg4
[main] INFO org.eclipse.jetty.util.log - Logging initialized @5528ms to org.eclipse.jetty.util.log.Slf4jLog
20-03-04 00:53:00 deploy-tasks-gjqg4 INFO [org.parkerici.sample-tracking.cli:55] - Running with environment :default
20-03-04 00:53:00 deploy-tasks-gjqg4 INFO [org.parkerici.sample-tracking.db.schema:182] - Writing schema out to file.
20-03-04 00:53:00 deploy-tasks-gjqg4 INFO [org.parkerici.sample-tracking.db.schema:184] - Transacting schema.
```
Once it's successful, delete the job.
```bash
$ kubectl delete job deploy-tasks
```
### Deploy the App Server and Service
#### Deploying without a Domain Name
Deploy the app and the basic service to the cluster.
```bash
$ kubectl apply -f ./deploy/k8s/sample-tracking/app.yaml
$ kubectl apply -f ./deploy/k8s/sample-tracking/app-basic-service.yaml
```
Get the IP address for the service.
```bash
$ kubectl get service/sample-tracking
NAME TYPE CLUSTER-IP EXTERNAL-IP PORT(S) AGE
sample-tracking LoadBalancer 10.110.5.220 34.82.204.132 80:31412/TCP 3m42s
```
#### Deploying with a Domain Name
Setup Helm locally.
```bash
$ brew install kubernetes-helm
```
Or make sure it's up to date if already installed.
```bash
$ brew upgrade kubernetes-helm
```
Reserve an **
unused/unbound** [reserved regional external IP from GCP](https://cloud.google.com/compute/docs/ip-addresses/reserve-static-external-ip-address)
IP address for the nginx load balancer.
```bash
gcloud compute addresses create sample-tracking --region <CLUSTER-REGION>
```
Install the nginx-ingress chart with the custom static IP. If you are installing multiple ingresses in the same culster
you must name them differently.
```bash
$ helm repo add stable https://kubernetes-charts.storage.googleapis.com
$ helm repo update
$ helm install nginx-ingress stable/nginx-ingress --set controller.service.loadBalancerIP=<RESERVED-IP>
```
We can use the following command to check when our static IP has been assigned to the load balancer.
```bash
$ kubectl get services -o wide nginx-ingress-controller
NAME TYPE CLUSTER-IP EXTERNAL-IP PORT(S) AGE SELECTOR
nginx-ingress-nginx-ingress LoadBalancer 10.110.4.204 <RESERVED-IP> 80:31312/TCP,443:30326/TCP 85s app=controller
```
Once this is done, create the application, service, and ingress to be exposed by the load balancer.
```bash
kubectl apply -f ./deploy/k8s/sample-tracking/app.yaml
kubectl apply -f ./deploy/k8s/sample-tracking/app-service.yaml
kubectl apply -f ./deploy/k8s/sample-tracking/app-ingress.yaml
```
## TODO
* Add test coverage
* Move all CircleCI environment variables into the Project Environment Variables.
# License
Mantis Viewer is distributed under Apache 2 license. See the [LICENSE](LICENSE.md) file for details.

29
deploy/datomic/Dockerfile Normal file
View File

@@ -0,0 +1,29 @@
FROM naartjie/alpine-lein
# Based on pointslope/datomic-pro-starter
# https://hub.docker.com/r/pointslope/datomic-pro-starter/dockerfile
MAINTAINER Mike Travers "mtravers@parkerici.org"
# Set the version to the one you're downloading.
ENV DATOMIC_VERSION=1.0.6202
ENV DATOMIC_HOME /opt/datomic-pro-$DATOMIC_VERSION
ENV DATOMIC_DATA $DATOMIC_HOME/data
RUN apk add --no-cache unzip curl
# Datomic Pro Starter as easy as 1-2-3
# 1. Download a release from my.datomic.com and put it in the releases folder
ADD releases/datomic-pro-1.0.6202.zip /tmp/datomic.zip
RUN unzip /tmp/datomic.zip -d /opt \
&& rm -f /tmp/datomic.zip
WORKDIR $DATOMIC_HOME
RUN echo DATOMIC HOME: $DATOMIC_HOME
# 3. Provide a CMD argument with the relative path to the
# transactor.properties file it will supplement the ENTRYPOINT
VOLUME $DATOMIC_DATA
EXPOSE 4334 4335 4336

View File

@@ -0,0 +1,4 @@
;;; Run by CI to create a local database
(require 'datomic.api)
(datomic.api/create-database "datomic:dev://localhost:4334/ereq-test")

View File

@@ -0,0 +1,22 @@
# transactor properties for local dev instances (and CI)
###################################################################
protocol=dev
host=localhost
port=4334
###################################################################
# See https://docs.datomic.com/on-prem/storage.html
license-key=${DATOMIC_LICENSE_KEY}
###################################################################
# See https://docs.datomic.com/on-prem/capacity.html
## Recommended settings for -Xmx1g usage, e.g. dev laptops.
memory-index-threshold=32m
memory-index-max=256m
object-cache-max=128m

View File

@@ -0,0 +1,14 @@
apiVersion: v1
kind: Service
metadata:
labels:
app: datomic-peer
name: datomic-peer
spec:
ports:
- name: datomic-peer
port: 8998
protocol: TCP
targetPort: 8998
selector:
app: datomic-peer

View File

@@ -0,0 +1,26 @@
apiVersion: apps/v1
kind: Deployment
metadata:
name: datomic-peer
labels:
app: datomic-peer
spec:
replicas: 1
selector:
matchLabels:
app: datomic-peer
template:
metadata:
labels:
app: datomic-peer
spec:
containers:
- name: datomic-peer
image: gcr.io/pici-ereq/datomic:1.0.6202
imagePullPolicy: Always
command: [ "./bin/run", "-m", "datomic.peer-server", "-h", "0.0.0.0", "-p", "8998", "-a", "myaccesskey,mysecret", "-d", "sample-tracking,datomic:sql://sample-tracking?jdbc:postgresql://$POSTGRES_IP:5432/datomic?user=datomic&password=datomic" ]
ports:
- containerPort: 8998
env:
- name: POSTGRES_IP
value: ${POSTGRES_IP}

View File

@@ -0,0 +1,7 @@
apiVersion: v1
kind: Secret
metadata:
name: datomic-transactor-properties
type: Opaque
data:
transactor.properties: ${B64_TRANSACTOR_PROPS}

View File

@@ -0,0 +1,14 @@
apiVersion: v1
kind: Service
metadata:
name: datomic-transactor
labels:
app: datomic-transactor
spec:
ports:
- name: datomic-transactor
protocol: TCP
port: 4334
targetPort: 4334
selector:
app: datomic-transactor

View File

@@ -0,0 +1,31 @@
apiVersion: apps/v1
kind: Deployment
metadata:
name: datomic-transactor
labels:
app: datomic-transactor
spec:
replicas: 1
selector:
matchLabels:
app: datomic-transactor
template:
metadata:
labels:
app: datomic-transactor
spec:
volumes:
- name: transactor-properties
secret:
secretName: datomic-transactor-properties
containers:
- name: datomic-transactor
image: gcr.io/pici-ereq/datomic:1.0.6202
imagePullPolicy: Always
command: [ "./bin/transactor", "config/transactor.properties" ]
ports:
- containerPort: 4334
volumeMounts:
- name: transactor-properties
mountPath: /opt/datomic-pro-1.0.6202/config/transactor.properties
subPath: transactor.properties

View File

@@ -0,0 +1,7 @@
apiVersion: networking.gke.io/v1beta2
kind: ManagedCertificate
metadata:
name: ereq-cert-dev
spec:
domains:
- dev-ereq.parkerici.org

View File

@@ -0,0 +1,7 @@
apiVersion: networking.gke.io/v1beta2
kind: ManagedCertificate
metadata:
name: ereq-cert-prod
spec:
domains:
- ereq.parkerici.org

View File

@@ -0,0 +1,14 @@
apiVersion: networking.k8s.io/v1beta1
kind: Ingress
metadata:
name: ereq-ingress
annotations:
kubernetes.io/ingress.allow-http: "false"
kubernetes.io/ingress.global-static-ip-name: ereq-${ENVIRONMENT}
networking.gke.io/managed-certificates: ereq-cert-${ENVIRONMENT}
labels:
app: sample-tracking
spec:
backend:
serviceName: sample-tracking-service
servicePort: 80

View File

@@ -0,0 +1,26 @@
apiVersion: cloud.google.com/v1
kind: BackendConfig
metadata:
name: ereq-backend-config
spec:
timeoutSec: 60
---
apiVersion: v1
kind: Service
metadata:
name: sample-tracking-service
labels:
app: sample-tracking
annotations:
beta.cloud.google.com/backend-config: '{"default": "ereq-backend-config"}'
spec:
type: NodePort
selector:
app: sample-tracking
tier: web
ports:
- name: http
port: 80
protocol: TCP
targetPort: 8989
sessionAffinity: ClientIP

View File

@@ -0,0 +1,97 @@
apiVersion: apps/v1
kind: Deployment
metadata:
name: sample-tracking-app
labels:
app: sample-tracking
spec:
replicas: 1
selector:
matchLabels:
app: sample-tracking
template:
metadata:
labels:
app: sample-tracking
tier: web
spec:
volumes:
- name: google-application-credentials
secret:
secretName: google-application-credentials
- name: firebase-application-credentials
secret:
secretName: firebase-application-credentials
containers:
- name: sample-tracking-app
image: gcr.io/pici-ereq/sample-tracking:${DEPLOY_VERSION}
imagePullPolicy: Always
command: [ "java" ]
args: [ "-Xss4096k", "-Xmx23G", "-jar", "sample-tracking-standalone.jar", "server", "-p", "8989" ]
resources:
requests:
memory: "24Gi"
ports:
- containerPort: 8989
livenessProbe:
httpGet:
path: /api/health
port: 8989
initialDelaySeconds: 30
timeoutSeconds: 1
readinessProbe:
httpGet:
path: /api/health
port: 8989
initialDelaySeconds: 30
timeoutSeconds: 1
volumeMounts:
- name: google-application-credentials
mountPath: /credentials/service-account.json
subPath: service-account.json
- name: firebase-application-credentials
mountPath: /credentials/firebase-credentials.json
subPath: firebase-credentials.json
env:
- name: DEPLOY_ENVIRONMENT
value: default
- name: DATOMIC_ACCESS_KEY
value: myaccesskey
- name: DATOMIC_SECRET
value: mysecret
- name: DATOMIC_DB_NAME
value: sample-tracking
- name: DATOMIC_ENDPOINT
value: datomic-peer:8998
- name: MANIFEST_EMAIL_RECIPIENT
value: ${MANIFEST_EMAIL_RECIPIENT}
- name: MANIFEST_EMAIL_SENDER
value: ereq-admin@parkerici.org
- name: SEND_MANIFEST_EMAILS
value: "true"
- name: GOOGLE_APPLICATION_CREDENTIALS
value: "/credentials/service-account.json"
- name: FIREBASE_JS_APPLICATION_CREDENTIALS
value: "/credentials/firebase-credentials.json"
- name: SEND_VENDOR_EMAILS
value: "${SEND_VENDOR_EMAILS}"
- name: OAUTH_CLIENT_ID
valueFrom:
secretKeyRef:
name: google-oauth
key: id
- name: OAUTH_CLIENT_SECRET
valueFrom:
secretKeyRef:
name: google-oauth
key: secret
- name: SENDGRID_API_KEY
valueFrom:
secretKeyRef:
name: sendgrid-api
key: key
- name: API_KEY
valueFrom:
secretKeyRef:
name: ereq-auth
key: key

View File

@@ -0,0 +1,32 @@
# Job to run deploy tasks before actual deploy.
apiVersion: batch/v1
kind: Job
metadata:
name: deploy-tasks
spec:
template:
metadata:
name: deploy-tasks
labels:
name: deploy-tasks
spec:
restartPolicy: Never
containers:
- name: deploy-tasks-runner
image: gcr.io/pici-ereq/sample-tracking:${DEPLOY_VERSION}
imagePullPolicy: Always
command: [ "/bin/sh", "-c", "java -jar sample-tracking-standalone.jar predeploy" ]
ports:
- containerPort: 8989
env:
- name: DEPLOY_ENVIRONMENT
value: default
- name: DATOMIC_ACCESS_KEY
value: myaccesskey
- name: DATOMIC_SECRET
value: mysecret
- name: DATOMIC_DB_NAME
value: sample-tracking
- name: DATOMIC_ENDPOINT
value: datomic-peer:8998
backoffLimit: 1

View File

@@ -0,0 +1,8 @@
apiVersion: v1
kind: Secret
metadata:
name: google-oauth
type: Opaque
data:
id: ${B64_OAUTH_CLIENT_ID}
secret: ${B64_OAUTH_CLIENT_SECRET}

View File

@@ -0,0 +1,7 @@
apiVersion: v1
kind: Secret
metadata:
name: sendgrid-api
type: Opaque
data:
key: ${B64_SENDGRID_API}

13
dev.cljs.edn Normal file
View File

@@ -0,0 +1,13 @@
^{:watch-dirs ["src/cljs"]
:css-dirs ["resources/public/css"]
:npm {:bundles {"dist/index.bundle.js" "src/js/index.js"}}
:ring-handler org.parkerici.sample-tracking.handler/app
;; Open a static page that doesn't load from DB or else we'll error. Can remove once we add components.
:open-url "http://[[server-hostname]]:[[server-port]]/auth/log-in"
:cljs-devtools true}
{:main org.parkerici.sample-tracking.core
:closure-defines {"re_frame.trace.trace_enabled_QMARK_" true}
:preloads [day8.re-frame-10x.preload]
:npm-deps false
:infer-externs true
:output-to "resources/public/cljs-out/main.js"}

52
dev/user.clj Normal file
View File

@@ -0,0 +1,52 @@
(ns user
(:require [figwheel.main.api :as fig]
[org.parkerici.sample-tracking.api.export :as export]
[org.parkerici.sample-tracking.api.iam :as auth]
[org.parkerici.sample-tracking.configuration :as c]
[org.parkerici.sample-tracking.db.datomic :as db-d]
[org.parkerici.sample-tracking.db.kit-type :as kit-type-db]
[org.parkerici.sample-tracking.db.schema :as schema]
[org.parkerici.sample-tracking.db.site :as site-db]
[org.parkerici.sample-tracking.server :as server])
(:import (java.util UUID)))
(defn string->stream
([s] (string->stream s "UTF-8"))
([s encoding]
(-> s
(.getBytes encoding)
(java.io.ByteArrayInputStream.))))
(comment
:transact-schema
(schema/transact-schema))
(comment
:add-admin
(db-d/wrap-datomic-fn #(doall (map auth/find-or-create-role (c/application-role-values))))
(db-d/wrap-datomic-fn #(auth/add-role-to-user "rschiemann@parkerici.org" (c/application-admin-role))))
(comment
:test-db-methods
(clojure.pprint/pprint (db-d/wrap-datomic-fn #(site-db/list-study-tuples)))
(clojure.pprint/pprint (db-d/wrap-datomic-fn #(site-db/list-all-sites)))
(clojure.pprint/pprint (db-d/wrap-datomic-fn #(kit-type-db/find-active-kit-type-by-name-and-cohort "Blood Sample Collection Kit" (UUID/fromString "5fab14f6-f01c-4f96-bfd1-1b5629fccf17"))))
)
(comment
:test-export
(clojure.pprint/pprint (db-d/wrap-datomic-fn #(export/get-samples-for-export {}))))
(comment
:figwheel
; Starts figwheel and attempts to launch a repl. Use the below command if piggyback fails.
(fig/start "dev")
; Starts figwheel without launching a repl
(fig/start {:mode :serve} "dev")
(fig/stop "dev"))
(comment
:server-start-stop
(server/start 5526)
(server/stop))

62
docs/console.md Normal file
View File

@@ -0,0 +1,62 @@
# eReq Admin Console
Most of the administrative tasks for eReq are performed from the admin console. The admin console can be accessed by
clicking the link that says `Login` in the top right hand corner of the main page. If you are logged in this link will
change from `Login` to `Console`.
## Kit Shipment Form
This link will take you to the main kit shipment form page that users at sites will have access to.
## List Kits
The list kits page allows you to list and filter all kits that have been submitted through the kit shipment form. It
also allows you to export all kits or the filtered kits with all associated metadata to a CSV.
From this page you can filter on complete, incomplete, or archived kits. Complete kits are kit forms that were
successfully submitted by a user. Incomplete kits are kit forms that were shared but have not yet been submitted.
Archived kits are kits that were archived by an administrator (usually due to accidental or duplicate submission).
Each entry in the list of kits has a link for `View Kit`, `Edit Kit`, and `History`. `View Kit` will show you a
read-only version of the form that was submitted for that kit. `Edit Kit` will show you a page where you can edit or
archive the kit. `History` will show you the history of any modifications that were made to that kit.
## Audit History
The audit history page gives you a list of all changes that have been made to any entities in the eReq system. If you
want to focus on one entity (e.g. a submitted kit or a study) you can click on the link under the `Entity UUID` column
for that piece of content.
## List Types
The list types page allows you to list all of the types (e.g. studies, sites, cohorts, kits) that are in eReq and are
used to populate the kit shipment form.
From this page you also have the ability to make minor edits to types. You can use this in the case that a mistake was
made when uploading types (e.g. a misspelled study) or if something was changed (e.g. a site's name changes). **Note:**
any edits made from this page will immediately apply to any kits submitted with the original values.
More complicated edits should be made by marking the entities that need to be edited as inactive and then uploading new
type CSVs on the upload type data page for the edited entities. You can mark an entity as inactive by finding it on the
list types page and then unchecking the `Active` checkbox in the edit types section.
## Upload Type Data
New kit types, sites, studies, and form types (custom form questions) can be uploaded from the upload type data page.
You can read more about the process around creating and uploading new type files on
the [New Form Creation page](forms.md).
## User List
The user list page allows you to give new users access to the admin console. All users must have an `@parkerici.org`
email address.
There are three roles that a user can be assigned: viewer, editor, and administrator. Viewers can view and export
content, but cannot edit anything. Editors can view, export, and edit any content in the system, but cannot upload new
forms through the upload type data page. Administrators can perform all tasks on the admin console.
## Configuration List
The configuration list page lists important configuration settings for the eReq system. This is so that you can check
and confirm that the system is configured as expected in case you encounter any issues or errors.

32
docs/forms.md Normal file
View File

@@ -0,0 +1,32 @@
# New Form Creation
Currently new form creation is a bit of an involved and painful process. It occurs infrequently enough (1 - 2x a year) that we haven't put effort into improving the process, although this may change in the future.
## Example Form Files
The current production form files can be found under the path `test/resources/forms`. You can use these as examples for creating new form files.
## Form Creation and Testing Process
eReq/Sample Tracking was an application requested by and built for Research Ops. They are responsible for creating and testing all new forms. As of the writing of this document Mike Gricoski is the point person on Research Ops for creating and testing forms.
The first step in the process of creating new forms is to have Research Ops create the new form files and send them to you. Once you have the files you should start running a local eReq instance and then upload the files from the `Upload Type Data` page in the console.
Assuming that the new form files upload successfully, it is usually best to hop on a short call with the point person to confirm that everything looks as expected. If it looks as expected, you can navigate to `https://dev-ereq.parkerici.org/` and upload the new files there. If it doesn't look as expected you may have to delete and recreate your local database a few times until the files are right.
Once the files have been uploaded to dev it's time to have a UAT meeting with all of Research Ops. This meeting serves two purposes. First, it makes sure that everyone on Research Ops agrees with the contents of the new forms. Second, it makes sure that the new forms function as expected. If the forms pass UAT, they can be uploaded to `https://ereq.parkerici.org/` If they don't, you may have to delete and recreate the dev database (this is described in the main README and is part of why this can be a pain).
## Production Form Files
Production form files can be found under the path `test/resources/forms`. When new forms are added to production a new folder should be created for them under this path and they should be added to that folder.
In addition you should edit the command `test-setup` in the file at `src/clj/org/parkerici/sample_tracking/cli.clj` to account for the new form files. You will also need to update the appropriate tests under the path `test/clj/org/parkerici/sample_tracking` to account for the new form options.
## Editing Production Forms
Basic editing of production forms is available through the `List Types` page in the console.
If you need more advanced editing than is available on the `List Types` page you will need mark the form as inactive (this can also be done through the `List Types` page) and then upload new form files with the appropriate edits.
## Process Improvements
There are a few points at which this process could be improved.
First, there should be an easier way than recreating the database to delete form types in the local and dev environments. If this functionality is built it is important that form types cannot be deleted in production.
Second, it would be a nicer process if there was a way to promote forms from dev to production and to make any necessary edits through a UI in dev before promoting to production.

30
figwheel-main.edn Normal file
View File

@@ -0,0 +1,30 @@
;; Figwheel-main configuration options see: https://figwheel.org/config-options
;; these will be overriden by the metadata config options in dev.cljs.edn build file
{;; Set the server port https://figwheel.org/config-options#ring-server-options
;; :ring-server-options {:port 9500}
;; Change the target directory from the "target" to "resources"
;; https://figwheel.org/config-options#target-dir
:target-dir "resources"
;; Server Ring Handler (optional) https://figwheel.org/docs/ring-handler.html
;; If you want to embed a ring handler into the figwheel server, this
;; is for simple ring servers
;; :ring-handler hello_world.server/handler
;; To be able to open files in your editor from the heads up display
;; you will need to put a script on your path. This script will have
;; to take a file path and a line number ie.
;; in ~/bin/myfile-opener:
;;
;; #! /bin/sh
;; emacsclient -n +$2:$3 $1
;;
;; :open-file-command "myfile-opener"
;; if you are using emacsclient you can just use
;; :open-file-command "emacsclient"
;; Logging output gets printed to the REPL, if you want to redirect it to a file:
;; :log-file "figwheel-main.log"
}

5264
package-lock.json generated Normal file

File diff suppressed because it is too large Load Diff

43
package.json Normal file
View File

@@ -0,0 +1,43 @@
{
"name": "sample-tracking",
"version": "0.2.0",
"description": "JS Dependencies for sample-tracking application",
"main": "index.js",
"directories": {
"test": "test"
},
"scripts": {
"test": "echo \"Error: no test specified\" && exit 1",
"build": "webpack"
},
"repository": {
"type": "git",
"url": "git+https://github.com/ParkerICI/sample-tracking.git"
},
"keywords": [],
"author": "",
"license": "ISC",
"bugs": {
"url": "https://github.com/ParkerICI/sample-tracking/issues"
},
"homepage": "https://github.com/ParkerICI/sample-tracking#readme",
"dependencies": {
"@blueprintjs/datetime": "^3.19.3",
"css-loader": "^3.6.0",
"dayjs": "^1.9.4",
"firebase": "^8.10.0",
"firebaseui": "^5.0.0",
"react": "^16.12.0",
"react-dom": "^16.12.0",
"react-editext": "^3.17.1",
"react-firebaseui": "^5.0.2",
"react-input-checkbox": "^0.1.6",
"react-select": "^3.1.0",
"reactstrap": "^8.6.0",
"style-loader": "^1.2.1"
},
"devDependencies": {
"webpack": "^4.44.2",
"webpack-cli": "^3.3.12"
}
}

11
prod.cljs.edn Normal file
View File

@@ -0,0 +1,11 @@
^{:watch-dirs ["src/cljs"]
:css-dirs ["resources/public/css"]
:npm {:bundles {"dist/index.bundle.js" "src/js/index.js"}}
:ring-handler org.parkerici.sample-tracking.handler/app
;; Open a static page that doesn't load from DB or else we'll error. Can remove once we add components.
:open-url "http://[[server-hostname]]:[[server-port]]/auth/log-in"
:cljs-devtools false}
{:main org.parkerici.sample-tracking.core
:closure-defines {"re_frame.trace.trace_enabled_QMARK_" true}
:npm-deps false
:output-to "resources/public/cljs-out/main.js"}

121
project.clj Executable file
View File

@@ -0,0 +1,121 @@
(defproject sample-tracking "0.2.1"
:dependencies [[aero "1.1.6"]
[bidi "2.1.6"]
[bk/ring-gzip "0.3.0"]
[buddy/buddy-auth "3.0.1"]
[clj-commons/pushy "0.3.10"]
[clj-htmltopdf "0.2"]
[cheshire "5.10.1"]
[clojure.java-time "0.3.3"]
[cljs-ajax "0.8.4"]
[madvas/cemerick-url "0.1.2"]
[cljsjs/firebase "7.5.0-0"]
[com.datomic/client-pro "0.9.63"
:exclusions [org.eclipse.jetty/jetty-client
org.eclipse.jetty/jetty-http
org.eclipse.jetty/jetty-util]]
[com.google.firebase/firebase-admin "8.1.0"]
[com.google.guava/guava "31.0.1-jre"]
[com.sendgrid/sendgrid-java "2.2.2"]
[com.taoensso/timbre "5.1.2"]
[commons-codec/commons-codec "1.15"]
[compojure "1.6.2"]
[day8.re-frame/http-fx "0.2.4"]
[hiccup "1.0.5"]
[http-kit "2.5.3"]
[listora/again "1.0.0"]
[ns-tracker "0.4.0"]
[org.apache.httpcomponents/httpclient "4.5.13"]
[org.clojure/clojure "1.10.3"]
[org.clojure/clojurescript "1.11.4"]
[org.clojure/data.csv "1.0.0"]
[org.clojure/tools.cli "1.0.206"]
[org.eclipse.jetty/jetty-server "9.4.12.v20180830"]
[org.eclipse.jetty/jetty-client "9.4.12.v20180830"]
[org.eclipse.jetty/jetty-http "9.4.12.v20180830"]
[org.eclipse.jetty/jetty-util "9.4.12.v20180830"]
[org.eclipse.jetty.websocket/websocket-servlet "9.4.12.v20180830"]
[org.eclipse.jetty.websocket/websocket-server "9.4.12.v20180830"]
[org.parkerici/alzabo "0.2.7"]
[org.parkerici/multitool "0.0.18"]
[org.slf4j/slf4j-simple "1.7.32"] ;required to turn off warning
[reagent "0.10.0"]
[re-frame "1.2.0"]
[ring "1.8.0"]
[ring/ring-defaults "0.3.3"]
[ring/ring-jetty-adapter "1.7.1"]
[ring-logger "1.0.1"]
[ring-middleware-format "0.7.4"]
[trptcolin/versioneer "0.2.0"]]
:repositories [["github" {:url "https://maven.pkg.github.com/ParkerICI/mvn-packages"
:sign-releases false
:username :env/github_user
:password :env/github_password}]]
:ring {:handler org.parkerici.sample-tracking.handler/app}
:plugins [[lein-cljsbuild "1.1.7"]
[lein-ring "0.12.6"]]
:min-lein-version "2.5.3"
:source-paths ["src/cljs" "src/cljc" "src/clj"]
:test-paths ["test/clj"]
:target-dir "target"
:resource-paths ["resources" "test/resources"]
:clean-targets ^{:protect false} ["target" "resources/public/cljs-out"]
:aliases {"cli" ["with-profile" "cli" "run"]
"fig" ["trampoline" "run" "-m" "figwheel.main"]
"fig:build" ["trampoline" "run" "-m" "figwheel.main" "-b" "dev" "-r"]
"fig:build-min" ["trampoline" "run" "-m" "figwheel.main" "-O" "advanced" "-bo" "prod" "-s"]
"fig:min" ["run" "-m" "figwheel.main" "-O" "advanced" "-bo" "prod"]
"fig:test" ["run" "-m" "figwheel.main" "-co" "test.cljs.edn" "-m" "hello-figwheel-main.test-runner"]
"package" ["do" "clean" ["fig:min"] ["uberjar"]]}
:profiles
{:cli
{:main org.parkerici.sample-tracking.cli
:source-paths ["src/clj"]}
:test
{:dependencies [[ring/ring-mock "0.4.0"]]
:env {:datomic-endpoint "localhost:9119"
:datomic-db-name "ereq-test"
:send-manifest-emails "false"}}
:dev
{:source-paths ["src/clj" "src/cljc" "src/cljs" "dev"]
:nrepl-middleware ["cider.nrepl/cider-middleware"
"refactor-nrepl.middleware/wrap-refactor"
"cider.piggieback/wrap-cljs-repl"]
:dependencies [[binaryage/devtools "1.0.4"]
[cider/piggieback "0.5.3"]
[com.bhauman/figwheel-main "0.2.15"
:exclusions [org.eclipse.jetty.websocket/websocket-servlet
org.eclipse.jetty.websocket/websocket-server]]
[com.bhauman/rebel-readline-cljs "0.1.4"]
[day8.re-frame/tracing "0.6.2"]
[day8.re-frame/re-frame-10x "1.2.1"]]}
:uberjar
{:dependencies [[com.bhauman/figwheel-main "0.2.15"
:exclusions [org.eclipse.jetty.websocket/websocket-servlet
org.eclipse.jetty.websocket/websocket-server]]
[com.bhauman/rebel-readline-cljs "0.1.4"]]
:omit-source true
:cljs-devtools false
:jar-name "sample-tracking.jar"
:uberjar-name "sample-tracking-standalone.jar"
:clean-targets ^:replace ["target"]
:resource-paths ^:replace ["resources"]
:main ^:skip-aot org.parkerici.sample-tracking.cli
:aot :all}}
:main org.parkerici.sample-tracking.cli
:aot [org.parkerici.sample-tracking.cli])

2
resources/config.edn Normal file
View File

@@ -0,0 +1,2 @@
{:datomic #include "config/datomic.edn"
:application #include "config/application.edn"}

View File

@@ -0,0 +1,65 @@
{:roles {:admin "administrator"
:editor "editor"
:viewer "viewer"
:site-admin "site-admin"
:site-coordinator "site-coordinator"}
:email {:sendgrid-api-key #env SENDGRID_API_KEY
:sender #env MANIFEST_EMAIL_SENDER
:manifest-recipient #env MANIFEST_EMAIL_RECIPIENT
:send-manifest-emails #or [#env SEND_MANIFEST_EMAILS "false"]
:send-vendor-emails #or [#env SEND_VENDOR_EMAILS "false"]}
:temp-path "/tmp"
:api-key #env API_KEY
:firebase-js-credentials-path #env FIREBASE_JS_APPLICATION_CREDENTIALS
:csv-files {:form-type {:headers [:form-type-fields
:form-type-name
:kit-item-no]}
:kit-type {:headers [:study-name
:cohort-name
:kit-item-no
:kit-name
:sample-id-suffix
:sample-name
:kit-timepoints
:ships-with-kit
:sample-reminders
:vendor-email
:collection-date-optional
:air-waybill-optional]}
:site {:headers [:site
:study-names]}
:study {:headers [:study
:participant-id-prefix
:participant-id-regex
:participant-id-validation-message
:kit-id-prefix
:kit-id-regex
:kit-id-validation-message]}}
:sample-export {:columns-to-drop [:kit-uuid :timezone :complete :deleted :sample-type-uuid
:kit-type-uuid]
:column-order [:study-name
:site-name
"Bioinventory Group Name"
:sample-id
:participant-id
:timepoints
"PK Timepoint"
:collection-date
:collection-time
"processing-time"
:sample-type-name
:air-waybill
:kit-type-name
:kit-id]
:columns-to-rename {:study-name "BioInventory Project Name"
:site-name "Site"
:sample-id "Originating ID"
:participant-id "Participant ID"
:timepoints "Visit"
:collection-date "Collection Date"
:collection-time "Collection Time"
"processing-time" "Processing Time"
:sample-type-name "Sample"
:air-waybill "Air Waybill"
:kit-type-name "Kit"
:kit-id "Kit ID"}}}

View File

@@ -0,0 +1,7 @@
{:endpoint #or [#env DATOMIC_ENDPOINT "localhost:8998"]
:access-key #or [#env DATOMIC_ACCESS_KEY "myaccesskey"]
:secret #or [#env DATOMIC_SECRET "mysecret"]
:db-name #or [#env DATOMIC_DB_NAME "ereq-dev"]
:validate-hostnames #profile {:default false
:staging false
:production false}}

6
resources/log4j.properties Executable file
View File

@@ -0,0 +1,6 @@
log4j.rootLogger=WARN, console
log4j.appender.console=org.apache.log4j.ConsoleAppender
log4j.appender.console.layout=org.apache.log4j.PatternLayout
log4j.appender.console.layout.ConversionPattern=%-5p %c: %m%n
log4j.logger.org.eclipse.jetty=WARN

23
resources/logback.xml Executable file
View File

@@ -0,0 +1,23 @@
<!-- Logback configuration. See http://logback.qos.ch/manual/index.html -->
<configuration>
<!-- Console output -->
<appender name="STDOUT" class="ch.qos.logback.core.ConsoleAppender">
<!-- encoder defaults to ch.qos.logback.classic.encoder.PatternLayoutEncoder -->
<encoder>
<pattern>%-5level %logger{36} - %msg%n</pattern>
</encoder>
<!-- Only log level INFO and above -->
<filter class="ch.qos.logback.classic.filter.ThresholdFilter">
<level>INFO</level>
</filter>
</appender>
<!-- Enable FILE and STDOUT appenders for all log messages.
By default, only log at level INFO and above. -->
<root level="WARN">
<appender-ref ref="STDOUT" />
</root>
<!-- For loggers in the ".*" namespace, log at all levels. -->
<logger name="starter" level="INFO" />
</configuration>

345
resources/public/css/app.css Executable file
View File

@@ -0,0 +1,345 @@
@font-face {
font-family: 'Px Grotesk';
src: url('fonts/PxGrotesk-Bold.woff2') format('woff2'),
url('fonts/PxGrotesk-Bold.woff') format('woff');
font-weight: bold;
font-style: normal;
font-display: swap;
}
@font-face {
font-family: 'Px Grotesk';
src: url('fonts/PxGrotesk-BoldIta.woff2') format('woff2'),
url('fonts/PxGrotesk-BoldIta.woff') format('woff');
font-weight: bold;
font-style: italic;
font-display: swap;
}
@font-face {
font-family: 'Px Grotesk';
src: url('fonts/PxGrotesk-Light.woff2') format('woff2'),
url('fonts/PxGrotesk-Light.woff') format('woff');
font-weight: 300;
font-style: normal;
font-display: swap;
}
@font-face {
font-family: 'Px Grotesk';
src: url('fonts/PxGrotesk-Regular.woff2') format('woff2'),
url('fonts/PxGrotesk-Regular.woff') format('woff');
font-weight: normal;
font-style: normal;
font-display: swap;
}
@font-face {
font-family: 'Px Grotesk';
src: url('fonts/PxGrotesk-LightIta.woff2') format('woff2'),
url('fonts/PxGrotesk-LightIta.woff') format('woff');
font-weight: 300;
font-style: italic;
font-display: swap;
}
@font-face {
font-family: 'Px Grotesk';
src: url('fonts/PxGrotesk-RegularIta.woff2') format('woff2'),
url('fonts/PxGrotesk-RegularIta.woff') format('woff');
font-weight: normal;
font-style: italic;
font-display: swap;
}
@font-face {
font-family: 'Px Grotesk Screen';
src: url('fonts/PxGrotesk-Screen.woff2') format('woff2'),
url('fonts/PxGrotesk-Screen.woff') format('woff');
font-weight: normal;
font-style: normal;
font-display: swap;
}
*{font-family:'Px Grotesk';}
body {
background-color: black;
font-size: 1rem!important;
}
.main {
text-align: center;
width: 100%;
}
.header {
margin: 0px auto;
padding: 5px;
background: #343a40!important;
color: white;
font-size: 20px;
}
.header.manifest {
background: white!important;
color: black;
}
.header .content {
text-align: left;
top: 16px;
left: 16px;
}
.header .content .title {
display: inline-block;
}
.header .content .log-in-out-link {
float: right;
}
.header .content .console-link {
float: right;
clear: right;
}
.header .bars {
text-align: left;
left: 16px;
}
.page-body {
padding: 10px;
text-align: center;
max-width: 1000px;
margin: auto;
color: white;
}
.page-body.manifest {
padding: 10px;
text-align: center;
max-width: 1000px;
margin: auto;
color: black;
}
.page-body table {
text-align: left;
margin-bottom: .5em;
}
.list-body {
padding: 10px;
text-align: center;
max-width: 1500px;
margin: auto;
color: white;
}
.list-body table {
text-align: left;
margin-bottom: .5em;
border-collapse: separate;
border-spacing: 10px 5px;
}
div.spacer {
display: inline-block;
width: 5px;
}
/* Apply style colors to a links */
a {
color: #685bc7!important;
}
a:hover {
color: #4a4c9b!important;
}
a:active {
color: #313377!important;
}
a.disabled {
color: #a197e6!important;
pointer-events: none;
cursor: default;
}
/* Apply theme colors to reactstrap elements */
.btn-secondary {
background-color: #685bc7;
border-color: #685bc7;
}
.btn-secondary:hover {
background-color: #4a4c9b;
border-color: #4a4c9b;
}
.btn-secondary:active {
background-color: #313377;
border-color: #313377;
}
.btn-secondary:focus {
background-color: #313377;
border-color: #313377;
}
.btn-secondary:not(:disabled):not(.disabled):active {
background-color: #313377;
border-color: #313377;
}
.btn-secondary.disabled,
.btn-secondary:disabled {
background-color: #a197e6;
border-color: #a197e6;
}
/* Make React Select Menu List items have black font */
.react-select__menu-list {
color: black!important;
}
/* Disable red box outline in Firefox */
input:required {
box-shadow:none!important;
}
input:invalid {
box-shadow:none!important;
}
select[name=amPm] {
box-shadow:none!important;
}
/* Blueprint Styling */
.bp3-input {
font-size: 1rem!important;
}
/* Editext Styling */
button[editext] {
border-radius: .25rem;
padding: 2px;
background-color: #685bc7;
border-color: #685bc7;
color: white;
}
button[editext]:hover {
background-color: #4a4c9b;
border-color: #4a4c9b;
}
button[editext="input"] {
width: auto!important;
}
/* Tooltip styling */
.tooltip-inner {
background: #343a40!important;
}
.bs-tooltip-auto[x-placement^=top] .arrow::before, .bs-tooltip-top .arrow::before {
border-top-color: #343a40!important;
}
/* Datetime picker */
.react-datetime-picker__wrapper {
background: white;
border: 0;
border-radius: .25rem;
font-size: 1.25em;
color: black;
}
.react-datetime-picker__inputGroup__input {
color: black!important;
}
.react-datetime-picker__inputGroup__input:invalid {
background: none!important;
}
/* Checkbox stuff */
.Checkbox_themed {
padding-left: 1.2em;
}
.Checkbox__input_themed {
position: absolute;
width: 1px;
height: 1px;
overflow: hidden;
clip: rect(0 0 0 0);
-webkit-appearance: none;
-moz-appearance: none;
appearance: none;
}
.Checkbox__image_themed {
position: absolute;
margin-left: -1.2em;
width: 1em;
height: 1em;
}
.bootstrap-checkbox {
padding-left: 1.5rem;
margin-bottom: 1em;
}
.bootstrap-checkbox__image {
margin-left: -1.5rem;
border: #adb5bd solid 1px;
border-radius: .25rem;
background-color: #fff;
transition: background-color .15s ease-in-out,border-color .15s ease-in-out,box-shadow .15s ease-in-out;
}
.bootstrap-checkbox__input:checked + .bootstrap-checkbox__image {
border-color: #564bac;
background: #685bc7 url(data:image/svg+xml;base64,PHN2ZyB4bWxucz0naHR0cDovL3d3dy53My5vcmcvMjAwMC9zdmcnIHZpZXdCb3g9JzAgMCA4IDgnPjxwYXRoIGZpbGw9JyNmZmYnIGQ9J002LjU2NC43NWwtMy41OSAzLjYxMi0xLjUzOC0xLjU1TDAgNC4yNiAyLjk3NCA3LjI1IDggMi4xOTN6Jy8+PC9zdmc+) no-repeat 50%/50% 50%;
}
.bootstrap-checkbox__input_indeterminate + .bootstrap-checkbox__image {
border-color: #5247a8;
background: #685bc7 url("data:image/svg+xml,%3csvg xmlns='http://www.w3.org/2000/svg' viewBox='0 0 4 4'%3e%3cpath stroke='%23fff' d='M0 2h4'/%3e%3c/svg%3e") no-repeat 50%/50% 50%;
}
.bootstrap-checkbox__input:disabled + .bootstrap-checkbox__image {
border-color: #888c91;
background-color: #b3b7bb;
}
.bootstrap-checkbox__input:checked:disabled + .bootstrap-checkbox__image,
.bootstrap-checkbox__input_indeterminate:disabled + .bootstrap-checkbox__image {
border-color: #8077c0;
background-color: #a197e6;
}
.bootstrap-checkbox__input:focus + .bootstrap-checkbox__image {
box-shadow: 0 0 0 0.2rem #776cbe;
}
.bootstrap-checkbox__label {
vertical-align: middle;
}
/* Date picker stuff */
.bp3-datepicker .DayPicker-Day.DayPicker-Day--selected {
background-color: #685bc7!important;
}

7
resources/public/css/bootstrap.min.css vendored Executable file

File diff suppressed because one or more lines are too long

File diff suppressed because one or more lines are too long

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

After

Width:  |  Height:  |  Size: 644 B

Binary file not shown.

After

Width:  |  Height:  |  Size: 975 B

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.3 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 4.3 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 4.0 KiB

30
resources/public/index.html Executable file
View File

@@ -0,0 +1,30 @@
<!doctype html>
<html lang="en">
<head>
<meta charset="utf-8">
<meta name="viewport"
content="width=device-width, initial-scale=1, shrink-to-fit=no">
<meta name="description" content="">
<meta name="author" content="">
<title>PICI Sample Tracking</title>
<!-- Bootstrap core CSS -->
<link href="/css/bootstrap.min.css" rel="stylesheet">
<link href="/css/app.css" rel="stylesheet">
<link rel="icon" type="image/png" sizes="32x32" href="/favicon-32x32.png">
<link rel="icon" type="image/png" sizes="16x16" href="/favicon-16x16.png">
</head>
<body>
<main role="main" class="main">
<div id="app"></div>
</main>
<script src="/cljs-out/main.js" type="text/javascript"></script>
<script>
org.parkerici.sample_tracking.core.init();
</script>
</body>
</html>

1
resources/schema.edn Normal file

File diff suppressed because one or more lines are too long

View File

@@ -0,0 +1,411 @@
(ns org.parkerici.sample-tracking.api
"The main interface for all of the API functionality that's available to users.
Tries to loosely format responses according to Google's JSON style guide
https://google.github.io/styleguide/jsoncstyleguide.xml
Acceptable top level keys are :api-version, :data, and :error
:error should be an object that should have the key :message with an error message string
:data should be an object that may have the key :uuid or :items"
(:require [cheshire.core :as json]
[trptcolin.versioneer.core :as version]
[org.parkerici.sample-tracking.utils.ring :as ring-utils]
[org.parkerici.sample-tracking.db.study :as study-db]
[org.parkerici.sample-tracking.db.site :as site-db]
[org.parkerici.sample-tracking.db.cohort :as cohort-db]
[org.parkerici.sample-tracking.db.kit-type :as kit-type-db]
[org.parkerici.sample-tracking.db.timepoint :as timepoint-db]
[org.parkerici.sample-tracking.db.sample-type :as sample-type-db]
[org.parkerici.sample-tracking.db.form-type :as form-type-db]
[org.parkerici.sample-tracking.db.kit :as kit-db]
[org.parkerici.sample-tracking.db.history :as history-db]
[org.parkerici.sample-tracking.db.role :as role-db]
[org.parkerici.sample-tracking.db.user :as user-db]
[org.parkerici.sample-tracking.api.iam :as iam]
[org.parkerici.sample-tracking.api.kit-type :as kit-type]
[org.parkerici.sample-tracking.api.form-type :as form-type]
[org.parkerici.sample-tracking.api.site :as site-api]
[org.parkerici.sample-tracking.api.study :as study-api]
[org.parkerici.sample-tracking.api.kit-shipment :as kit-shipment]
[org.parkerici.sample-tracking.api.propose-kit-edits :as kit-edits]
[org.parkerici.sample-tracking.api.export :as export]
[org.parkerici.sample-tracking.api.firebase :as firebase]
[org.parkerici.sample-tracking.configuration :as c]
[org.parkerici.multitool.core :as multitool]
[java-time :as time]
[clojure.string :as str])
(:import (java.util UUID)))
(defn api-response
[data & {:keys [status] :or {status 200}}]
(ring-utils/json-response data :status status))
(defn catch-error-response
[to-try]
(try
(to-try)
(api-response {})
(catch Exception e (api-response {:error {:message (.getMessage e)} :status 400}))))
(defn parse-request
[request]
(json/parse-string (slurp (:body request)) true))
(defn api-version
[]
(api-response {:api-version (version/get-version "sample-tracking" "sample-tracking")}))
(defn parse-boolean-or-nil
[value]
(if (nil? value) nil (Boolean/valueOf value)))
(defn parse-uuid-or-nil
[value]
(if (nil? value) nil (UUID/fromString value)))
(defn first-uploaded-file-path
[{:keys [multipart-params]}]
(let [upload (first (vals multipart-params))]
(:tempfile upload)))
(defn firebase-js-credentials
[]
(let [credentials-path (c/firebase-js-credentials-path)
credentials (json/parse-string (slurp credentials-path) true)]
(ring-utils/json-response credentials :status 200)))
(defn upload-kit-types
[request]
(let [path (first-uploaded-file-path request)]
(catch-error-response #(kit-type/parse-kit-type-csv-and-save-to-db path))))
(defn upload-form-types
[request]
(let [path (first-uploaded-file-path request)]
(catch-error-response #(form-type/parse-form-type-csv-and-save-to-db path))))
(defn upload-sites
[request]
(let [path (first-uploaded-file-path request)]
(catch-error-response #(site-api/parse-site-csv-and-save-to-db path))))
(defn upload-studies
[request]
(let [path (first-uploaded-file-path request)]
(catch-error-response #(study-api/parse-study-csv-and-save-to-db path))))
(defn list-studies
[active]
(api-response {:data {:items (sort-by :name (study-db/list-studies (parse-boolean-or-nil active)))}}))
(defn list-sites
[study-uuid active]
(api-response {:data {:items (sort-by :name (site-db/list-sites (parse-uuid-or-nil study-uuid) (parse-boolean-or-nil active)))}}))
(defn get-form-type-fields
[kit-type-uuid]
(api-response {:data {:items (form-type-db/get-form-type-fields (parse-uuid-or-nil kit-type-uuid))}}))
(defn list-cohorts
[study-uuid active]
(api-response {:data {:items (sort-by :name (cohort-db/list-cohorts (parse-uuid-or-nil study-uuid) (parse-boolean-or-nil active)))}}))
(defn list-timepoints
[kit-type-uuid]
(api-response {:data {:items (timepoint-db/list-sorted-kit-type-timepoints (parse-uuid-or-nil kit-type-uuid))}}))
(defn list-kit-types
[cohort-uuid active]
; If one timepoint is passed in we get it as a single number. If multiple are passed in we get a seq.
; We need to make the results of either call uniform and parse the numbers into longs.
(api-response {:data {:items (sort-by :name (kit-type-db/list-kit-types (parse-uuid-or-nil cohort-uuid) (parse-boolean-or-nil active)))}}))
(defn list-sample-types
[kit-type-uuid]
(api-response {:data {:items (sort-by :id-suffix (sample-type-db/list-sample-types (parse-uuid-or-nil kit-type-uuid)))}}))
(defn datomic-transaction-response
[tx-results]
(let [error-message (:cognitect.anomalies/message tx-results)]
(if (nil? error-message)
(api-response {})
(api-response {:error {:message error-message}} :status 400))))
(defn update-with-history
[request entity-type fetch-fn update-fn]
(let [input (parse-request request)
entity-uuid (parse-uuid-or-nil (:uuid input))
current-entity (fetch-fn entity-uuid)
results (update-fn input)
updated-entity (fetch-fn entity-uuid)]
(history-db/create-history (get-in request [:session :identity]) entity-type entity-uuid (str current-entity) (str updated-entity))
(datomic-transaction-response results)))
(defn update-study
[request]
(update-with-history request :study study-db/find-study-by-uuid
(fn [i] (study-db/update-study (parse-uuid-or-nil (:uuid i)) (:name i)))))
(defn update-site
[request]
(update-with-history request :site site-db/find-site-by-uuid
(fn [i] (site-db/update-site (parse-uuid-or-nil (:uuid i)) (:name i)))))
(defn update-cohort
[request]
(update-with-history request :cohort cohort-db/find-cohort-by-uuid
(fn [i] (cohort-db/update-cohort (parse-uuid-or-nil (:uuid i)) (:name i)))))
(defn update-timepoint
[request]
(update-with-history request :timepoint timepoint-db/find-timepoint-by-uuid
(fn [i] (timepoint-db/update-timepoint (parse-uuid-or-nil (:uuid i)) (:name i)))))
(defn update-kit-type
[request]
(update-with-history request :kit-type kit-type-db/find-kit-type-by-uuid
(fn [i]
(kit-type-db/update-kit-type
(parse-uuid-or-nil (:uuid i))
(:name i)
(Long/parseLong (str (:item-number i)))
(:collection-date-required i)
(:air-waybill-required i)))))
(defn update-sample-type
[request]
(update-with-history request :sample-type sample-type-db/find-sample-type-by-uuid (fn [i] (sample-type-db/update-sample-type (parse-uuid-or-nil (:uuid i)) (:name i) (:id-suffix i) (:ships-with-kit i) (:reminder i)))))
(defn set-active
[request]
(let [{:keys [study site cohort kit-type active]} (parse-request request)
parsed-status (Boolean/valueOf active)
study-uuid (parse-uuid-or-nil study)
site-uuid (parse-uuid-or-nil site)
cohort-uuid (parse-uuid-or-nil cohort)
kit-type-uuid (parse-uuid-or-nil kit-type)]
(cond
(and (some? study-uuid) (some? site-uuid)) (datomic-transaction-response (site-db/update-site-active-status study-uuid site-uuid parsed-status))
(and (some? study-uuid) (some? cohort-uuid)) (datomic-transaction-response (cohort-db/update-cohort-active-status study-uuid cohort-uuid parsed-status))
(and (some? cohort-uuid) (some? kit-type-uuid)) (datomic-transaction-response (kit-type-db/update-kit-type-active-status cohort-uuid kit-type-uuid parsed-status))
(some? study-uuid) (datomic-transaction-response (study-db/update-study-active-status study-uuid parsed-status))
:else (api-response {:error {:message "Parameters not accepted"}}))))
(defn submit-kit-shipment
[request]
(let [input (parse-request request)
uuid (parse-uuid-or-nil (:uuid input))
complete-kit (kit-db/get-kit {:uuid uuid :complete true})]
(if (or (nil? uuid) (not complete-kit))
(api-response {:data {:uuid (kit-shipment/submit-kit-shipment uuid input)}})
(api-response {:error {:message "Kit has already been submitted."}} :status 400))))
(defn create-incomplete-kit-shipment
[request]
(let [input (merge (parse-request request) {:complete false})
uuid (kit-shipment/create-kit-shipment input)]
(api-response {:data {:uuid uuid}})))
(defn list-kit-shipments
[request]
(let [user (get-in request [:session :identity])
roles (get-in request [:session :roles])
{:keys [uuid complete archived]} (:params request)
parsed-kit-uuid (parse-uuid-or-nil uuid)
parsed-complete (parse-boolean-or-nil complete)
parsed-archived (parse-boolean-or-nil archived)
shipment-options (cond-> {}
(contains? roles (c/site-coordinator-role)) (assoc :completing-email user)
(contains? roles (c/site-admin-role)) (assoc :completing-email-domain (second (str/split user #"@")))
(some? parsed-kit-uuid) (assoc :uuid parsed-kit-uuid)
(some? parsed-complete) (assoc :complete parsed-complete)
(some? parsed-archived) (assoc :archived parsed-archived))
kits (kit-shipment/list-kit-shipment shipment-options)]
(api-response {:data {:items (reverse (sort-by :uuid kits))}})))
(defn kit-shipment-submitted
[kit-id]
(let [submitted-kit (kit-db/get-kit {:kit-id kit-id :complete true :archived false})]
(api-response {:data {:items [{:kit-id kit-id :exists (some? submitted-kit)}]}})))
(defn get-incomplete-kit-shipment
[raw-kit-uuid]
(let [kit-uuid (parse-uuid-or-nil raw-kit-uuid)
complete-kit (kit-db/get-kit {:uuid kit-uuid :complete true})
shipment-options (cond-> {}
(some? kit-uuid) (assoc :uuid kit-uuid))]
(if (not complete-kit)
(api-response {:data {:items (kit-shipment/list-kit-shipment shipment-options)}})
(api-response {:error {:message "Kit not found."}} :status 400))))
(defn update-kit-shipment
[request]
(let [input (parse-request request)
kit-uuid (parse-uuid-or-nil (:uuid input))
user (get-in request [:session :identity])]
(if (kit-edits/kit-has-pending-edits kit-uuid)
(api-response {:error {:message "Kit has pending edits."}} :status 400)
(api-response {:data {:uuid (kit-shipment/update-kit-shipment-with-history kit-uuid user input)}}))))
(defn propose-kit-shipment-edit
[request]
(let [user-email (get-in request [:session :identity])
input (parse-request request)
uuid (kit-edits/propose-kit-edits input user-email)]
(api-response {:data {:uuid uuid}})))
(defn get-proposed-kit-shipment-edit-for-view
[request]
(let [uuid (get-in request [:params :uuid])
parsed-uuid (parse-uuid-or-nil uuid)]
(api-response {:data {:items [(kit-edits/get-proposed-kit-edit-for-display parsed-uuid)]}})))
(defn list-proposed-kit-shipment-edits
[status]
(api-response {:data {:items (reverse (sort-by :uuid (kit-edits/list-proposed-edits {:status status})))}}))
(defn get-kit-shipment-or-proposed-edit
[request]
(let [user (get-in request [:session :identity])
roles (get-in request [:session :roles])
uuid (parse-uuid-or-nil (get-in request [:params :uuid]))
shipment-options (cond-> {:uuid uuid}
(contains? roles (c/site-coordinator-role)) (assoc :completing-email user)
(contains? roles (c/site-admin-role)) (assoc :completing-email-domain (second (str/split user #"@"))))]
(api-response {:data {:items [(kit-edits/get-kit-or-proposed-edit shipment-options)]}})))
(defn update-proposed-kit-shipment-edit-status
[request status-update-fn]
(let [user-email (get-in request [:session :identity])
uuid (get-in request [:params :uuid])
parsed-uuid (parse-uuid-or-nil uuid)
proposed-edit (kit-edits/get-proposed-kit-edit parsed-uuid)
proposed-edit-status (:status proposed-edit)]
(cond
(nil? status-update-fn) (api-response {:error {:message "Status not found"} :status 400})
(not= proposed-edit-status "pending") (api-response {:error {:message "Edit not pending."}} :status 400)
:else (api-response (status-update-fn parsed-uuid user-email)))))
(defn set-kit-shipment-edit-status
[request]
(let [status (get-in request [:params :status])
update-fn (case status
"approved" kit-edits/approve-proposed-kit-edit
"denied" kit-edits/deny-proposed-kit-edit
nil)]
(update-proposed-kit-shipment-edit-status request update-fn)))
(defn update-incomplete-kit-shipment
[request]
(let [input (parse-request request)
kit-uuid (parse-uuid-or-nil (:uuid input))
complete-kit (kit-db/get-kit {:uuid kit-uuid :complete true})]
(if (not complete-kit)
(api-response {:data {:uuid (kit-shipment/update-kit-shipment kit-uuid input)}})
(api-response {:error {:message "Kit not found."}} :status 400))))
(defn set-kit-shipment-archived
[request raw-uuid raw-archived]
(let [user (get-in request [:session :identity])
kit-uuid (parse-uuid-or-nil raw-uuid)
archived (parse-boolean-or-nil raw-archived)]
(api-response {:data {:uuid (kit-shipment/set-kit-shipment-archived kit-uuid user archived)}})))
(defn export-samples->csv
[raw-uuid raw-complete raw-archived raw-uncollected]
(let [export-options (multitool/clean-map
{:uuid (parse-uuid-or-nil raw-uuid)
:complete (parse-boolean-or-nil raw-complete)
:archived (parse-boolean-or-nil raw-archived)
:include-uncollected (parse-boolean-or-nil raw-uncollected)})
streaming-samples (export/export-samples-to-streaming-csv export-options)
filename (str "ereq_" (time/format (time/formatter "YYYY_MM_dd_HH_mm") (time/local-date-time)) ".csv")]
(ring-utils/csv-response streaming-samples filename)))
(defn user-info
[request]
(let [{:keys [identity is-a-user email-verified roles auth-error]} (:session request)
items (cond
(some? identity) [{:email identity
:roles roles
:is-a-user is-a-user
:email-verified email-verified}]
(true? auth-error) [{:auth-error true}]
:else [{}])]
(api-response {:data {:items items}})))
(defn list-history
[entity-uuid]
(api-response {:data {:items (sort-by :time (history-db/list-history (parse-uuid-or-nil entity-uuid)))}}))
(defn list-roles
[]
(api-response {:data {:items (sort-by :name (role-db/list-roles))}}))
(defn list-users
[]
(api-response {:data {:items (sort-by :email (user-db/list-users {}))}}))
(defn create-user
[request]
(let [email (:email (parse-request request))
user (iam/get-user email)]
(cond
(true? (:deactivated user)) (api-response {:data {:uuid (iam/reactivate-user email)}})
(some? user) (api-response {:error {:message "User already exists."}} :status 400)
:else (api-response {:data {:uuid (user-db/create-user email)}}))))
(defn deactivate-user
[request]
(let [requesting-email (get-in request [:session :identity])
deactivating-email (:email (parse-request request))]
(if (= requesting-email deactivating-email)
(api-response {:error {:message "Cannot deactivate yourself."}} :status 400)
(catch-error-response #(iam/deactivate-user deactivating-email)))))
(defn add-role-to-user
[request]
(let [input (parse-request request)]
(catch-error-response #(iam/add-role-to-user (:email input) (:role-name input)))))
(defn remove-role-from-user
[request]
(let [input (parse-request request)
user-email (get-in request [:session :identity])
modifying-email (:email input)
role-name (:role-name input)]
(if (and (= user-email modifying-email) (= role-name (c/application-admin-role)))
(api-response {:error {:message "Cannot remove admin from yourself."}} :status 400)
(catch-error-response #(iam/remove-role-from-user (:email input) (:role-name input))))))
(defn list-configuration
[]
(api-response {:data {:items [{:datomic-endpoint (c/datomic-endpoint)
:datomic-db-name (c/datomic-db-name)
:sendgrid-api-key (c/sendgrid-api-key)
:email-sender (c/email-sender)
:email-manifest-recipient (c/email-manifest-recipient)
:send-manifest-emails (c/send-manifest-emails)
:send-vendor-emails (c/send-vendor-emails)}]}}))
(defn log-in
[request]
(if-let [firebase-jwt (:firebase-jwt (parse-request request))]
(let [authed-session (firebase/add-firebase-auth-to-session (:session request) firebase-jwt)]
(-> (api-response {:success true})
(assoc :session authed-session)))
(api-response {:error {:message "Request missing Firebase JWT"}} :status 400)))
;Method to log in in case of no internet for firebase.
;(defn test-log-in
; []
; (let [session (-> {}
; (assoc :identity "rschiemann@parkerici.org")
; (assoc :roles #{"site-admin"})
; (assoc :is-a-user true)
; (assoc :email-verified true))]
; (-> (api-response {:success true})
; (assoc :session session))))
(defn log-out
[request]
(-> (api-response {:success true})
(assoc :session (firebase/remove-firebase-auth-from-session (:session request)))))

View File

@@ -0,0 +1,123 @@
(ns org.parkerici.sample-tracking.api.email
(:require [org.parkerici.sample-tracking.configuration :as c]
[org.parkerici.sample-tracking.db.study :as study-db]
[org.parkerici.sample-tracking.db.site :as site-db]
[org.parkerici.sample-tracking.db.cohort :as cohort-db]
[org.parkerici.sample-tracking.db.kit-type :as kit-type-db]
[org.parkerici.sample-tracking.db.timepoint :as timepoint-db]
[org.parkerici.sample-tracking.db.sample-type :as sample-type-db]
[org.parkerici.sample-tracking.db.form-type :as form-type-db]
[org.parkerici.sample-tracking.db.kit :as kit-db]
[org.parkerici.sample-tracking.api.export :as export]
[org.parkerici.sample-tracking.utils.path :as path]
[org.parkerici.sample-tracking.pages.manifest :as manifest-page]
[again.core :as again]
[clojure.java.io :as io]
[hiccup.core :as hiccup]
[clj-htmltopdf.core :as htmltopdf]
[org.parkerici.sample-tracking.utils.date-time :as dt])
(:import [com.sendgrid SendGrid SendGrid$Email]
(java.util UUID)))
(def csv-attachment-name "samples.csv")
(def pdf-attachment-name "manifest.pdf")
(defn send-message
[to subject content csv-file]
(let [pdf-path (path/join (c/temp-path) pdf-attachment-name)
_ (htmltopdf/->pdf content pdf-path)
pdf-file (io/file pdf-path)
sg (new SendGrid (c/sendgrid-api-key))
email (doto (new SendGrid$Email)
(.addTo to)
(.setFrom (c/email-sender))
(.setSubject subject)
(.setHtml content))
email-with-csv (if csv-file
(.addAttachment email csv-attachment-name csv-file)
email)
email-with-pdf (if pdf-file
(.addAttachment email-with-csv pdf-attachment-name pdf-file)
email-with-csv)]
(try
(again/with-retries
[1000 10000]
(.send sg email-with-pdf))
(catch Exception ex
(.printStackTrace ex)
(println (.getMessage ex))))
(io/delete-file pdf-path)))
(defn manifest-email-body
[kit-map config]
(let [{:keys [kit-id site study cohort participant-id air-waybill collection-timestamp timezone
completing-first-name completing-last-name completing-email comments timepoints kit-type samples
form-type-field-values]} kit-map
kit-type-uuid (UUID/fromString kit-type)
site-name (:name (site-db/find-site-by-uuid (UUID/fromString site)))
study-name (:name (study-db/find-study-by-uuid (UUID/fromString study)))
cohort-name (:name (cohort-db/find-cohort-by-uuid (UUID/fromString cohort)))
timepoint-names (map #(:name (timepoint-db/find-timepoint-by-uuid (UUID/fromString %))) timepoints)
kit-type-name (kit-type-db/get-kit-type-name kit-type-uuid)
selected-sample-types (sort-by :id-suffix (sample-type-db/list-sample-types kit-type-uuid))
selected-form-type-fields (form-type-db/get-form-type-fields kit-type-uuid)
date-display-fn (fn [date] (when date (dt/generate-date-string date timezone)))
time-display-fn (fn [time] (when time (dt/generate-time-string time timezone)))
completing-user-manifest (:completing-user-manifest config)
content (manifest-page/content {:site-name site-name
:study-name study-name
:cohort-name cohort-name
:timepoint-names timepoint-names
:kit-name kit-type-name
:kit-id kit-id
:participant-id participant-id
:collection-date collection-timestamp
:collection-time collection-timestamp
:selected-form-type-fields selected-form-type-fields
:form-type-field-values form-type-field-values
:selected-sample-types selected-sample-types
:sample-values samples
:air-waybill air-waybill
:completing-first-name completing-first-name
:completing-last-name completing-last-name
:completing-email completing-email
:comments comments
:date-display-fn date-display-fn
:time-display-fn time-display-fn
:add-empty-field-lines completing-user-manifest
:add-signature-fields completing-user-manifest})]
(hiccup/html [:div.page-body
[:h1 "Kit Shipment Manifest"]
[:div.kit-manifest
content]])))
(defn send-manifest-email
[kit-map kit-uuid]
(let [completing-user-body (manifest-email-body kit-map {:completing-user-manifest true})
non-completing-user-body (manifest-email-body kit-map {:completing-user-manifest false})
subject "Sample Tracking Kit Manifest"
completing-email (:completing-email kit-map)
vendor-email (kit-db/get-kit-vendor-email kit-uuid)
csv-path (path/join (c/temp-path) csv-attachment-name)
_ (export/export-samples-to-csv {:uuid kit-uuid :shipped true} csv-path)
csv-file (io/file csv-path)]
(when (c/send-manifest-emails)
(send-message (c/email-manifest-recipient) subject non-completing-user-body csv-file)
(send-message completing-email subject completing-user-body csv-file)
(when (and (c/send-vendor-emails) (some? vendor-email))
(send-message vendor-email subject non-completing-user-body csv-file)))
(io/delete-file csv-path)))
(defn proposed-edit-body
[user-email]
(hiccup/html
[:div.page-body
[:p (str user-email " has proposed a kit edit. Please login to the application to approve or deny it.")]]))
(defn send-proposed-edit-email
[update-map user-email]
(let [recipient (c/email-manifest-recipient)
subject (str "Edit Proposed for Kit " (:kit-id update-map))
body (proposed-edit-body user-email)]
(when (c/send-manifest-emails)
(send-message recipient subject body nil))))

View File

@@ -0,0 +1,201 @@
(ns org.parkerici.sample-tracking.api.export
(:require [clojure.string :as string]
[org.parkerici.sample-tracking.configuration :as c]
[org.parkerici.sample-tracking.db.form-value :as form-value-db]
[org.parkerici.sample-tracking.db.sample :as sample-db]
[org.parkerici.sample-tracking.db.sample-attribute :as sample-attribute-db]
[org.parkerici.sample-tracking.db.sample-type :as sample-type-db]
[org.parkerici.sample-tracking.db.timepoint :as timepoint-db]
[org.parkerici.sample-tracking.utils.csv :as csv]
[org.parkerici.sample-tracking.utils.date-time :as dt]))
(defn build-timepoint-map
[config-map]
(reduce (fn [m value]
(let [kit-uuid (:kit-uuid value)
cur-values (or (get m kit-uuid) [])
updated-values (conj cur-values (:timepoint-name value))]
(assoc m kit-uuid updated-values))) {} (timepoint-db/list-kit-timepoints config-map)))
(defn add-timepoints-to-samples
"Add attributes and their values to a map of samples
Samples should be a list of maps that all have the key :sample-id
Timepoints should be a list of maps that have they keys :sample-id and :timepoint-name
Returns the samples list with the timepoint-names that map to each sample added as a comma separated list
under the key :timepoints."
[timepoint-map samples]
(map (fn [sample]
(let [kit-uuid (:kit-uuid sample)
timepoint-names (string/join ", " (sort (get timepoint-map kit-uuid)))]
(assoc sample :timepoints timepoint-names))) samples))
(defn build-sample-join-map
[values-to-join join-key]
(reduce (fn [value-map value]
(let [join-key-value (get value join-key)
existing-values (or (get value-map join-key-value) [])
updated-values (conj existing-values value)]
(assoc value-map join-key-value updated-values))) {} values-to-join))
(defn join-to-sample-map
"Add the values elements in values to join to the sample maps in samples.
Samples should be a list of maps that all have the key :sample-id
values-to-join should be a list of maps that have they keys join-key, id-key.
Calls the join-fn on sample and a list of the values in values-to-join with the same join-key.
Expects the join-fn to returned the sample map joined with corresponding values from values-to-join.
Returns the list of samples after joining with the values-to-join and applying join-fn."
[join-map join-key join-fn samples]
(map (fn [sample]
(let [join-key-value (get sample join-key)
joining-values (get join-map join-key-value)]
(join-fn sample joining-values))) samples))
(defn parse-and-split-collection-timestamp
[samples]
(map (fn [sample]
(let [timezone (:timezone sample)
collection-timestamp (:collection-timestamp sample)]
(-> sample
(assoc :collection-date (when collection-timestamp (dt/generate-date-string collection-timestamp timezone)))
(assoc :collection-time (when collection-timestamp (dt/generate-time-string collection-timestamp timezone)))
(dissoc :collection-timestamp))))
samples))
(defn attributes-and-values-join-fn
[sample values]
(reduce (fn [sample value]
(assoc sample (:attribute value) (:value value))) sample values))
(defn kit-form-values-join-fn
[sample values]
(if (:collected sample)
(reduce (fn [sample value]
(if (= (:field-type value) "time")
(assoc sample
(:field-id value)
(dt/generate-time-string (:value value) (:timezone sample)))
(assoc sample
(:field-id value)
(:value value))))
sample values)
sample))
(defn kit-type->sample-type-map-reduce-fn
"A reduce function that expects a sample-type map as input.
Builds an output map of the form
{kit-type-uuid: {sample-type-uuid: {:name 'sample-type-name' :id-suffix 'sample-type-id-suffix'}}"
[m sample-type]
(let [kit-type-uuid (:kit-type-uuid sample-type)
cur-values (or (get m kit-type-uuid) {})
sample-type-map {:name (:name sample-type)
:suffix (:id-suffix sample-type)}
updated-values (assoc cur-values
(:uuid sample-type)
sample-type-map)]
(assoc m kit-type-uuid updated-values)))
(defn kit->sample-map-reduce-fn
"A reduce function that expects a sample map as an input.
Builds an output map of the form {kit-uuid: {sample-type-uuid: sample}}"
[m sample]
(let [kit-uuid (:kit-uuid sample)
cur-values (or (get m kit-uuid) {})
updated-values (assoc cur-values
(:sample-type-uuid sample) sample)]
(assoc m kit-uuid updated-values)))
(defn kit-sample-type-uuids
"For a given kit, finds the kit-type for that kit and then finds the sample-types for that kit-type.
Returns a list of the sample-type-uuids for a given kit."
[kit-uuid kit-type-sample-type-map kit-sample-map]
(let [samples-map (get kit-sample-map kit-uuid)
first-sample (first (vals samples-map))
kit-type-uuid (get first-sample :kit-type-uuid)
kit-sample-types (get kit-type-sample-type-map kit-type-uuid)]
(keys kit-sample-types)))
(defn build-uncollected-sample
"Given a kit and a sample-type for that kit, builds an uncollected sample by taking the first collected sample for
that kit and then clearing any sample specific information and adding the correct sample-type-name and sample-id."
[kit-uuid sample-type-uuid kit-type-sample-type-map kit-sample-map]
(let [samples-map (get kit-sample-map kit-uuid)
first-sample (first (vals samples-map))
kit-type-uuid (get first-sample :kit-type-uuid)
cur-sample-type (get-in kit-type-sample-type-map [kit-type-uuid sample-type-uuid])]
(-> first-sample
(dissoc :collection-timestamp)
(assoc :sample-type-name (:name cur-sample-type))
(assoc :sample-id (str (:kit-id first-sample) (:suffix cur-sample-type)))
(assoc :collected false)
(assoc :shipped false)
(assoc :air-waybill ""))))
(defn add-uncollected-samples
"Expects a sample map and a boolean flag to add uncollected. Normally a sample map only contains samples that have
been collected. If add-uncollected is true, iterates over the sample-types for the kits represented in samples
and then generates samples for the uncollected samples. If add-uncollected is false just returns the passed in
samples."
[kit-type-sample-type-map add-uncollected]
(fn [xf]
(fn
([] (xf))
([processed-samples] (xf processed-samples))
([processed-samples new-samples]
(if add-uncollected
(let [kit-sample-map (reduce kit->sample-map-reduce-fn {} new-samples)
full-kit-sample-map (for [cur-kit-uuid (keys kit-sample-map)
cur-sample-type-uuid (kit-sample-type-uuids cur-kit-uuid kit-type-sample-type-map
kit-sample-map)]
(if-let [cur-kit-sample (get-in kit-sample-map [cur-kit-uuid cur-sample-type-uuid])]
cur-kit-sample
(build-uncollected-sample cur-kit-uuid cur-sample-type-uuid kit-type-sample-type-map
kit-sample-map)))]
(xf processed-samples full-kit-sample-map))
(xf processed-samples new-samples))))))
(defn remove-unused-columns
[samples]
(map #(apply dissoc % (c/sample-export-columns-to-drop)) samples))
; TODO - Could possibly use some refactoring here.
; Could be cleaner to get all kit types and sample types, and then iterate through all existing kits and samples.
; If a sample is present for a kit, get the sample type and fill in the collected sample's specific information.
; Otherwise we would emit a "base" uncollected sample.
;
; Readability isn't the best to decrease memory usage.
(defn get-samples-for-export
"Gets all of the samples for export as a list of maps ready to pass to csv/write-csv-file.
Config map can have a :uuid key to export only a specific kit, or an :include-uncollected key
if we want to include any uncollected samples in the export."
([config-map]
(let [samples (sample-db/list-samples-for-export config-map)
kit-type-sample-type-map (reduce kit-type->sample-type-map-reduce-fn {} (sample-type-db/list-sample-types nil))
timepoint-map (build-timepoint-map config-map)
attributes-and-values-join-map (build-sample-join-map
(sample-attribute-db/list-sample-attributes-and-values-for-export config-map)
:sample-id)
kit-form-join-map (build-sample-join-map
(form-value-db/list-form-values config-map)
:kit-uuid)
sample-transducer (comp
(map (partial join-to-sample-map kit-form-join-map :kit-uuid kit-form-values-join-fn))
(map (partial join-to-sample-map attributes-and-values-join-map :sample-id attributes-and-values-join-fn))
(map (partial add-timepoints-to-samples timepoint-map))
(map parse-and-split-collection-timestamp)
(add-uncollected-samples kit-type-sample-type-map (:include-uncollected config-map)))
]
(->> (transduce sample-transducer concat (vals (group-by :kit-uuid samples)))
(sort-by (juxt :kit-uuid :sample-id))
(remove-unused-columns)))))
(defn export-options
[]
{:column-order (c/sample-export-column-order) :columns-to-rename (c/sample-export-columns-to-rename)})
(defn export-samples-to-csv
[config-map csv-path]
(csv/write-csv-file csv-path (get-samples-for-export config-map) (export-options)))
(defn export-samples-to-streaming-csv
[config-map]
(csv/csv-output-stream-fn (get-samples-for-export config-map) (export-options)))

View File

@@ -0,0 +1,53 @@
(ns org.parkerici.sample-tracking.api.firebase
(:require [clojure.string :as str]
[org.parkerici.sample-tracking.api.iam :as iam]
[taoensso.timbre :as log])
(:import [com.google.firebase FirebaseApp FirebaseOptions]
[com.google.auth.oauth2 GoogleCredentials]
[com.google.firebase.auth FirebaseAuth]))
(defn get-authorization-jwt
[request]
(when-let [authorization-header (get-in request [:headers "authorization"])]
(let [split-header (str/split authorization-header #" " 2)]
(when (= (first split-header) "Bearer")
(second split-header)))))
(defn check-initialize-firebase
[]
(when (empty? (FirebaseApp/getApps))
(let [firebase-options (-> (FirebaseOptions/builder)
(.setCredentials (GoogleCredentials/getApplicationDefault))
(.build))]
(FirebaseApp/initializeApp firebase-options))))
(defn verify-token
"Verifies that the passed in JWT is valid.
If it's valid, returns a decoded FirebaseToken"
[token]
(check-initialize-firebase)
(-> (FirebaseAuth/getInstance)
(.verifyIdToken token true)))
(defn process-firebase-jwt-request
[session request-jwt]
(let [decoded-jwt (verify-token request-jwt)
firebase-email (.getEmail decoded-jwt)
user (iam/get-user firebase-email)
is-a-user (and (some? user) (not (:deactivated user)))
email-verified (.isEmailVerified decoded-jwt)
roles (set (iam/get-users-roles firebase-email))]
(merge session
{:identity firebase-email :roles roles :is-a-user is-a-user :email-verified email-verified})))
(defn add-firebase-auth-to-session
[session firebase-jwt]
(try
(process-firebase-jwt-request session firebase-jwt)
(catch Exception e
(log/error e)
(assoc session :auth-error true))))
(defn remove-firebase-auth-from-session
[session]
(dissoc session :identity :roles :is-a-user :email-verified))

View File

@@ -0,0 +1,51 @@
(ns org.parkerici.sample-tracking.api.form-type
"Form types are custom, configurable forms that are associated with
kit types to collect information for that kit type outside of the
default fields collected.
This file is focused on taking in a csv with form type definitions
along with the kit item numbers of the kits they are used for,
parsing that csv, and then creating the appropriate values in the database."
(:require [clojure.edn :as edn]
[org.parkerici.sample-tracking.utils.csv :as csv]
[org.parkerici.sample-tracking.configuration :as config]
[org.parkerici.sample-tracking.db.kit-type :as kit-type-db]
[org.parkerici.sample-tracking.db.form-type :as form-type-db]))
; Used with filter to remove rows in the input CSV that don't have the required values.
(defn row-has-required-values
[row]
(not (or (empty? (:form-type-name row))
(empty? (:kit-item-no row)))))
; Does not create a form-type if form-type-fields is missing from the row.
(defn create-form-type
[row]
(when-not (empty? (:form-type-fields row))
(let [raw-form-type-fields (edn/read-string (:form-type-fields row))
form-type-fields (map #(vector :form-type-field/uuid (form-type-db/create-form-type-field %)) raw-form-type-fields)
form-type (form-type-db/create-form-type (:form-type-name row) form-type-fields)]
form-type)))
; Tries to find form-type by name. Returns it if found, otherwise creates it with row information.
(defn find-or-create-form-type
[row]
(let [form-type-uuid (form-type-db/find-form-type (:form-type-name row))]
(if form-type-uuid
form-type-uuid
(create-form-type row))))
(defn create-row-in-db
[row]
(let [form-type (find-or-create-form-type row)
kit-item-numbers (csv/split-csv-string (:kit-item-no row))]
(doseq [kit-item-number kit-item-numbers]
(when (and form-type
(not (kit-type-db/kit-type-has-form-type kit-item-number)))
(kit-type-db/add-form-type-to-kit-type form-type (Integer/parseInt kit-item-number))))))
(defn parse-form-type-csv-and-save-to-db
[fpath]
(let [csv-headers (config/csv-file-headers :form-type)
csv-data (csv/read-csv-into-map fpath csv-headers row-has-required-values)]
(doseq [row csv-data] (create-row-in-db row))))

View File

@@ -0,0 +1,59 @@
(ns org.parkerici.sample-tracking.api.iam
(:require [org.parkerici.sample-tracking.db.user :as user-db]
[org.parkerici.sample-tracking.db.role :as role-db]))
(defn find-or-create-user
[email]
(let [user-uuid (user-db/find-user-uuid email)]
(if user-uuid
user-uuid
(user-db/create-user email))))
(defn find-or-create-role
[name]
(let [role-uuid (role-db/find-role-uuid name)]
(if role-uuid
role-uuid
(role-db/create-role name))))
(defn add-role-to-user
[email role-name]
(let [user-uuid (find-or-create-user email)
role-uuid (find-or-create-role role-name)]
(if (user-db/user-has-role user-uuid role-uuid)
(throw (Exception. "User already has role."))
(user-db/add-role-to-user user-uuid role-uuid))))
(defn remove-role-from-user
[email role-name]
(let [user-uuid (find-or-create-user email)
role-uuid (find-or-create-role role-name)]
(if (user-db/user-has-role user-uuid role-uuid)
(user-db/remove-role-from-user user-uuid role-uuid)
(throw (Exception. "User does not have role to remove.")))))
(defn get-users-roles
[email]
(doall (map first (user-db/get-users-roles email))))
(defn get-users-with-role
[role-name]
(doall (map first (user-db/get-users-with-role role-name))))
(defn get-user
[email]
(first (user-db/list-users {:email email})))
(defn reactivate-user
[email]
(user-db/set-user-deactivated-status email false)
(find-or-create-user email))
(defn deactivate-user
[email]
(let [user-uuid (user-db/find-user-uuid email)]
(user-db/set-user-deactivated-status email true)
(doseq [role (role-db/list-roles)]
(when (user-db/user-has-role user-uuid (:uuid role))
(user-db/remove-role-from-user user-uuid (:uuid role))))
user-uuid))

View File

@@ -0,0 +1,216 @@
(ns org.parkerici.sample-tracking.api.kit-shipment
(:require [clojure.set :as set]
[java-time :as time]
[org.parkerici.sample-tracking.db.core :as db]
[org.parkerici.sample-tracking.db.timepoint :as timepoint-db]
[org.parkerici.sample-tracking.db.kit-type :as kit-type-db]
[org.parkerici.sample-tracking.db.kit :as kit-db]
[org.parkerici.sample-tracking.db.form-type :as form-type-db]
[org.parkerici.sample-tracking.db.form-value :as form-value-db]
[org.parkerici.sample-tracking.db.sample :as sample-db]
[org.parkerici.sample-tracking.db.shipment :as shipment-db]
[org.parkerici.sample-tracking.db.history :as history-db]
[org.parkerici.sample-tracking.db.proposed-kit-edit :as proposed-kit-edit-db]
[org.parkerici.sample-tracking.api.email :as email]
[org.parkerici.sample-tracking.utils.collection :as coll-utils])
(:import (java.util Date UUID)))
(defn create-samples-and-add-to-kit-shipment
[kit-uuid shipment-uuid samples]
(doseq [sample-type-uuid (keys samples)]
(let [sample (get samples sample-type-uuid)
sample-collected (boolean (:collected sample))
sample-shipped (boolean (:shipped sample))]
(when sample-collected
(let [sample-uuid (sample-db/create-or-update-sample nil (name sample-type-uuid) (:sample-id sample)
sample-collected sample-shipped)]
(kit-db/add-sample-to-kit kit-uuid sample-uuid)
(when (and shipment-uuid sample-shipped) (sample-db/add-sample-to-shipment shipment-uuid sample-uuid)))))))
(defn create-update-form-value
[form-value-uuid form-value-field-id-key form-fields form-values]
(let [form-value-field-id (name form-value-field-id-key)
form-field (first (filter #(= form-value-field-id (:field-id %)) form-fields))
form-field-type (:type form-field)
form-field-uuid (:uuid form-field)
raw-form-value (get form-values form-value-field-id-key)
parsed-form-value (case form-field-type
"time" (if (string? raw-form-value) (time/java-date raw-form-value) raw-form-value)
"boolean" (if (string? raw-form-value) (Boolean/valueOf raw-form-value) raw-form-value)
"int" (if (string? raw-form-value) (Long/parseLong raw-form-value) raw-form-value)
raw-form-value)]
(form-value-db/create-or-update-form-value form-value-uuid form-field-uuid form-field-type parsed-form-value)))
(defn create-form-values-and-add-to-kit
[kit-uuid kit-type-uuid form-values]
(let [form-fields (form-type-db/get-form-type-fields kit-type-uuid)]
(doseq [form-value-field-id-key (keys form-values)]
(let [form-value-uuid (create-update-form-value nil form-value-field-id-key form-fields form-values)]
(kit-db/add-form-value-to-kit kit-uuid form-value-uuid)))))
(defn create-kit-shipment
[kit-map]
(let [{:keys [air-waybill kit-type samples form-type-field-values]} kit-map
kit-type-uuid (UUID/fromString kit-type)
kit-uuid (kit-db/create-or-update-kit nil kit-map)
shipment-uuid (when (some? air-waybill) (shipment-db/create-or-update-shipment nil air-waybill))]
(when (some? shipment-uuid) (kit-db/add-shipment-to-kit kit-uuid shipment-uuid))
(create-samples-and-add-to-kit-shipment kit-uuid shipment-uuid samples)
(create-form-values-and-add-to-kit kit-uuid kit-type-uuid form-type-field-values)
kit-uuid))
; If uuid is passed in then filters on that as a kit uuid. Otherwise returns all kits.
; If tx-id is passed in then queries the kit-shipment values as-of the historical tx-id
(defn list-kit-shipment
[config-map]
(let [kits (kit-db/list-kits config-map)
timepoints (timepoint-db/list-kit-timepoints config-map)
samples (sample-db/list-samples config-map)
form-values (form-value-db/list-form-values config-map)
shipments (shipment-db/list-shipments config-map)
pending-edits (map #(select-keys % [:kit-uuid :uuid :email :time])
(proposed-kit-edit-db/list-proposed-edits {:status "pending"}))
edit-history (map #(select-keys % [:entity-uuid :agent-email :time])
(history-db/list-history nil))]
(-> kits
(coll-utils/merge-map-colls :uuid timepoints :kit-uuid :timepoints)
(coll-utils/merge-map-colls :uuid samples :kit-uuid :samples)
(coll-utils/merge-map-colls :uuid form-values :kit-uuid :form-values)
(coll-utils/merge-map-colls :uuid shipments :kit-uuid :shipments)
(coll-utils/merge-map-colls :uuid pending-edits :kit-uuid :pending-edits)
(coll-utils/merge-map-colls :uuid edit-history :entity-uuid :history))))
(defn delete-samples
[current-sample-map sample-type-uuids]
(let [uuids (doall (map #(vector :sample-type/uuid (:uuid (get current-sample-map %))) sample-type-uuids))]
(db/retract-entities uuids)))
(defn update-existing-samples
[shipment-uuid current-sample-map updated-sample-map sample-type-uuids]
(let [shipment-sample-uuids (sample-db/list-shipment-samples shipment-uuid)]
(doseq [sample-type-uuid sample-type-uuids]
(let [current-sample (get current-sample-map sample-type-uuid)
sample-uuid (:uuid current-sample)
current-sample-in-shipment (boolean (some #(= sample-uuid %) shipment-sample-uuids))
updated-sample (get updated-sample-map sample-type-uuid)
updated-sample-collected (boolean (:collected updated-sample))
updated-sample-shipped (boolean (:shipped updated-sample))]
; Update the existing shipment in the db with the new values
(sample-db/create-or-update-sample sample-uuid (name sample-type-uuid) (:sample-id updated-sample)
updated-sample-collected updated-sample-shipped)
; If the current sample was marked as shipped, but the updated one was not then remove the sample from the associated shipment.
(when (and current-sample-in-shipment (not updated-sample-shipped)) (sample-db/remove-sample-from-shipment shipment-uuid sample-uuid))
; If the current sample was not marked as shipped, but the updated one is then add the sample to the associated shipment
(when (and (not current-sample-in-shipment) updated-sample-shipped) (sample-db/add-sample-to-shipment shipment-uuid sample-uuid))))))
; Currently assumes one shipment per kit. May not be the case in the future.
(defn create-or-update-shipment
[kit-uuid air-waybill]
(let [current-shipment-uuid (:uuid (first (shipment-db/list-shipments kit-uuid)))
new-shipment-uuid (shipment-db/create-or-update-shipment current-shipment-uuid air-waybill)]
(when (and (some? new-shipment-uuid) (not= new-shipment-uuid current-shipment-uuid))
(kit-db/add-shipment-to-kit kit-uuid new-shipment-uuid))
(if current-shipment-uuid
current-shipment-uuid
new-shipment-uuid)))
(defn create-update-delete-samples
[kit-uuid shipment-uuid current-sample-map updated-sample-map]
(let [updated-sample-type-uuids (set (keys updated-sample-map))
current-sample-type-uuids (set (keys current-sample-map))
new-sample-type-uuids (set/difference updated-sample-type-uuids current-sample-type-uuids)
delete-sample-type-uuids (set/difference current-sample-type-uuids updated-sample-type-uuids)
update-sample-type-uuids (set/intersection current-sample-type-uuids updated-sample-type-uuids)]
(create-samples-and-add-to-kit-shipment kit-uuid shipment-uuid (select-keys updated-sample-map new-sample-type-uuids))
(delete-samples current-sample-map delete-sample-type-uuids)
(update-existing-samples shipment-uuid current-sample-map updated-sample-map update-sample-type-uuids)))
(defn update-existing-form-values
[kit-uuid kit-type-uuid current-form-values new-form-values]
(let [form-fields (form-type-db/get-form-type-fields kit-type-uuid)
current-form-field-id-map (reduce (fn [m v] (assoc m (keyword (:field-id v)) (:uuid v))) {} current-form-values)]
(doseq [form-value-field-id-key (keys new-form-values)]
(let [current-form-value-id (get current-form-field-id-map form-value-field-id-key)
updated-form-value-id (create-update-form-value (get current-form-field-id-map form-value-field-id-key) form-value-field-id-key form-fields new-form-values)]
(when (nil? current-form-value-id) (kit-db/add-form-value-to-kit kit-uuid updated-form-value-id))))))
(defn delete-existing-form-values
[current-form-values]
(let [ids (map #(vector :form-value/uuid (:uuid %)) current-form-values)]
(db/retract-entities ids)))
(defn delete-existing-create-new-form-values
[kit-uuid kit-type-uuid current-form-values new-form-values]
(delete-existing-form-values current-form-values)
(create-form-values-and-add-to-kit kit-uuid kit-type-uuid new-form-values))
(defn update-form-values
[kit-db-id current-kit-type-uuid updated-kit-type-uuid current-form-values new-form-values]
(let [current-form-type (kit-type-db/get-kit-type-form-type current-kit-type-uuid)
updated-form-type (kit-type-db/get-kit-type-form-type updated-kit-type-uuid)]
; If the form-type hasn't changed we can just update the existing form values.
; If it has changed then we should delete the existing values and create new ones.
(if (= (:uuid current-form-type) (:uuid updated-form-type))
(update-existing-form-values kit-db-id updated-kit-type-uuid current-form-values new-form-values)
(delete-existing-create-new-form-values kit-db-id updated-kit-type-uuid current-form-values new-form-values))))
(defn get-kit-values
[kit-uuid]
(let [config-map {:uuid kit-uuid}
kit (first (kit-db/list-kits config-map))
sample-map (reduce (fn [m v] (assoc m (keyword (str (:sample-type-uuid v))) v)) {} (sample-db/list-samples config-map))
form-values (form-value-db/list-form-values config-map)
shipment (first (shipment-db/list-shipments config-map))]
{:kit kit
:samples sample-map
:form-values form-values
:shipment shipment}))
(defn remove-deleted-timepoints
[kit-uuid updated-kit-map]
(let [current-timepoints (timepoint-db/list-kit-timepoints {:uuid kit-uuid})
current-timepoint-uuids (map :uuid current-timepoints)
updated-timepoints-uuids (map #(UUID/fromString %) (:timepoints updated-kit-map))
deleted-timepoints (set/difference (set current-timepoint-uuids) (set updated-timepoints-uuids))]
(doseq [timepoint-uuid deleted-timepoints] (kit-db/remove-timepoint-from-kit kit-uuid timepoint-uuid))))
(defn update-kit-shipment
[kit-uuid kit-map]
(let [{:keys [air-waybill kit-type samples form-type-field-values]} kit-map
config-map {:uuid kit-uuid}
kit-type-uuid (UUID/fromString kit-type)
current-kit (first (kit-db/list-kits config-map))
current-sample-map (reduce (fn [m v] (assoc m (keyword (str (:sample-type-uuid v))) v)) {} (sample-db/list-samples config-map))
current-form-values (form-value-db/list-form-values config-map)
shipment-id (create-or-update-shipment kit-uuid air-waybill)]
(kit-db/create-or-update-kit kit-uuid kit-map)
(remove-deleted-timepoints kit-uuid kit-map)
(create-update-delete-samples kit-uuid shipment-id current-sample-map samples)
(update-form-values kit-uuid (:kit-type-uuid current-kit) kit-type-uuid current-form-values form-type-field-values)
kit-uuid))
(defn update-kit-shipment-with-history
[kit-uuid user kit-map]
(let [current-kit-values (get-kit-values kit-uuid)]
(update-kit-shipment kit-uuid kit-map)
(history-db/create-history user :kit-shipment kit-uuid (str current-kit-values) (str (get-kit-values kit-uuid)))
kit-uuid))
; If a kit hasn't been created, create it as complete otherwise update it to be complete. Send and email when done.
(defn submit-kit-shipment
[submitted-kit-uuid kit-map]
(let [completed-kit-map (merge kit-map {:complete true :submission-timestamp (Date.)})
kit-uuid (or submitted-kit-uuid (create-kit-shipment completed-kit-map))]
(when-not (nil? submitted-kit-uuid)
(update-kit-shipment kit-uuid completed-kit-map))
(email/send-manifest-email kit-map kit-uuid)
kit-uuid))
(defn set-kit-shipment-archived
[kit-uuid user archived]
(let [current-kit-values (get-kit-values kit-uuid)]
(kit-db/set-archived kit-uuid archived)
(doseq [shipment (shipment-db/list-shipments {:uuid kit-uuid})]
(shipment-db/set-archived (:uuid shipment) archived))
(history-db/create-history user :kit-shipment kit-uuid (str current-kit-values) (str (get-kit-values kit-uuid)))
kit-uuid))

View File

@@ -0,0 +1,179 @@
(ns org.parkerici.sample-tracking.api.kit-type
"This file is focused on taking in a csv with kit and sample type definitions
along with the studies, cohorts, and timepoints they belong to,
parsing that csv, and then creating the appropriate values in the database."
(:require [org.parkerici.sample-tracking.utils.csv :as csv]
[org.parkerici.sample-tracking.configuration :as config]
[clojure.string :as str]
[clojure.set :as set]
[org.parkerici.sample-tracking.db.study :as study-db]
[org.parkerici.sample-tracking.db.cohort :as cohort-db]
[org.parkerici.sample-tracking.db.kit-type :as kit-type-db]
[org.parkerici.sample-tracking.db.timepoint :as timepoint-db]
[org.parkerici.sample-tracking.db.sample-type :as sample-type-db]
[org.parkerici.sample-tracking.db.sample-attribute :as sample-attribute-db]))
; Used with filter to remove rows in the input CSV that don't have the required values.
(defn row-has-required-values
[row]
(not (or (empty? (:study-name row))
(empty? (:cohort-name row))
(empty? (:kit-item-no row))
(empty? (:kit-name row))
(empty? (:sample-id-suffix row))
(empty? (:sample-name row))
(empty? (:kit-timepoints row))
(empty? (:ships-with-kit row)))))
(defn read-csv
[fpath]
(filter row-has-required-values (drop 1 (csv/read-csv-file fpath))))
(defn find-or-create-study
[study-name]
(or (:uuid (study-db/find-study-by-name study-name)) (study-db/create-study study-name)))
(defn find-or-create-cohort-and-add-to-study
[study-uuid cohort-name]
(let [cohort-uuid (or (:uuid (cohort-db/find-cohort-by-name-and-study cohort-name study-uuid) (cohort-db/create-cohort cohort-name study-uuid)))]
(when-not (study-db/cohort-associated-with-study study-uuid cohort-uuid)
(study-db/add-cohort-to-study study-uuid cohort-uuid))
cohort-uuid))
(defn create-kit-type-and-add-to-cohort
[cohort-uuid kit-name kit-item-number vendor-email collection-date-required air-waybill-required]
(let [kit-type-uuid (kit-type-db/create-kit-type kit-name kit-item-number vendor-email collection-date-required air-waybill-required)]
(cohort-db/add-kit-type-to-cohort cohort-uuid kit-type-uuid)
kit-type-uuid))
(defn add-attribute-to-sample-type
[sample-type-uuid attribute value]
(let [attribute-uuid (or (sample-attribute-db/find-sample-attribute attribute) (sample-attribute-db/create-sample-attribute attribute))
value-uuid (or (sample-attribute-db/find-sample-attribute-value value attribute-uuid) (sample-attribute-db/create-sample-attribute-value value attribute-uuid))]
(sample-type-db/add-attribute-value-to-sample-type sample-type-uuid value-uuid)))
(defn find-or-create-timepoint-and-add-to-kit-type
[kit-type-uuid timepoint-name]
(let [timepoint-uuid (or (timepoint-db/find-timepoint-uuid-from-name timepoint-name) (timepoint-db/create-timepoint timepoint-name))]
(kit-type-db/add-timepoint-to-kit-type timepoint-uuid kit-type-uuid)))
(defn create-sample-type-and-add-to-kit-type
[kit-type-uuid sample-name sample-id-suffix sample-ships-with-kit sample-reminder attributes-and-values]
(let [sample-type-uuid (sample-type-db/create-sample-type sample-name sample-id-suffix sample-ships-with-kit sample-reminder)]
(doseq [[attribute value] attributes-and-values]
(add-attribute-to-sample-type sample-type-uuid attribute value))
(kit-type-db/add-sample-type-to-kit-type sample-type-uuid kit-type-uuid)
sample-type-uuid))
(defn parse-boolean
[value]
(case (str/lower-case value)
"yes" true
"no" false))
; Attributes and values are taken from any extra columns in the input CSV.
; The first n columns are expected to map to the column names in (config/csv-file-headers :kit-type)
; Any remaining columns after the first column are taken as attributes and values.
; The column header is used as the attribute and the cell value for the row is used as the value for that attribute.
(defn get-attributes-and-values
[row]
(let [attributes (set/difference (set (keys row)) (set (config/csv-file-headers :kit-type)))]
(select-keys row attributes)))
(defn update-sample-types-map
[row kit-type-map]
(let [sample-types (or (:sample-types kit-type-map) [])
sample-attributes-and-values (get-attributes-and-values row)
sample-type {:name (:sample-name row)
:id-suffix (:sample-id-suffix row)
:ships-with-kit (parse-boolean (:ships-with-kit row))
:reminders (:sample-reminders row)
:attributes-and-values sample-attributes-and-values}
updated-sample-types (conj sample-types sample-type)]
updated-sample-types))
(defn update-kit-type-map
[row kit-name cohort-map]
(let [kit-type-map (or (get cohort-map kit-name) {})
timepoints (or (:timepoints kit-type-map) (csv/split-csv-string (:kit-timepoints row)))
item-number (or (:item-number kit-type-map) (Integer/parseInt (:kit-item-no row)))
vendor-email (or (:vendor-email kit-type-map) (:vendor-email row))
collection-date-required (or (:collection-date-required kit-type-map) (not (= (str/lower-case (:collection-date-optional row)) "true")))
air-waybill-required (or (:air-waybill-required kit-type-map) (not (= (str/lower-case (:air-waybill-optional row)) "true")))
sample-types (update-sample-types-map row kit-type-map)
updated-kit-type-map (-> kit-type-map
(assoc :sample-types sample-types)
(assoc :timepoints timepoints)
(assoc :item-number item-number)
(assoc :vendor-email vendor-email)
(assoc :collection-date-required collection-date-required)
(assoc :air-waybill-required air-waybill-required))]
updated-kit-type-map))
(defn update-cohort-map
[row cohort-name study-map]
(let [cohort-map (or (get study-map cohort-name) {})
kit-name (:kit-name row)
kit-type-map (update-kit-type-map row kit-name cohort-map)
updated-cohort-map (assoc cohort-map kit-name kit-type-map)]
updated-cohort-map))
(defn update-study-map
[row study-name m]
(let [study-map (or (get m study-name) {})
cohort-name (:cohort-name row)
cohort-map (update-cohort-map row cohort-name study-map)
updated-study-map (assoc study-map cohort-name cohort-map)]
updated-study-map))
(defn build-type-map
[csv-data]
(reduce (fn [type-map row]
(let [study-name (:study-name row)
study-map (update-study-map row study-name type-map)
updated-m (assoc type-map study-name study-map)]
updated-m)) {} csv-data))
(defn process-sample-type-map
[kit-type-uuid sample-type-map]
(create-sample-type-and-add-to-kit-type kit-type-uuid
(:name sample-type-map)
(:id-suffix sample-type-map)
(:ships-with-kit sample-type-map)
(:reminders sample-type-map)
(:attributes-and-values sample-type-map)))
(defn process-kit-type-map
[cohort-uuid kit-type-name kit-type-map]
(when-not (kit-type-db/find-active-kit-type-by-name-and-cohort kit-type-name cohort-uuid)
(let [kit-type-uuid (create-kit-type-and-add-to-cohort
cohort-uuid kit-type-name (:item-number kit-type-map) (:vendor-email kit-type-map)
(:collection-date-required kit-type-map) (:air-waybill-required kit-type-map))]
(doseq [timepoint (:timepoints kit-type-map)]
(find-or-create-timepoint-and-add-to-kit-type kit-type-uuid timepoint))
(doseq [sample-type (:sample-types kit-type-map)]
(process-sample-type-map kit-type-uuid sample-type)))))
(defn process-cohort-map
[study-uuid cohort-name cohort-map]
(let [cohort-uuid (find-or-create-cohort-and-add-to-study study-uuid cohort-name)]
(doseq [kit-type (keys cohort-map)]
(process-kit-type-map cohort-uuid kit-type (get cohort-map kit-type)))))
(defn process-study-map
[study-name study-map]
(let [study-uuid (find-or-create-study study-name)]
(doseq [cohort (keys study-map)]
(process-cohort-map study-uuid cohort (get study-map cohort)))))
(defn process-type-map
[type-map]
(doseq [study (keys type-map)]
(process-study-map study (get type-map study))))
(defn parse-kit-type-csv-and-save-to-db
[fpath]
(let [csv-headers (config/csv-file-headers :kit-type)
csv-data (csv/read-csv-into-map fpath csv-headers row-has-required-values)
type-map (build-type-map csv-data)]
(process-type-map type-map)))

View File

@@ -0,0 +1,20 @@
(ns org.parkerici.sample-tracking.api.migrate
(:require [org.parkerici.sample-tracking.db.migration :as migration]
[org.parkerici.sample-tracking.db.migration.air-waybill-required :as air-waybill-migration]
[taoensso.timbre :as log]))
(defn migrate-kit-types-without-air-waybill-required
[]
(doseq [to-migrate (air-waybill-migration/list-kit-types-without-air-waybill-required)]
(air-waybill-migration/set-kit-type-air-waybill-required (:uuid to-migrate) true)))
(defn run-migration
[name fn]
(when-not (migration/migration-has-been-run name)
(log/info "Running migration" name)
(fn)
(migration/create-migration name)))
(defn run-pending-migrations
[]
(run-migration "add-kit-type-air-waybill" migrate-kit-types-without-air-waybill-required))

View File

@@ -0,0 +1,181 @@
(ns org.parkerici.sample-tracking.api.propose-kit-edits
(:require [clojure.edn :as edn]
[org.parkerici.sample-tracking.api.kit-shipment :as kit-shipment]
[org.parkerici.sample-tracking.db.proposed-kit-edit :as proposed-kit-edit-db]
[org.parkerici.sample-tracking.db.site :as site-db]
[org.parkerici.sample-tracking.db.study :as study-db]
[org.parkerici.sample-tracking.db.cohort :as cohort-db]
[org.parkerici.sample-tracking.db.form-type :as form-type-db]
[org.parkerici.sample-tracking.db.kit-type :as kit-type-db]
[org.parkerici.sample-tracking.db.sample-type :as sample-type-db]
[org.parkerici.sample-tracking.db.timepoint :as timepoint-db]
[org.parkerici.sample-tracking.api.email :as email]
[org.parkerici.sample-tracking.utils.collection :as coll-utils])
(:import (java.util UUID)))
(defn propose-kit-edits
[kit-map user-email]
(let [kit-uuid (UUID/fromString (:uuid kit-map))
pending-proposed-edit-uuid (:uuid (first (proposed-kit-edit-db/list-proposed-edits {:kit-uuid kit-uuid :status "pending"})))
uuid (proposed-kit-edit-db/create-or-update-proposed-edit pending-proposed-edit-uuid kit-uuid (str kit-map) user-email)]
(email/send-proposed-edit-email kit-map user-email)
uuid))
(defn list-proposed-edits
[config-map]
(let [proposed-edits (proposed-kit-edit-db/list-proposed-edits config-map)
timepoints (timepoint-db/list-kit-timepoints config-map)]
(coll-utils/merge-map-colls proposed-edits :kit-uuid timepoints :kit-uuid :timepoints)))
(defn convert-update-map-to-display-map
"There are three formats of maps for kits. Form maps for populating edit forms, display maps for generating a view page
using manifest.cljc, and create/update maps for creating or updating kits.
This function converts an update map to a display map."
[update-map]
(let [kit-type-uuid (UUID/fromString (:kit-type update-map))
site-name (:name (site-db/find-site-by-uuid (UUID/fromString (:site update-map))))
study-name (:name (study-db/find-study-by-uuid (UUID/fromString (:study update-map))))
cohort-name (:name (cohort-db/find-cohort-by-uuid (UUID/fromString (:cohort update-map))))
timepoint-names (map #(:name (timepoint-db/find-timepoint-by-uuid (UUID/fromString %))) (:timepoints update-map))
kit-name (kit-type-db/get-kit-type-name kit-type-uuid)
collection-timestamp (:collection-timestamp update-map)
selected-form-type-fields (form-type-db/get-form-type-fields kit-type-uuid)
selected-sample-types (sample-type-db/list-sample-types kit-type-uuid)
unchaged-update-map (select-keys update-map [:kit-id :participant-id :form-type-field-values :air-waybill
:completing-first-name :completing-last-name :completing-email
:comments :complete])
display-map {:site-name site-name
:study-name study-name
:cohort-name cohort-name
:timepoint-names timepoint-names
:kit-name kit-name
:collection-date collection-timestamp
:collection-time collection-timestamp
:selected-form-type-fields selected-form-type-fields
:selected-sample-types selected-sample-types
:sample-values (:samples update-map)
:archived false
}]
(merge display-map unchaged-update-map)))
(defn convert-form-map-to-display-map
"There are three formats of maps for kits. Form maps for populating edit forms, display maps for generating a view page
using manifest.cljc, and create/update maps for creating or updating kits.
This function converts an edit form map to a display map."
[original-map]
(let [kit-type-uuid (:kit-type-uuid original-map)
site-name (:name (site-db/find-site-by-uuid (:site-uuid original-map)))
study-name (:name (study-db/find-study-by-uuid (:study-uuid original-map)))
cohort-name (:name (cohort-db/find-cohort-by-uuid (:cohort-uuid original-map)))
timepoint-names (map :timepoint-name (:timepoints original-map))
kit-name (kit-type-db/get-kit-type-name kit-type-uuid)
collection-timestamp (:collection-timestamp original-map)
selected-form-type-fields (form-type-db/get-form-type-fields kit-type-uuid)
form-type-field-values (reduce (fn [m v]
(assoc m (keyword (:field-id v)) (:value v))) {} (:form-values original-map))
selected-sample-types (sample-type-db/list-sample-types kit-type-uuid)
samples (reduce (fn [m s] (assoc m (:sample-type-uuid s) s)) {} (:samples original-map))
air-waybill (:air-waybill (first (:shipments original-map)))
unchaged-map-entries (select-keys original-map [:kit-id :participant-id :completing-first-name
:completing-last-name :completing-email :comments :complete
:archived])
display-map {:site-name site-name
:study-name study-name
:cohort-name cohort-name
:timepoint-names timepoint-names
:kit-name kit-name
:collection-date collection-timestamp
:collection-time collection-timestamp
:selected-form-type-fields selected-form-type-fields
:form-type-field-values form-type-field-values
:selected-sample-types selected-sample-types
:sample-values samples
:air-waybill air-waybill
:archived false
}]
(merge display-map unchaged-map-entries)))
(defn get-proposed-kit-edit-for-display
[uuid]
(let [proposed-edit (first (proposed-kit-edit-db/list-proposed-edits {:uuid uuid}))
tx-id (proposed-kit-edit-db/get-proposed-edit-tx-id uuid)
unedited-map (first (kit-shipment/list-kit-shipment {:uuid (:kit-uuid proposed-edit) :tx-id tx-id}))
unedited-display-map (convert-form-map-to-display-map unedited-map)
update-map (edn/read-string (:update-map proposed-edit))
updated-display-map (convert-update-map-to-display-map update-map)]
{:original-map unedited-display-map :update-map updated-display-map :status (:status proposed-edit)}))
(defn get-proposed-kit-edit
[uuid]
(first (proposed-kit-edit-db/list-proposed-edits {:uuid uuid})))
(defn approve-proposed-kit-edit
[uuid reviewing-user]
(let [proposed-edit (first (proposed-kit-edit-db/list-proposed-edits {:uuid uuid}))
update-map (edn/read-string (:update-map proposed-edit))]
(kit-shipment/update-kit-shipment-with-history (:kit-uuid proposed-edit) reviewing-user update-map)
(proposed-kit-edit-db/approve-proposed-edit uuid reviewing-user)))
(defn deny-proposed-kit-edit
[uuid reviewing-user]
(proposed-kit-edit-db/deny-proposed-edit uuid reviewing-user))
(defn kit-has-pending-edits
[uuid]
(> (count (proposed-kit-edit-db/list-proposed-edits {:uuid uuid :status "pending"})) 0))
(defn convert-update-map-form-values
[kit-type form-type-field-values]
(let [form-type-fields (form-type-db/get-form-type-fields (UUID/fromString kit-type))
updated-form-values form-type-field-values]
(map (fn [field-key]
(let [field (first (filter #(= (name field-key) (:field-id %)) form-type-fields))
value (get updated-form-values field-key)
field-type (:type field)
field-id (:field-id field)]
(-> {}
(assoc :field-id field-id)
(assoc :value value)
(assoc :field-type field-type))))
(keys updated-form-values))))
(defn convert-update-map-to-form-map
" There are three formats of maps for kits. Form maps for populating edit forms, display maps for generating a view page
using manifest.cljc, and create/update maps for creating or updating kits.
This function converts an update map to an edit form map."
[proposed-edit]
(let [proposed-edit-uuid (:uuid proposed-edit)
proposed-edit-email (:email proposed-edit)
proposed-edit-time (:time proposed-edit)
update-map (edn/read-string (:update-map proposed-edit))
{:keys [samples timepoints form-type-field-values air-waybill site kit-type cohort study]} update-map
form-samples (map (fn [sample-type-uuid]
(let [sample (get samples sample-type-uuid)]
(assoc sample :sample-type-uuid sample-type-uuid)))
(keys samples))
form-timepoints (map #(assoc {} :uuid %) timepoints)
shipments [{:air-waybill air-waybill}]
form-values (convert-update-map-form-values kit-type form-type-field-values)
unchaged-map-entries (select-keys update-map [:timezone :completing-last-name :collection-timestamp
:completing-email :comments :completing-first-name
:participant-id :kit-id :uuid])
form-map {:pending-edits [{:uuid proposed-edit-uuid :email proposed-edit-email :time proposed-edit-time}]
:samples form-samples
:timepoints form-timepoints
:shipments shipments
:site-uuid site
:kit-type-uuid kit-type
:cohort-uuid cohort
:form-values form-values
:study-uuid study}]
(merge unchaged-map-entries form-map)))
(defn get-kit-or-proposed-edit
"Gets a kit map if there is no pending proposed edit, otherwise gets a map of the pending proposed edit. When using
this function you should get the kit from kit-shipment first so that the email filtering from the config-map is used."
[config-map]
(let [kit (first (kit-shipment/list-kit-shipment config-map))]
(if (= (count (:pending-edits kit)) 0)
kit
(let [pending-proposed-edit (first (proposed-kit-edit-db/list-proposed-edits {:kit-uuid (:uuid kit) :status "pending"}))]
(convert-update-map-to-form-map pending-proposed-edit)))))

View File

@@ -0,0 +1,31 @@
(ns org.parkerici.sample-tracking.api.site
"This file deals with reading in a csv with sites along with the studies they are running,
parsing that csv, and then creating the appropriate associations of sites with studies in the database."
(:require [org.parkerici.sample-tracking.utils.csv :as csv]
[org.parkerici.sample-tracking.configuration :as config]
[org.parkerici.sample-tracking.db.study :as study-db]
[org.parkerici.sample-tracking.db.site :as site-db]))
; Used with filter to remove rows in the input CSV that don't have the required values.
(defn row-has-required-values
[row]
(not (or (empty? (:site row))
(empty? (:study-names row)))))
(defn find-or-create-site
[name]
(or (:id (site-db/find-site-by-name name)) (site-db/create-site name)))
(defn create-site
[row]
(let [site-uuid (find-or-create-site (:site row))
study-names (csv/split-csv-string (:study-names row))]
(doseq [study-name study-names]
(when-not (study-db/site-is-associated-with-study site-uuid study-name)
(study-db/add-site-to-study site-uuid study-name)))))
(defn parse-site-csv-and-save-to-db
[fpath]
(let [csv-headers (config/csv-file-headers :site)
csv-data (csv/read-csv-into-map fpath csv-headers row-has-required-values)]
(doseq [row csv-data] (create-site row))))

View File

@@ -0,0 +1,28 @@
(ns org.parkerici.sample-tracking.api.study
"This file deals with reading in a csv with studies along with validation information for participant and kit ids,
parsing that csv, and then creating the appropriate associations of studies with validation information."
(:require [org.parkerici.sample-tracking.utils.csv :as csv]
[org.parkerici.sample-tracking.configuration :as config]
[org.parkerici.sample-tracking.db.study :as study-db]
[org.parkerici.sample-tracking.utils.str :as str]))
; Used with filter to remove rows in the input CSV that don't have the required values.
(defn row-has-required-values
[row]
(str/not-blank? (:study row)))
(defn add-validation-to-study
[row]
(let [{:keys [study participant-id-prefix participant-id-regex participant-id-validation-message kit-id-prefix
kit-id-regex kit-id-validation-message]} row]
(when (str/not-blank? participant-id-regex)
(study-db/add-participant-id-validation-to-study study participant-id-prefix participant-id-regex participant-id-validation-message))
(when (str/not-blank? kit-id-regex)
(study-db/add-kit-id-validation-to-study study kit-id-prefix kit-id-regex kit-id-validation-message))))
(defn parse-study-csv-and-save-to-db
[fpath]
(let [csv-headers (config/csv-file-headers :study)
csv-data (csv/read-csv-into-map fpath csv-headers row-has-required-values)]
(doseq [row csv-data]
(add-validation-to-study row))))

View File

@@ -0,0 +1,99 @@
(ns org.parkerici.sample-tracking.cli
(:gen-class)
(:require [org.parkerici.sample-tracking.db.schema :as schema]
[org.parkerici.sample-tracking.api.iam :as auth]
[org.parkerici.sample-tracking.db.datomic :as d]
[org.parkerici.sample-tracking.server :as server]
[org.parkerici.sample-tracking.api.kit-type :as kit-type]
[org.parkerici.sample-tracking.api.site :as site]
[org.parkerici.sample-tracking.api.study :as study]
[org.parkerici.sample-tracking.api.form-type :as form-type]
[org.parkerici.sample-tracking.api.migrate :as migrate]
[org.parkerici.sample-tracking.configuration :as c]
[clojure.java.io :as io]
[taoensso.timbre :as log]
[clojure.tools.cli :as cli]
[clojure.string :as str]
[org.parkerici.sample-tracking.api.iam :as iam]))
(def default-port 1777)
(defmulti command
(fn [command _arguments _options _summary] command))
(defmethod command "predeploy"
[_ _ _ _]
(log/info "Transacting schema.")
(schema/transact-schema)
(log/info "Running pending migrations.")
(d/wrap-datomic-fn migrate/run-pending-migrations)
(log/info "Initializing roles.")
(d/wrap-datomic-fn #(doall (map auth/find-or-create-role (c/application-role-values)))))
(defmethod command "test-setup"
[_ _ _ _]
(schema/transact-schema)
(d/wrap-datomic-fn #(doall (map auth/find-or-create-role (c/application-role-values))))
(d/wrap-datomic-fn #(iam/find-or-create-user "test@example.com"))
(d/wrap-datomic-fn #(kit-type/parse-kit-type-csv-and-save-to-db (io/resource "forms/kit_types.csv")))
(d/wrap-datomic-fn #(site/parse-site-csv-and-save-to-db (io/resource "forms/sites.csv")))
(d/wrap-datomic-fn #(study/parse-study-csv-and-save-to-db (io/resource "forms/studies.csv")))
(d/wrap-datomic-fn #(form-type/parse-form-type-csv-and-save-to-db (io/resource "forms/form_types.csv"))))
(defmethod command "transact-schema"
[_ _ _ _]
(log/info "Transacting schema.")
(schema/transact-schema))
(defmethod command "create-roles"
[_ _ _ _]
(d/wrap-datomic-fn #(doall (map auth/find-or-create-role (c/application-role-values)))))
(defmethod command "add-admin"
[_ arguments _ _]
(let [user (first arguments)]
(d/wrap-datomic-fn #(auth/add-role-to-user user (c/application-admin-role)))))
(defmethod command "server"
[_ _ options _]
(let [port (if (:port options) (Integer. (:port options)) default-port)]
(server/start port)))
(defmethod command "run-pending-migrations"
[_ _ _ _]
(log/info "Running pending migrations")
(d/wrap-datomic-fn migrate/run-pending-migrations))
(defn all-commands []
(sort (keys (dissoc (methods command) :default))))
(defn usage
[options-summary]
(->> [""
"Usage: java -jar sample-tracking.jar [ACTION] [OPTIONS]..."
""
"Actions:"
(print-str (all-commands))
""
"Options:"
options-summary]
(str/join \newline)))
(defmethod command "help"
[_ _ summary]
(println (usage summary)))
(defmethod command :default
[command _ summary]
(log/error "Unknown command:" command)
(println (usage summary)))
(def cli-options
;; An option with a required argument
[["-p" "--port PORT" "Port for the server to start on"]])
(defn -main
[& args]
(let [{:keys [options arguments summary]} (cli/parse-opts args cli-options)]
(log/info "Running with environment" (c/environment))
(command (first arguments) (rest arguments) options summary)))

View File

@@ -0,0 +1,130 @@
(ns org.parkerici.sample-tracking.configuration
(:require [aero.core :as aero]
[clojure.java.io :as io]
[clojure.string :as str]))
(defn environment
"Retrieves which profile we should be using based on which environment we're deployed to"
[]
(let [env (System/getenv "DEPLOY_ENVIRONMENT")]
(if (empty? env)
:default
(keyword env))))
(def config (aero/read-config (io/resource "config.edn") {:profile (environment)}))
(defn datomic-config
[]
(:datomic config))
(defn datomic-endpoint
[]
(:endpoint (datomic-config)))
(defn datomic-access-key
[]
(:access-key (datomic-config)))
(defn datomic-secret
[]
(:secret (datomic-config)))
(defn datomic-db-name
[]
(:db-name (datomic-config)))
(defn datomic-validate-hostnames
[]
(:validate-hostnames (datomic-config)))
(defn application-config
[]
(:application config))
(defn firebase-js-credentials-path
[]
(:firebase-js-credentials-path (application-config)))
(defn application-roles
[]
(:roles (application-config)))
(defn application-role-values
[]
(vals (application-roles)))
(defn application-admin-role
[]
(:admin (application-roles)))
(defn application-editor-role
[]
(:editor (application-roles)))
(defn application-viewer-role
[]
(:viewer (application-roles)))
(defn site-admin-role
[]
(:site-admin (application-roles)))
(defn site-coordinator-role
[]
(:site-coordinator (application-roles)))
(defn csv-files-config
[]
(:csv-files (application-config)))
(defn csv-file-headers
[file]
(get-in (csv-files-config) [file :headers]))
(defn email-config
[]
(:email (application-config)))
(defn sendgrid-api-key
[]
(:sendgrid-api-key (email-config)))
(defn email-sender
[]
(:sender (email-config)))
(defn email-manifest-recipient
[]
(:manifest-recipient (email-config)))
(defn send-manifest-emails
[]
(= (str/lower-case (:send-manifest-emails (email-config))) "true"))
(defn send-vendor-emails
[]
(= (str/lower-case (:send-vendor-emails (email-config))) "true"))
(defn temp-path
[]
(:temp-path (application-config)))
(defn api-key
[]
(:api-key (application-config)))
(defn sample-export-config
[]
(:sample-export (application-config)))
(defn sample-export-columns-to-drop
[]
(:columns-to-drop (sample-export-config)))
(defn sample-export-column-order
[]
(:column-order (sample-export-config)))
(defn sample-export-columns-to-rename
[]
(:columns-to-rename (sample-export-config)))

View File

@@ -0,0 +1,73 @@
(ns org.parkerici.sample-tracking.db.cohort
(:require [org.parkerici.sample-tracking.db.datomic :as d]
[org.parkerici.sample-tracking.db.core :as db])
(:import (java.util Date)))
(defn create-cohort
[name study-uuid]
(let [uuid (db/squuid)
txn {:cohort/name name :cohort/uuid uuid :cohort/create-time (Date.) :cohort/study [:study/uuid study-uuid]}]
(db/transact [txn])
uuid))
(defn add-kit-type-to-cohort
[cohort-uuid kit-type-uuid]
(d/transact [[:db/add [:cohort/uuid cohort-uuid] :cohort/kit-types [[:kit-type/uuid kit-type-uuid] true]]]))
; TODO - Try converting to a pull
(defn find-cohort-by-name-and-study
[cohort-name study-uuid]
(first (d/q-latest '[:find ?uuid ?create-time
:keys uuid create-time
:in $ ?cohort-name ?study-uuid
:where
[?cohort :cohort/uuid ?uuid]
[?cohort :cohort/name ?cohort-name]
[?cohort :cohort/create-time ?create-time]
[?cohort :cohort/study ?study]
[?study :study/uuid ?study-uuid]]
cohort-name study-uuid)))
(defn find-cohort-by-uuid
[uuid]
(first (d/q-latest '[:find ?cohort-name ?create-time
:keys name create-time
:in $ ?uuid
:where
[?cohort :cohort/uuid ?uuid]
[?cohort :cohort/name ?cohort-name]
[?cohort :cohort/create-time ?create-time]]
uuid)))
(defn list-cohorts
[study-uuid active]
(let [query {:find '[?cohort-uuid ?cohort-name ?active ?create-time]
:keys '[uuid name active create-time]
:where '[[?study :study/uuid ?study-uuid]
[?study :study/cohorts ?cohort-tuple]
[(untuple ?cohort-tuple) [?cohort ?active]]
[?cohort :cohort/name ?cohort-name]
[?cohort :cohort/uuid ?cohort-uuid]
[?cohort :cohort/create-time ?create-time]]}
filtered-query (if (nil? active)
(assoc query :in '[$ ?study-uuid])
(assoc query :in '[$ ?study-uuid ?active]))]
(apply d/q-latest (remove nil? [filtered-query study-uuid active]))))
(defn update-cohort
[uuid name]
(d/transact [{:db/id [:cohort/uuid uuid]
:cohort/name name}]))
(defn update-cohort-active-status
[study-uuid cohort-uuid status]
(let [current-tuple (first (d/q-latest '[:find ?cohort ?active
:in $ ?cohort-uuid ?study-uuid
:where
[?study :study/uuid ?study-uuid]
[?study :study/cohorts ?cohort-tuple]
[(untuple ?cohort-tuple) [?cohort ?active]]
[?cohort :cohort/uuid ?cohort-uuid]]
cohort-uuid study-uuid))]
(when (some? current-tuple) (d/transact [[:db/retract [:study/uuid study-uuid] :study/cohorts current-tuple]]))
(d/transact [[:db/add [:study/uuid study-uuid] :study/cohorts [[:cohort/uuid cohort-uuid] status]]])))

View File

@@ -0,0 +1,42 @@
(ns org.parkerici.sample-tracking.db.core
(:require [org.parkerici.sample-tracking.db.datomic :as d]
[clojure.core.reducers :as r])
(:import (java.util UUID)))
(defn squuid []
(let [uuid (UUID/randomUUID)
time (System/currentTimeMillis)
secs (quot time 1000)
lsb (.getLeastSignificantBits uuid)
msb (.getMostSignificantBits uuid)
timed-msb (bit-or (bit-shift-left secs 32)
(bit-and 0x00000000ffffffff msb))]
(UUID. timed-msb lsb)))
(defn remove-nil-map-values
[map]
(into {} (filter #(not (nil? (second %))) map)))
(defn reduce-fn-filter
[map-coll fn]
(into [] (r/filter fn map-coll)))
(defn reducer-filter
[map-coll key value]
(reduce-fn-filter map-coll (fn [map] (= (get map key) value))))
; Convenience function. Assumes that the passed in transaction will create/modify one entity.
; Runs the transaction and returns the id of the created entity.
(defn transact-and-return-id
[txn]
(let [transaction-results (d/transact (map remove-nil-map-values txn))]
(first (vals (:tempids transaction-results)))))
(defn transact
[txn]
(d/transact (map remove-nil-map-values txn)))
(defn retract-entities
[db-ids]
(let [txns (for [db-id db-ids] [:db/retractEntity db-id])]
(d/transact txns)))

View File

@@ -0,0 +1,110 @@
(ns org.parkerici.sample-tracking.db.datomic
(:require [datomic.client.api :as d]
[org.parkerici.multitool.core :as u]
[org.parkerici.sample-tracking.configuration :as c]))
;;; Source https://gist.github.com/natural/871d7a3ddfb6ae5f72fb141e549ca3bb
(def ^{:dynamic true :doc "A Datomic database value used over the life of a Ring or CLI request."} *db*)
(def ^{:dynamic true :doc "A Datomic connection bound for the life of a Ring or CLI request."} *connection*)
(defn config
[]
{:server-type :peer-server
:access-key (c/datomic-access-key)
:secret (c/datomic-secret)
:endpoint (c/datomic-endpoint)
:validate-hostnames (c/datomic-validate-hostnames)})
;;; Ben@Cognitect says that this caches behind the scenes, no need to do ourselves
(defn conn
[]
(let [client (d/client (config))]
(d/connect client {:db-name (c/datomic-db-name)})))
;;; In general this should not be used; instead, use wrap-datomic-fn or equivalent
(defn latest-db
[]
(d/db (conn)))
(def default-timeout 60000) ;Far too long for web app, need TODO performance tuning / paging
(defn q
[query & args]
; (prn :q query :args args :db *db*)
(d/q {:query query :args (cons *db* args) :timeout 60000}))
; Chat with Mike about using this.
; If we don't query latest when creating a bunch of records from the uploaded files, we end up with duplicates instead of finding new values.
(defn q-latest
[query & args]
; (prn :q query :args args :db *db*)
(d/q {:query query :args (cons (d/db *connection*) args) :timeout 60000}))
(defn pull
[spec eid]
(d/pull *db* spec eid))
(defn q-as-of
"Return a function that works like q but on a historical version of the database"
[as-of]
(fn [query & args]
(apply d/q query (d/as-of (d/db *connection*) as-of) args)))
(defn pull-as-of
[as-of]
(fn [spec eid]
(d/pull (d/as-of (d/db *connection*) as-of) spec eid)))
(defn q-history
[query & args]
(d/q {:query query :args (cons (d/history *db*) args) :timeout 60000}))
(defn q1
"Query for a single result. Errors if there is more than one row returned."
[query & args]
(let [res (apply q query args)]
(if (> (count res) 1)
(throw (Error. (str "Multiple results where at most one expected: " query " " res)))
(first res))))
(defn q11
"Query for a single value in a single result. Errors if there is more than one row returned."
[query & args]
(let [res (apply q1 query args)]
(if (> (count res) 1)
(throw (Error. (str "Multiple results where at most one expected: " query " " res)))
(first res))))
(defn transact
[txn]
(d/transact *connection* {:tx-data txn}))
(defn get-entity
[id]
(first
(q1 '[:find (pull ?id [*])
:in $ ?id]
id)))
(defn wrap-datomic
"A Ring middleware that provides a request-consistent database connection and
value for the life of a request."
[handler]
(fn [request]
(let [connection (conn)]
(binding [*connection* connection
*db* (d/db connection)]
(handler request)))))
;;; TODO the doall-safe is to try to make sure lazy lists are realized within the scope of the db binding
;;; but it doesn't really work because inner elements might be lazy. Really needs to do a walk of the structure.
(defn wrap-datomic-fn
[f]
((wrap-datomic (fn [& _] (u/doall-safe (f)))) nil))
(defn update->txn
"`entity` is an entity map, update is an updated version of it (can be incomplete). Generates a txn. Not recursive (but maybe should be)."
[entity update]
(for [[key val] update
:when (not (= (get entity key) val))]
[:db/add (:db/id entity) key val]))

View File

@@ -0,0 +1,58 @@
(ns org.parkerici.sample-tracking.db.form-type
(:require [org.parkerici.sample-tracking.db.datomic :as d]
[org.parkerici.sample-tracking.db.core :as db]))
;TODO - This errors silently if field-type is not one of the valid enums. Should raise an error.
(defn create-form-type-field
[field-map]
(let [uuid (db/squuid)
{:keys [field-id type required label options]} field-map
txn (cond-> {:form-type-field/uuid uuid
:form-type-field/field-id field-id
:form-type-field/field-type (keyword "form-type-field-type" type)
:form-type-field/required required
:form-type-field/label label}
(some? options) (assoc :form-type-field/options options))]
(db/transact [txn])
uuid))
(defn find-form-type
[name]
(ffirst (d/q-latest '[:find ?uuid
:in $ ?form-type-name
:where
[?form-type :form-type/name ?form-type-name]
[?form-type :form-type/uuid ?uuid]]
name)))
(defn create-form-type
[name fields]
(let [uuid (db/squuid)
txn {:form-type/name name :form-type/uuid uuid :form-type/fields fields}]
(db/transact [txn])
uuid))
(defn process-form-type-field-pull
[results]
(map (fn [result]
(let [result-map (first result)]
(-> result-map
(assoc :options (into {} (:options result-map)))
(assoc :type (get-in result-map [:form-type-field/field-type :type]))
(dissoc :form-type-field/field-type)))) results))
(defn get-form-type-fields
[kit-type-uuid]
(let [results (d/q-latest '[:find (pull ?field [[:form-type-field/uuid :as :uuid]
[:form-type-field/field-id :as :field-id]
[:form-type-field/required :as :required]
[:form-type-field/label :as :label]
[:form-type-field/options :as :options]
{:form-type-field/field-type [[:db/doc :as :type]]}])
:in $ ?kit-type-uuid
:where
[?kit-type :kit-type/uuid ?kit-type-uuid]
[?kit-type :kit-type/form-type ?form-type]
[?form-type :form-type/fields ?field]] kit-type-uuid)]
(process-form-type-field-pull results)))

View File

@@ -0,0 +1,37 @@
(ns org.parkerici.sample-tracking.db.form-value
(:require [org.parkerici.sample-tracking.db.datomic :as d]
[org.parkerici.sample-tracking.db.core :as db]))
(defn create-or-update-form-value
[uuid field field-type value]
(let [uuid-to-return (or uuid (db/squuid))
txn (cond-> {:form-value/field [:form-type-field/uuid field]}
uuid (assoc :db/id [:form-value/uuid uuid])
(nil? uuid) (assoc :form-value/uuid uuid-to-return)
(= field-type "boolean") (assoc :form-value/value_boolean value)
(= field-type "int") (assoc :form-value/value_long value)
(= field-type "select") (assoc :form-value/value_string value)
(= field-type "string") (assoc :form-value/value_string value)
(= field-type "time") (assoc :form-value/value_instant value))]
(db/transact [txn])
uuid-to-return))
(defn list-form-values
[config-map]
(let [kit-uuid (:uuid config-map)
query {:find '[?kit-uuid ?uuid ?field-id ?value ?type]
:keys '[kit-uuid uuid field-id value field-type]
:where '[[?kit :kit/uuid ?kit-uuid]
[?kit :kit/form-values ?form-value]
[?form-value :form-value/uuid ?uuid]
[?form-value :form-value/field ?field]
[?field :form-type-field/field-id ?field-id]
[?field :form-type-field/field-type ?field-type]
[?field-type :db/doc ?type]
[(get-some $ ?form-value
:form-value/value_string :form-value/value_long :form-value/value_float
:form-value/value_instant :form-value/value_boolean) [_attr ?value]]]}
query-fn (if-let [tx-id (:tx-id config-map)] (d/q-as-of tx-id) d/q-latest)
results (query-fn query)]
(cond-> results
kit-uuid (db/reducer-filter :kit-uuid kit-uuid))))

View File

@@ -0,0 +1,51 @@
(ns org.parkerici.sample-tracking.db.history
(:require [org.parkerici.sample-tracking.db.datomic :as d]
[org.parkerici.sample-tracking.db.core :as db])
(:import (java.util Date)))
(defn create-history
[agent-email entity-type entity-id old-value new-value]
(let [uuid (db/squuid)
txn {:history/uuid uuid
:history/agent-email agent-email
:history/entity-type entity-type
:history/entity-uuid entity-id
:history/old-value old-value
:history/new-value new-value
:history/time (Date.)}]
(db/transact [txn])
uuid))
; Pull version to use at some point. Didn't use before uuids because :as doesn't work with :db/id and returns
; each entity as it's own list for some reason.
;
;(defn list-history
; [id]
; (let [query {:find '[(pull ?history [[:db/id :as :id] [:history/agent-email :as :agent-email]
; [:history/entity-type :as :entity-type] [:history/entity-id :as :entity-id]
; [:history/old-value :as :old-value] [:history/new-value :as :new-value]
; [:history/time :as :time]])]
; :where '[[?history :history/entity-id ?entity-id]]}
; filtered-query (if (nil? id)
; query
; (assoc query :in '[$ ?entity-id]))]
; (apply d/q-latest (remove nil? [filtered-query id]))))
(defn list-history
[entity-uuid]
(let [query {:find '[?history-uuid ?agent-email ?entity-type ?entity-uuid ?old-value ?new-value ?time ?tx-inst]
:keys '[uuid agent-email entity-type entity-uuid old-value new-value time sort-time]
:where '[[?history :history/uuid ?history-uuid ?tx-eid]
[?history :history/agent-email ?agent-email]
[?history :history/entity-type ?entity-type]
[?history :history/entity-uuid ?entity-uuid]
[?history :history/old-value ?old-value]
[?history :history/new-value ?new-value]
[?history :history/time ?time]
[?tx-eid :db/txInstant ?tx-inst]]}
filtered-query (if (nil? entity-uuid)
query
(assoc query :in '[$ ?entity-uuid]))
results (apply d/q-latest (remove nil? [filtered-query entity-uuid]))
sorted-results (reverse (sort-by :sort-time results))]
(map #(dissoc % :sort-time) sorted-results)))

View File

@@ -0,0 +1,103 @@
(ns org.parkerici.sample-tracking.db.kit
(:require [org.parkerici.sample-tracking.db.datomic :as d]
[org.parkerici.sample-tracking.db.core :as db]
[java-time :as time]
[clojure.string :as str])
(:import (java.util UUID)))
(defn create-or-update-kit
[uuid kit-map]
(let [uuid-to-return (or uuid (db/squuid))
{:keys [kit-id participant-id collection-timestamp timezone
completing-first-name completing-last-name completing-email comments site cohort timepoints kit-type
complete submission-timestamp]} kit-map
txn (cond-> {:kit/kit-id kit-id
:kit/complete complete
:kit/submission-timestamp submission-timestamp
:kit/participant-id participant-id
:kit/timezone timezone
:kit/completing-first-name completing-first-name
:kit/completing-last-name completing-last-name
:kit/completing-email completing-email
:kit/comments comments
:kit/site [:site/uuid (UUID/fromString site)]
:kit/cohort [:cohort/uuid (UUID/fromString cohort)]
:kit/timepoints (map #(vector :timepoint/uuid (UUID/fromString %)) timepoints)
:kit/kit-type [:kit-type/uuid (UUID/fromString kit-type)]}
uuid (assoc :db/id [:kit/uuid uuid])
(nil? uuid) (assoc :kit/uuid uuid-to-return)
collection-timestamp (assoc :kit/collection-timestamp (time/java-date collection-timestamp)))]
(db/transact [txn])
uuid-to-return))
(defn add-sample-to-kit
[kit-uuid sample-uuid]
(d/transact [[:db/add [:kit/uuid kit-uuid] :kit/samples [:sample/uuid sample-uuid]]]))
(defn add-shipment-to-kit
[kit-uuid shipment-uuid]
(d/transact [[:db/add [:kit/uuid kit-uuid] :kit/shipments [:shipment/uuid shipment-uuid]]]))
(defn add-form-value-to-kit
[kit-uuid form-value-uuid]
(d/transact [[:db/add [:kit/uuid kit-uuid] :kit/form-values [:form-value/uuid form-value-uuid]]]))
(defn remove-timepoint-from-kit
[kit-uuid timepoint-uuid]
(d/transact [[:db/retract [:kit/uuid kit-uuid] :kit/timepoints [:timepoint/uuid timepoint-uuid]]]))
; TODO - Convert to a pull
(defn list-kits
[config-map]
(let [{:keys [uuid complete archived kit-id completing-email completing-email-domain]} config-map
query '[:find ?kit-uuid ?kit-id ?participant-id ?collection-timestamp ?timezone ?first-name ?last-name
?email ?comments ?kit-type-uuid ?kit-type-name ?site-uuid ?study-uuid ?cohort-uuid ?complete ?archived
:keys uuid kit-id participant-id collection-timestamp timezone completing-first-name completing-last-name
completing-email comments kit-type-uuid kit-type-name site-uuid study-uuid cohort-uuid complete archived
:where [?kit :kit/uuid ?kit-uuid]
[?kit :kit/kit-id ?kit-id]
[?kit :kit/complete ?complete]
[?kit :kit/timezone ?timezone]
[(get-else $ ?kit :kit/participant-id "") ?participant-id]
[(get-else $ ?kit :kit/collection-timestamp "") ?collection-timestamp]
[(get-else $ ?kit :kit/completing-first-name "") ?first-name]
[(get-else $ ?kit :kit/completing-last-name "") ?last-name]
[(get-else $ ?kit :kit/completing-email "") ?email]
[(get-else $ ?kit :kit/comments "") ?comments]
[(get-else $ ?kit :kit/archived false) ?archived]
[?kit :kit/kit-type ?kit-type]
[?kit-type :kit-type/uuid ?kit-type-uuid]
[?kit-type :kit-type/name ?kit-type-name]
[?kit :kit/site ?site]
[?site :site/uuid ?site-uuid]
[?kit :kit/cohort ?cohort]
[?cohort :cohort/uuid ?cohort-uuid]
[?cohort :cohort/study ?study]
[?study :study/uuid ?study-uuid]]
query-fn (if-let [tx-id (:tx-id config-map)] (d/q-as-of tx-id) d/q-latest)
results (query-fn query)]
(cond-> results
uuid (db/reducer-filter :uuid uuid)
(some? completing-email) (db/reducer-filter :completing-email completing-email)
(some? completing-email-domain) (db/reduce-fn-filter (fn [map] (str/ends-with? (:completing-email map) completing-email-domain)))
(some? kit-id) (db/reducer-filter :kit-id kit-id)
(some? complete) (db/reducer-filter :complete complete)
(some? archived) (db/reducer-filter :archived (boolean archived)))))
(defn get-kit
[config-map]
(first (list-kits config-map)))
(defn get-kit-vendor-email
[uuid]
(let [query '[:find ?vendor-email
:in $ ?kit-uuid
:where
[?kit :kit/uuid ?kit-uuid]
[?kit :kit/kit-type ?kit-type]
[?kit-type :kit-type/vendor-email ?vendor-email]]]
(ffirst (d/q-latest query uuid))))
(defn set-archived
[uuid archived]
(db/transact [{:db/id [:kit/uuid uuid] :kit/archived archived}]))

View File

@@ -0,0 +1,127 @@
(ns org.parkerici.sample-tracking.db.kit-type
(:require [org.parkerici.sample-tracking.db.datomic :as d]
[org.parkerici.sample-tracking.db.core :as db])
(:import (java.util Date)))
(defn create-kit-type
[name item-number vendor-email collection-date-required air-waybill-required]
(let [uuid (db/squuid)
txn {:kit-type/name name
:kit-type/item-number item-number
:kit-type/vendor-email vendor-email
:kit-type/collection-date-required collection-date-required
:kit-type/air-waybill-required air-waybill-required
:kit-type/uuid uuid
:kit-type/create-time (Date.)}]
(db/transact [txn])
uuid))
(defn find-active-kit-type-by-name-and-cohort
[kit-type-name cohort-uuid]
(first (d/q-latest '[:find ?kit-type-uuid
:keys uuid
:in $ ?kit-type-name ?cohort-uuid ?active
:where
[?cohort :cohort/uuid ?cohort-uuid]
[?cohort :cohort/kit-types ?kit-type-tuple]
[(untuple ?kit-type-tuple) [?kit-type ?active]]
[?kit-type :kit-type/name ?kit-type-name]
[?kit-type :kit-type/uuid ?kit-type-uuid]] kit-type-name cohort-uuid true)))
;TODO - Convert to pull
(defn find-kit-type-by-uuid
[uuid]
(first (d/q-latest '[:find ?name ?item-number ?create-time
:keys name item-number create-time
:in $ ?uuid
:where
[?kit-type :kit-type/uuid ?uuid]
[?kit-type :kit-type/name ?name]
[?kit-type :kit-type/item-number ?item-number]
[?kit-type :kit-type/create-time ?create-time]]
uuid)))
(defn add-timepoint-to-kit-type
[timepoint-uuid kit-type-uuid]
(d/transact [[:db/add [:kit-type/uuid kit-type-uuid] :kit-type/timepoints [:timepoint/uuid timepoint-uuid]]]))
(defn add-form-type-to-kit-type
[form-type-uuid kit-type-item-no]
(d/transact [{:db/id [:kit-type/item-number kit-type-item-no] :kit-type/form-type [:form-type/uuid form-type-uuid]}]))
(defn add-sample-type-to-kit-type
[sample-type-uuid kit-type-uuid]
(d/transact [[:db/add [:kit-type/uuid kit-type-uuid] :kit-type/sample-types [:sample-type/uuid sample-type-uuid]]]))
(defn kit-type-has-form-type
[kit-type-item-no]
(seq (d/q-latest '[:find ?form-type
:in $ ?item-number
:where
[?kit-type :kit-type/item-number ?item-number]
[?kit-type :kit-type/form-type ?form-type]]
kit-type-item-no)))
(defn get-kit-type-form-type
[kit-type-uuid]
(first (d/q-latest '[:find ?form-type-uuid ?form-type-name ?form-type-fields
:keys uuid name fields
:in $ ?kit-type-uuid
:where
[?kit-type :kit-type/uuid ?kit-type-uuid]
[?kit-type :kit-type/form-type ?form-type]
[?form-type :form-type/uuid ?form-type-uuid]
[?form-type :form-type/name ?form-type-name]
[?form-type :form-type/fields ?form-type-fields]]
kit-type-uuid)))
(defn list-kit-types
[cohort-uuid active]
(let [query {:find '[?kit-type-uuid ?kit-type-name ?item-number ?active ?create-time ?collection-date-required
?air-waybill-required]
:keys '[uuid name item-number active create-time collection-date-required air-waybill-required]
:where '[[?cohort :cohort/uuid ?cohort-uuid]
[?cohort :cohort/kit-types ?kit-type-tuple]
[(untuple ?kit-type-tuple) [?kit-type ?active]]
[?kit-type :kit-type/uuid ?kit-type-uuid]
[?kit-type :kit-type/timepoints ?timepoints]
[?kit-type :kit-type/name ?kit-type-name]
[?kit-type :kit-type/item-number ?item-number]
[(get-else $ ?kit-type :kit-type/form-type "") ?form-type]
[?kit-type :kit-type/create-time ?create-time]
[?kit-type :kit-type/collection-date-required ?collection-date-required]
[?kit-type :kit-type/air-waybill-required ?air-waybill-required]]}
filtered-query (if (nil? active)
(assoc query :in '[$ ?cohort-uuid])
(assoc query :in '[$ ?cohort-uuid ?active]))]
(apply d/q-latest (remove nil? [filtered-query cohort-uuid active]))))
(defn get-kit-type-name
[uuid]
(ffirst (d/q-latest '[:find ?kit-type-name
:in $ ?uuid
:where
[?kit-type :kit-type/uuid ?uuid]
[?kit-type :kit-type/name ?kit-type-name]]
uuid)))
(defn update-kit-type
[uuid name item-number collection-date-required air-waybill-required]
(d/transact [{:db/id [:kit-type/uuid uuid]
:kit-type/name name
:kit-type/item-number item-number
:kit-type/collection-date-required collection-date-required
:kit-type/air-waybill-required air-waybill-required}]))
(defn update-kit-type-active-status
[cohort-uuid kit-type-uuid status]
(let [current-tuple (first (d/q-latest '[:find ?kit-type ?active
:in $ ?kit-type-uuid ?cohort-uuid
:where
[?cohort :cohort/uuid ?cohort-uuid]
[?cohort :cohort/kit-types ?kit-type-tuple]
[(untuple ?kit-type-tuple) [?kit-type ?active]]
[?kit-type :kit-type/uuid ?kit-type-uuid]]
kit-type-uuid cohort-uuid))]
(when (some? current-tuple) (d/transact [[:db/retract [:cohort/uuid cohort-uuid] :cohort/kit-types current-tuple]]))
(d/transact [[:db/add [:cohort/uuid cohort-uuid] :cohort/kit-types [[:kit-type/uuid kit-type-uuid] status]]])))

View File

@@ -0,0 +1,20 @@
(ns org.parkerici.sample-tracking.db.migration
(:require [org.parkerici.sample-tracking.db.datomic :as d]
[org.parkerici.sample-tracking.db.core :as db])
(:import (java.util Date)))
(defn create-migration
[name]
(let [uuid (db/squuid)]
(db/transact [{:migration/uuid uuid :migration/name name :migration/time (Date.)}])
uuid))
(defn migration-has-been-run
[name]
(let [migrations (d/q-latest '[:find ?uuid
:in $ ?migration-name
:where
[?migration :migration/name ?migration-name]
[?migration :migration/uuid ?uuid]]
name)]
(not= (count migrations) 0)))

View File

@@ -0,0 +1,22 @@
(ns org.parkerici.sample-tracking.db.migration.air-waybill-required
(:require [org.parkerici.sample-tracking.db.datomic :as d]
[org.parkerici.sample-tracking.db.core :as db]))
(defn list-kit-types-without-air-waybill-required
[]
(d/q-latest {:find '[?uuid]
:keys '[uuid]
:where '[[?kit-type :kit-type/uuid ?uuid]
[(missing? $ ?kit-type :kit-type/air-waybill-required)]]}))
(defn list-kit-types-air-waybill
[]
(d/q-latest {:find '[?uuid ?air-waybill]
:keys '[uuid air-waybill]
:where '[[?kit-type :kit-type/uuid ?uuid]
[?kit-type :kit-type/air-waybill-required ?air-waybill]]}))
(defn set-kit-type-air-waybill-required
[uuid required]
(db/transact [{:db/id [:kit-type/uuid uuid] :kit-type/air-waybill-required required}]))

View File

@@ -0,0 +1,70 @@
(ns org.parkerici.sample-tracking.db.proposed-kit-edit
(:require [org.parkerici.sample-tracking.db.datomic :as d]
[org.parkerici.sample-tracking.db.core :as db]
[clojure.string :as str])
(:import (java.util Date)))
(defn create-or-update-proposed-edit
"kit-uuid must be parsed uuid and not a string"
[edit-uuid kit-uuid kit-map email]
(let [uuid (or edit-uuid (db/squuid))
txn {:proposed-kit-edit/uuid uuid
:proposed-kit-edit/kit [:kit/uuid kit-uuid]
:proposed-kit-edit/update-map kit-map
:proposed-kit-edit/status :kit-edit-status/pending
:proposed-kit-edit/user [:user/email email]
:proposed-kit-edit/time (Date.)}]
(db/transact [txn])
uuid))
(defn list-proposed-edits
[config-map]
(let [{:keys [uuid kit-uuid status]} config-map
query {:find '[?uuid ?kit-uuid ?kit-id ?update-map ?status ?email ?time ?participant-id ?collection-timestamp
?kit-email ?kit-type-name]
:keys '[uuid kit-uuid kit-id update-map status email time participant-id collection-timestamp
kit-email kit-type-name]
:where '[[?proposed-edit :proposed-kit-edit/uuid ?uuid]
[?proposed-edit :proposed-kit-edit/kit ?kit]
[?kit :kit/uuid ?kit-uuid]
[?kit :kit/kit-id ?kit-id]
[(get-else $ ?kit :kit/participant-id "") ?participant-id]
[(get-else $ ?kit :kit/collection-timestamp "") ?collection-timestamp]
[(get-else $ ?kit :kit/completing-email "") ?kit-email]
[?kit :kit/kit-type ?kit-type]
[?kit-type :kit-type/name ?kit-type-name]
[?proposed-edit :proposed-kit-edit/update-map ?update-map]
[?proposed-edit :proposed-kit-edit/status ?status-enum]
[?status-enum :db/doc ?status]
[?proposed-edit :proposed-kit-edit/user ?user]
[?user :user/email ?email]
[?proposed-edit :proposed-kit-edit/time ?time]]}
results (apply d/q-latest [query])]
(cond-> results
(some? uuid) (db/reducer-filter :uuid uuid)
(some? kit-uuid) (db/reducer-filter :kit-uuid kit-uuid)
(not (str/blank? status)) (db/reducer-filter :status status))))
(defn get-proposed-edit-tx-id
[uuid]
(ffirst (d/q-latest '[:find ?tx
:in $ ?uuid
:where
[?form-type :proposed-kit-edit/uuid ?uuid ?tx ?op]]
uuid)))
(defn update-proposed-edit-status
[uuid reviewing-email status]
(let [txn {:proposed-kit-edit/uuid uuid
:proposed-kit-edit/status status
:proposed-kit-edit/reviewing-user [:user/email reviewing-email]}]
(db/transact [txn])
uuid))
(defn approve-proposed-edit
[uuid reviewing-email]
(update-proposed-edit-status uuid reviewing-email :kit-edit-status/approved))
(defn deny-proposed-edit
[uuid reviewing-email]
(update-proposed-edit-status uuid reviewing-email :kit-edit-status/denied))

View File

@@ -0,0 +1,24 @@
(ns org.parkerici.sample-tracking.db.role
(:require [org.parkerici.sample-tracking.db.datomic :as d]
[org.parkerici.sample-tracking.db.core :as db]))
(defn create-role
[name]
(let [uuid (db/squuid)]
(db/transact [{:role/name name :role/uuid uuid}])
uuid))
(defn find-role-uuid
[name]
(ffirst (d/q-latest '[:find ?uuid
:in $ ?name
:where
[?role :role/name ?name]
[?role :role/uuid ?uuid]]
name)))
(defn list-roles
[]
(map first (d/q-latest '[:find (pull ?role [[:role/uuid :as :uuid]
[:role/name :as :name]])
:where [?role :role/uuid]])))

View File

@@ -0,0 +1,102 @@
(ns org.parkerici.sample-tracking.db.sample
(:require [org.parkerici.sample-tracking.db.datomic :as d]
[org.parkerici.sample-tracking.db.core :as db])
(:import (java.util UUID)))
(defn create-or-update-sample
[uuid sample-type-uuid sample-id collected shipped]
(let [uuid-to-return (or uuid (db/squuid))
txn (cond-> {:sample/sample-type [:sample-type/uuid (UUID/fromString sample-type-uuid)]
:sample/sample-id sample-id
:sample/collected collected
:sample/shipped shipped}
uuid (assoc :db/id [:sample/uuid uuid])
(nil? uuid) (assoc :sample/uuid uuid-to-return))]
(db/transact [txn])
uuid-to-return))
(defn add-sample-to-shipment
[shipment-uuid sample-uuid]
(d/transact [{:db/id [:sample/uuid sample-uuid] :sample/shipment [:shipment/uuid shipment-uuid]}]))
(defn remove-sample-from-shipment
[shipment-uuid sample-uuid]
(d/transact [[:db/retract [:sample/uuid sample-uuid] :sample/shipment [:shipment/uuid shipment-uuid]]]))
(defn list-shipment-samples
[shipment-uuid]
(flatten (d/q-latest '[:find ?sample-uuid
:in $ ?shipment-uuid
:where
[?sample :sample/uuid ?sample-uuid]
[?sample :sample/shipment ?shipment]
[?shipment :shipment/uuid ?shipment-uuid]] shipment-uuid)))
(defn list-samples
[config-map]
(let [kit-uuid (:uuid config-map)
query {:find '[?kit-uuid ?sample-uuid ?sample-id ?sample-type-uuid ?collected ?shipped]
:keys '[kit-uuid uuid sample-id sample-type-uuid collected shipped]
:where '[[?kit :kit/uuid ?kit-uuid]
[?kit :kit/samples ?sample]
[?sample :sample/uuid ?sample-uuid]
[?sample :sample/sample-type ?sample-type]
[?sample :sample/sample-id ?sample-id]
[(get-else $ ?sample :sample/collected false) ?collected]
[(get-else $ ?sample :sample/shipped false) ?shipped]
[?sample-type :sample-type/uuid ?sample-type-uuid]]}
query-fn (if-let [tx-id (:tx-id config-map)] (d/q-as-of tx-id) d/q-latest)
results (query-fn query)]
(cond-> results
kit-uuid (db/reducer-filter :kit-uuid kit-uuid))))
; TODO - Convert to a pull
(defn list-samples-for-export
([config-map]
(let [{:keys [uuid complete shipped archived]} config-map
query '[:find ?site-name ?study-name ?cohort-name ?kit-type-name ?kit-type-uuid ?kit-type-item-number ?kit-uuid
?kit-id ?participant-id ?collection-timestamp ?completing-first-name ?completing-last-name
?completing-email ?kit-comments ?sample-type-name ?sample-type-uuid ?sample-id ?collected ?shipped
?air-waybill ?complete ?timezone ?archived
:keys site-name study-name cohort-name kit-type-name kit-type-uuid kit-type-item-number kit-uuid kit-id
participant-id collection-timestamp completing-first-name completing-last-name completing-email
kit-comments sample-type-name sample-type-uuid sample-id collected shipped air-waybill complete
timezone archived
:where [?kit :kit/kit-id ?kit-id]
[?kit :kit/complete ?complete]
[?kit :kit/timezone ?timezone]
[(get-else $ ?kit :kit/participant-id "") ?participant-id]
[(get-else $ ?kit :kit/collection-timestamp "") ?collection-timestamp]
[(get-else $ ?kit :kit/completing-first-name "") ?completing-first-name]
[(get-else $ ?kit :kit/completing-last-name "") ?completing-last-name]
[(get-else $ ?kit :kit/completing-email "") ?completing-email]
[(get-else $ ?kit :kit/comments "") ?kit-comments]
[(get-else $ ?kit :kit/archived false) ?archived]
[?kit :kit/uuid ?kit-uuid]
[?kit :kit/kit-type ?kit-type]
[?kit-type :kit-type/uuid ?kit-type-uuid]
[?kit-type :kit-type/name ?kit-type-name]
[?kit-type :kit-type/item-number ?kit-type-item-number]
[?kit :kit/site ?site]
[?site :site/name ?site-name]
[?study :study/name ?study-name]
[?kit :kit/cohort ?cohort]
[?cohort :cohort/name ?cohort-name]
[?cohort :cohort/study ?study]
[?kit :kit/samples ?sample]
[?sample :sample/sample-type ?sample-type]
[?sample-type :sample-type/name ?sample-type-name]
[?sample-type :sample-type/uuid ?sample-type-uuid]
[?sample :sample/sample-id ?sample-id]
[(get-else $ ?sample :sample/collected false) ?collected]
[(get-else $ ?sample :sample/shipped false) ?shipped]
[(get-else $ ?sample :sample/shipment -1) ?shipment]
[(get-else $ ?shipment :shipment/air-waybill "") ?air-waybill]]
results (d/q-latest query)]
(cond-> results
uuid (db/reducer-filter :kit-uuid uuid)
(some? complete) (db/reducer-filter :complete complete)
(some? shipped) (db/reducer-filter :shipped shipped)
(some? archived) (db/reducer-filter :archived (boolean archived)))))
([]
(list-samples-for-export {})))

View File

@@ -0,0 +1,60 @@
(ns org.parkerici.sample-tracking.db.sample-attribute
(:require [org.parkerici.sample-tracking.db.datomic :as d]
[org.parkerici.sample-tracking.db.core :as db]))
(defn create-sample-attribute
[name]
(let [uuid (db/squuid)]
(db/transact [{:sample-attribute/uuid uuid
:sample-attribute/name name}])
uuid))
; There should only be one sample-attribute with a given name.
; Returns the uuid of the attribute with the passed in name if it exists.
(defn find-sample-attribute
[name]
(ffirst (d/q-latest '[:find ?uuid
:in $ ?attribute-name
:where
[?sample-attribute :sample-attribute/uuid ?uuid]
[?sample-attribute :sample-attribute/name ?attribute-name]]
name)))
(defn create-sample-attribute-value
[name attribute-uuid]
(let [uuid (db/squuid)]
(db/transact [{:sample-attribute-value/uuid uuid
:sample-attribute-value/name name
:sample-attribute-value/attribute [:sample-attribute/uuid attribute-uuid]}])
uuid))
; There should only be one attribute-value with a given name and attribute.
; Returns the uuid of the attribute-value with the passed in name and attribute if it exists.
(defn find-sample-attribute-value
[name attribute-uuid]
(ffirst (d/q-latest '[:find ?sample-attribute-value-uuid
:in $ ?value-name ?attribute-uuid
:where
[?sample-attribute-value :sample-attribute-value/uuid ?sample-attribute-value-uuid]
[?sample-attribute-value :sample-attribute-value/name ?value-name]
[?sample-attribute-value :sample-attribute-value/attribute ?attribute]
[?attribute :sample-attribute/uuid ?attribute-uuid]]
name attribute-uuid)))
(defn list-sample-attributes-and-values-for-export
([config-map]
(let [kit-uuid (:uuid config-map)
query {:find '[?sample-id ?sample-attribute-name ?attribute-value-name]
:keys '[sample-id attribute value]
:where '[[?kit :kit/uuid ?kit-uuid]
[?kit :kit/kit-id ?kit-id]
[?kit :kit/samples ?sample]
[?sample :sample/sample-id ?sample-id]
[?sample :sample/sample-type ?sample-type]
[?sample-type :sample-type/attribute-values ?attribute-value]
[?attribute-value :sample-attribute-value/name ?attribute-value-name]
[?attribute-value :sample-attribute-value/attribute ?sample-attribute]
[?sample-attribute :sample-attribute/name ?sample-attribute-name]]}
results (d/q-latest query)]
(cond-> results
kit-uuid (db/reducer-filter :kit-uuid kit-uuid)))))

View File

@@ -0,0 +1,54 @@
(ns org.parkerici.sample-tracking.db.sample-type
(:require [org.parkerici.sample-tracking.db.datomic :as d]
[org.parkerici.sample-tracking.db.core :as db]))
(defn create-sample-type
[name id-suffix ships-with-kit reminder]
(let [uuid (db/squuid)
txn {:sample-type/name name
:sample-type/uuid uuid
:sample-type/id-suffix id-suffix
:sample-type/ships-with-kit ships-with-kit
:sample-type/reminder reminder}]
(db/transact [txn])
uuid))
(defn find-sample-type-by-uuid
[uuid]
(first (d/q-latest '[:find ?name ?id-suffix ?ships-with-kit ?reminder
:keys name id-suffix ships-with-kit reminder
:in $ ?uuid
:where
[?sample-type :sample-type/uuid ?uuid]
[?sample-type :sample-type/name ?name]
[?sample-type :sample-type/id-suffix ?id-suffix]
[?sample-type :sample-type/ships-with-kit ?ships-with-kit]
[?sample-type :sample-type/reminder ?reminder]]
uuid)))
(defn add-attribute-value-to-sample-type
[sample-type-uuid value-uuid]
(d/transact [[:db/add [:sample-type/uuid sample-type-uuid] :sample-type/attribute-values [:sample-attribute-value/uuid value-uuid]]]))
(defn list-sample-types
[kit-type-uuid]
(let [results (d/q-latest '[:find ?sample-type-uuid ?sample-type-name ?id-suffix ?ships-with-kit ?reminder ?kit-type-uuid
:keys uuid name id-suffix ships-with-kit reminder kit-type-uuid
:where
[?kit-type :kit-type/uuid ?kit-type-uuid]
[?kit-type :kit-type/sample-types ?sample-type]
[?sample-type :sample-type/name ?sample-type-name]
[?sample-type :sample-type/uuid ?sample-type-uuid]
[?sample-type :sample-type/id-suffix ?id-suffix]
[?sample-type :sample-type/ships-with-kit ?ships-with-kit]
[?sample-type :sample-type/reminder ?reminder]])]
(cond-> results
kit-type-uuid (db/reducer-filter :kit-type-uuid kit-type-uuid))))
(defn update-sample-type
[uuid name id-suffix ships-with-kit reminder]
(d/transact [{:db/id [:sample-type/uuid uuid]
:sample-type/name name
:sample-type/id-suffix id-suffix
:sample-type/ships-with-kit ships-with-kit
:sample-type/reminder reminder}]))

View File

@@ -0,0 +1,426 @@
(ns org.parkerici.sample-tracking.db.schema
(:require [org.parkerici.multitool.cljcore :as u]
[org.parkerici.sample-tracking.db.datomic :as d]
[org.parkerici.alzabo.schema :as schema]
[org.parkerici.alzabo.datomic :as datomic]))
;;; NOTE: whenever this changes, run the function (transact-schema) to update all databases.
;;; Also note that some schema changes are outlawed by Datomic, so verify it works.
;;; This uses the schema format from Alzabo: https://github.com/ParkerICI/alzabo/blob/master/src/alzabo/schema.clj
(def schema
{:kinds
{:study
{:fields {:uuid {:type :uuid
:unique-id true
:required true
:doc "The UUID for the entity"}
:name {:type :string
:unique-id true
:required true
:doc "The name of the study (e.g. PICI0002)."}
:active {:type :boolean
:required true
:doc "If this entity is active and should be displayed to users"}
:create-time {:type :instant
:required true
:doc "The time this entity was created"}
:participant-id-prefix {:type :string
:doc "An initial prefix for this study's participant-ids"}
:participant-id-regex {:type :string
:doc "A regex for validating participant-ids"}
:participant-id-validation-message {:type :string
:doc "A message to display for invalid participant-ids"}
:kit-id-prefix {:type :string
:doc "An initial prefix for this study's kit-ids"}
:kit-id-regex {:type :string
:doc "A regex for validating kit-ids"}
:kit-id-validation-message {:type :string
:doc "A message to display for invalid kit-ids"}
:cohorts {:type [:cohort :boolean]
:cardinality :many
:doc "The cohorts of participants in the study and their active statuses."}
:sites {:type [:site :boolean]
:cardinality :many
:doc "The sites a study is running at and their active statuses."}}}
:site
{:fields {:uuid {:type :uuid
:unique-id true
:required true
:doc "The UUID for the entity"}
:name {:type :string
:required true
:unique-id true
:doc "The name of a site"}
:create-time {:type :instant
:required true
:doc "The time this entity was created"}}}
:cohort
{:fields {:uuid {:type :uuid
:unique-id true
:required true
:doc "The UUID for the entity"}
:name {:type :string
:required true
:doc "The name of a cohort of participants (e.g. Default or Cohort B)."}
:study {:type :study
:required true
:doc "The study this cohort belongs to"}
:create-time {:type :instant
:required true
:doc "The time this entity was created"}
:kit-types {:type [:kit-type :boolean]
:cardinality :many
:doc "The types of kits that may be used for a cohort and their active statues."}}}
:kit-type
{:fields {:uuid {:type :uuid
:unique-id true
:required true
:doc "The UUID for the entity"}
:name {:type :string
:required true
:doc "The name of a kit type (e.g. Blood Collection Kit)."}
:create-time {:type :instant
:required true
:doc "The time this entity was created"}
:collection-date-required {:type :boolean
:required true
:doc "Whether or not collection timestamp is required for this kit"}
:air-waybill-required {:type :boolean
:required true
:doc "Whether or not air waybill is required for this kit"}
:vendor-email {:type :string
:doc "The email address for the vendor this kit belongs to."}
:item-number {:type :long
:required true
:unique-id true
:doc "The external ID for a kit-type. Used as a unique ID and to join with Therapak."}
:sample-types {:type :sample-type
:component true
:cardinality :many
:doc "A kit usually has multiple samples collected for it. These are the types of samples that can be collected for this type of kit."}
:timepoints {:type :timepoint
:component true
:cardinality :many
:doc "The timepoints this kit can be used for (e.g. Cycle 1 Day 1)"}
:form-type {:type :form-type
:component true
:cardinality :one
:doc "Form-type stores custom form field definitions that need to be collected for a kit. Depending on how the kit is being used, a different form might need to be filled out."}}}
:timepoint
{:fields {:uuid {:type :uuid
:unique-id true
:required true
:doc "The UUID for the entity"}
:name {:type :string
:unique-id true
:required true
:doc "The name of the timepoint (e.g. Cycle 2 Day 3)."}}}
:sample-type
{:fields {:uuid {:type :uuid
:unique-id true
:required true
:doc "The UUID for the entity"}
:name {:type :string
:required true
:doc "The name of a sample type (e.g. Red Cap Serum)"}
:id-suffix {:type :string
:required true
:doc "A sample has a two part ID. The first part is the kit id that it belongs two, and the second part is this generic id-suffix."}
:ships-with-kit {:type :boolean
:required true
:doc "If true, this sample is shipped out immediately by the site once the kit has been used. If false, the sample is kept by the site and might ship at a later date."}
:reminder {:type :string
:doc "A reminder about the sample to be displayed to the user. E.g. Please place tube only in Primary Bag or Cryobox"}
:attribute-values {:type :sample-attribute-value
:component true
:cardinality :many
:doc "Attributes for a sample (e.g. primary vs backup)"}}}
:sample-attribute
{:fields {:uuid {:type :uuid
:unique-id true
:required true
:doc "The UUID for the entity"}
:name {:type :string
:required true?
:doc "The name of a sample attribute"}}}
:sample-attribute-value
{:fields {:uuid {:type :uuid
:unique-id true
:required true
:doc "The UUID for the entity"}
:name {:type :string
:required true?
:doc "The name of a sample attribute value"}
:attribute {:type :sample-attribute
:cardinality :one
:required true
:doc "The attribute this value belongs to"}}}
:form-type
{:fields {:uuid {:type :uuid
:unique-id true
:required true
:doc "The UUID for the entity"}
:name {:type :string
:required true
:unique-id true
:doc "The name of a form. Different sample types can share the same form"}
:fields {:type :form-type-field
:cardinality :many
:component true
:required true
:doc "The fields that belong to this form-type"}}}
:form-type-field
{:fields {:uuid {:type :uuid
:unique-id true
:required true
:doc "The UUID for the entity"}
:field-id {:type :string
:required true
:doc "The id used for this field on forms"}
:field-type {:type :form-type-field-type
:component true
:required true
:doc "The type of field this is (e.g. boolean, int, time, string, select)"}
:required {:type :boolean
:required true
:doc "Whether or not this field is required"}
:label {:type :string
:required true
:doc "The label for this field"}
:options {:type [:string :string]
:cardinality :many
:doc "If this field is a select field, tuples of (id, value) for the select field"}}}
:kit
{:fields {:uuid {:type :uuid
:unique-id true
:required true
:doc "The UUID for the entity"}
:kit-id {:type :string
:required true
:doc "The string identifier for this kit."}
:participant-id {:type :string
:doc "The ID of the participant that this kit is being used to collect samples from."}
:collection-timestamp {:type :instant
:doc "A timestamp for when this kit was collected. Defined by the person entering data into the form."}
:timezone {:type :string
:required true
:doc "The timezone for proper rendering of the timestamps that belong to this kit (e.g. America/Los_Angeles)"}
:completing-first-name {:type :string
:doc "The first name of the person completing this kit."}
:completing-last-name {:type :string
:doc "The last name of the person completing this kit."}
:completing-email {:type :string
:doc "The email address of the person completing this kit."}
:comments {:type :string
:doc "Comments about the kit."}
:complete {:type :boolean
:required true
:doc "Whether or not this kit has been completed and submitted by the site."}
:site {:type :site
:cardinality :one
:required true
:doc "The site this kit was collected for."}
:cohort {:type :cohort
:cardinality :one
:required true
:doc "The cohort this kit was collected for."}
:timepoints {:type :timepoint
:cardinality :many
:required true
:doc "The timepoint this kit was collected for."}
:kit-type {:type :kit-type
:cardinality :one
:required true
:doc "The kit-type that this kit is an instance of."}
:samples {:type :sample
:component true
:cardinality :many
:doc "The samples that were collected for this kit."}
; We can get a kit's shipments through samples, but also keep an explicit reference so that we don't lose
; shipments associated with kits that don't have samples marked as shipped (can happen during the kit
; sharing process or possibly if a user accidentally doesn't mark any samples in a kit as shipped).
; Feels a little hacky, but best solution I have for now.
; Maybe disable air waybill field unless a sample is marked as shipped, but could be confusing for users?
:shipments {:type :shipment
:cardinality :many
:required false
:doc "Any shipments associated with this kit"}
:form-values {:type :form-value
:component true
:cardinality :many
:doc "The values for the custom form fields defined in form-type collected for this kit."}
:submission-timestamp {:type :instant
:doc "A timestamp for when this kit was submitted."}
:archived {:type :boolean
:doc "If this kit has been archived"}}}
:sample
{:fields {:uuid {:type :uuid
:unique-id true
:required true
:doc "The UUID for the entity"}
:sample-id {:type :string
:required :true
:doc "The barcoded ID on this sample"}
:collected {:type :boolean
:doc "If this sample was collected"}
:shipped {:type :boolean
:doc "If this sample was shipped"}
:sample-type {:type :sample-type
:cardinality :one
:required true
:doc "The sample-type that this sample is an instance of."}
:shipment {:type :shipment
:cardinality :one
:required false
:doc "The shipment that this sample was shipped in"}}}
:form-value
{:fields {:uuid {:type :uuid
:unique-id true
:required true
:doc "The UUID for the entity"}
:field {:type :form-type-field
:cardinality :one
:required true
:doc "The form-type-field that this value belongs to"}
:value_string {:type :string
:doc "If this field is a string, then value will be stored here."}
:value_long {:type :long
:doc "If this field is a long, then value will be stored here."}
:value_float {:type :float
:doc "If this field is a float, then value will be stored here."}
:value_instant {:type :instant
:doc "If this field is an instant (time), then value will be stored here."}
:value_boolean {:type :boolean
:doc "If this field is a boolean, then value will be stored here."}}}
:shipment
{:fields {:uuid {:type :uuid
:unique-id true
:required true
:doc "The UUID for the entity"}
:air-waybill {:type :string
:required true}
:archived {:type :boolean
:doc "If this shipment has been archived"}}}
:proposed-kit-edit
{:fields {:uuid {:type :uuid
:unique-id true
:required true
:doc "The UUID for the entity"}
:kit {:type :kit
:cardinality :one
:required true
:doc "The kit that this is proposing to edit"}
:update-map {:type :string
:required true
:doc "A stringified kit map that can be used to update the kit via the kit-shipment api"}
:status {:type :kit-edit-status
:component true
:required true
:doc "The status of this edit (e.g. pending, approved, or denied)"}
:user {:type :user
:cardinality :one
:required true
:doc "The user proposing the edit."}
:time {:type :instant
:required true
:doc "The time this edit was proposed."}
:reviewing-user {:type :user
:cardinality :one
:doc "The user proposing the edit."}}}
:role
{:fields {:uuid {:type :uuid
:unique-id true
:required true
:doc "The UUID for the entity"}
:name {:type :string
:unique-id true
:required true}}}
:user
{:fields {:uuid {:type :uuid
:unique-id true
:required true
:doc "The UUID for the entity"}
:email {:type :string
:unique-id true
:required true}
:deactivated {:type :boolean}
:roles {:type :role
:cardinality :many
:required true
:doc "The roles that this user belongs to"}}}
:history
{:fields {:uuid {:type :uuid
:unique-id true
:required true
:doc "The UUID for the entity"}
:agent-email {:type :string
:required true
:doc "The email address of the agent making the change"}
:time {:type :instant
:required true
:doc "The time this change was made"}
:entity-type {:type :keyword
:required true
:doc "The type of entity being changed"}
:entity-uuid {:type :uuid
:required true
:doc "The id of the database entity being changed"}
:old-value {:type :string
:required true
:doc "The old value of the entity being changed"}
:new-value {:type :string
:doc "The new value of the entity being changed. Can be blank in the case of deletion"}}}
:migration
{:fields {:uuid {:type :uuid
:unique-id true
:required true
:doc "The UUID for the entity"}
:name {:type :string
:unique-id true
:require true
:doc "The name of the migration"}
:time {:type :instant
:require true
:doc "The time the migration was made"}}}}
:enums {
:form-type-field-type
{:values #:form-type-field-type{:boolean "boolean"
:int "int"
:time "time"
:select "select"
:string "string"}}
:kit-edit-status
{:values #:kit-edit-status{:pending "pending"
:approved "approved"
:denied "denied"}}}})
(defn write-schema-file
[datomic-schema]
(u/schpit "resources/schema.edn" datomic-schema))
(defn transact-schema
[]
(let [datomic-schema (datomic/datomic-schema (schema/validate-schema schema))]
(write-schema-file datomic-schema)
(d/wrap-datomic-fn #(d/transact datomic-schema))))

View File

@@ -0,0 +1,31 @@
(ns org.parkerici.sample-tracking.db.shipment
(:require [org.parkerici.sample-tracking.db.datomic :as d]
[org.parkerici.sample-tracking.db.core :as db]))
(defn create-or-update-shipment
[uuid air-waybill]
(let [uuid-to-return (or uuid (db/squuid))
txn (cond-> {:shipment/air-waybill air-waybill}
uuid (assoc :db/id [:shipment/uuid uuid])
(nil? uuid) (assoc :shipment/uuid uuid-to-return))]
(db/transact [txn])
uuid-to-return))
; Gets the shipments explicitly associated with a kit
(defn list-shipments
[config-map]
(let [kit-uuid (:uuid config-map)
query {:find '[?shipment-uuid ?air-waybill ?kit-uuid]
:keys '[uuid air-waybill kit-uuid]
:where '[[?kit :kit/uuid ?kit-uuid]
[?kit :kit/shipments ?shipment]
[?shipment :shipment/uuid ?shipment-uuid]
[?shipment :shipment/air-waybill ?air-waybill]]}
query-fn (if-let [tx-id (:tx-id config-map)] (d/q-as-of tx-id) d/q-latest)
results (query-fn query)]
(cond-> results
kit-uuid (db/reducer-filter :kit-uuid kit-uuid))))
(defn set-archived
[uuid archived]
(db/transact [{:db/id [:shipment/uuid uuid] :shipment/archived archived}]))

View File

@@ -0,0 +1,82 @@
(ns org.parkerici.sample-tracking.db.site
(:require [org.parkerici.sample-tracking.db.datomic :as d]
[org.parkerici.sample-tracking.db.core :as db])
(:import (java.util Date)))
(defn create-site
[name]
(let [uuid (db/squuid)
txn {:site/name name :site/uuid uuid :site/create-time (Date.)}]
(db/transact [txn])
uuid))
(defn find-site-by-name
[name]
(first (d/q-latest '[:find ?site-uuid ?create-time
:keys uuid create-time
:in $ ?site-name
:where
[?site :site/uuid ?site-uuid]
[?site :site/name ?site-name]
[?site :site/create-time ?create-time]]
name)))
(defn find-site-by-uuid
[uuid]
(first (d/q-latest '[:find ?site-name ?create-time
:keys name create-time
:in $ ?uuid
:where
[?site :site/uuid ?uuid]
[?site :site/name ?site-name]
[?site :site/create-time ?create-time]]
uuid)))
(defn list-sites
[study-uuid active]
(let [query {:find '[?site-uuid ?site-name ?active ?create-time]
:keys '[uuid name active create-time]
:where '[[?study :study/uuid ?study-uuid]
[?study :study/sites ?site-tuple]
[(untuple ?site-tuple) [?site ?active]]
[?site :site/name ?site-name]
[?site :site/uuid ?site-uuid]
[?site :site/create-time ?create-time]]}
filtered-query (if (nil? active)
(assoc query :in '[$ ?study-uuid])
(assoc query :in '[$ ?study-uuid ?active]))]
(apply d/q-latest (remove nil? [filtered-query study-uuid active]))))
(defn list-study-tuples
[]
(let [query {:find '[?study-uuid ?site-tuple]
:keys '[uuid tuple]
:where '[[?study :study/uuid ?study-uuid]
[?study :study/sites ?site-tuple]]}]
(apply d/q-latest (remove nil? [query]))))
(defn list-all-sites
[]
(let [query {:find '[?site ?site-uuid ?site-name]
:keys '[id uuid name]
:where '[[?site :site/uuid ?site-uuid]
[?site :site/name ?site-name]]}]
(apply d/q-latest (remove nil? [query]))))
(defn update-site
[uuid name]
(d/transact [{:db/id [:site/uuid uuid]
:site/name name}]))
(defn update-site-active-status
[study-uuid site-uuid status]
(let [current-tuple (first (d/q-latest '[:find ?site ?active
:in $ ?site-uuid ?study-uuid
:where
[?study :study/uuid ?study-uuid]
[?study :study/sites ?site-tuple]
[(untuple ?site-tuple) [?site ?active]]
[?site :site/uuid ?site-uuid]]
site-uuid study-uuid))]
(when (some? current-tuple) (d/transact [[:db/retract [:study/uuid study-uuid] :study/sites current-tuple]]))
(d/transact [[:db/add [:study/uuid study-uuid] :study/sites [[:site/uuid site-uuid] status]]])))

View File

@@ -0,0 +1,110 @@
(ns org.parkerici.sample-tracking.db.study
(:require [org.parkerici.sample-tracking.db.core :as db]
[org.parkerici.sample-tracking.db.datomic :as d])
(:import (java.util Date)))
(defn create-study
[name]
(let [uuid (db/squuid)
txn {:study/name name :study/uuid uuid :study/active true :study/create-time (Date.)}]
(db/transact [txn])
uuid))
(defn find-study-by-name
[name]
(first (d/q-latest '[:find ?study-uuid ?active ?create-time
:keys uuid active create-time
:in $ ?study-name
:where
[?study :study/uuid ?study-uuid]
[?study :study/name ?study-name]
[?study :study/active ?active]
[?study :study/create-time ?create-time]]
name)))
(defn find-study-by-uuid
[uuid]
(first (d/q-latest '[:find ?study-name ?active ?create-time
:keys name active create-time
:in $ ?uuid
:where
[?study :study/uuid ?uuid]
[?study :study/name ?study-name]
[?study :study/active ?active]
[?study :study/create-time ?create-time]]
uuid)))
(defn add-site-to-study
[site-uuid study-name]
(d/transact [[:db/add [:study/name study-name] :study/sites [[:site/uuid site-uuid] true]]]))
(defn site-is-associated-with-study
[site-uuid study-name]
(seq (d/q-latest '[:find ?study
:in $ ?site-uuid ?study-name
:where
[?study :study/name ?study-name]
[?study :study/sites ?site-tuple]
[(untuple ?site-tuple) [?site ?active]]
[?site :site/uuid ?site-uuid]]
site-uuid study-name)))
(defn add-cohort-to-study
[study-uuid cohort-uuid]
(d/transact [[:db/add [:study/uuid study-uuid] :study/cohorts [[:cohort/uuid cohort-uuid] true]]]))
(defn add-participant-id-validation-to-study
[study-name prefix regex message]
(d/transact [{:db/id [:study/name study-name]
:study/participant-id-prefix prefix
:study/participant-id-regex regex
:study/participant-id-validation-message message}]))
(defn add-kit-id-validation-to-study
[study-name prefix regex message]
(d/transact [{:db/id [:study/name study-name]
:study/kit-id-prefix prefix
:study/kit-id-regex regex
:study/kit-id-validation-message message}]))
(defn list-studies
[active]
(let [query {:find '[?uuid ?study-name ?active ?create-time ?participant-id-prefix ?participant-id-regex
?participant-id-validation-message ?kit-id-prefix ?kit-id-regex ?kit-id-validation-message]
:keys '[uuid name active create-time participant-id-prefix participant-id-regex
participant-id-validation-message kit-id-prefix kit-id-regex kit-id-validation-message]
:where '[[?study :study/name ?study-name]
[?study :study/active ?active]
[?study :study/create-time ?create-time]
[?study :study/uuid ?uuid]
[(get-else $ ?study :study/participant-id-prefix "") ?participant-id-prefix]
[(get-else $ ?study :study/participant-id-regex "") ?participant-id-regex]
[(get-else $ ?study :study/participant-id-validation-message "") ?participant-id-validation-message]
[(get-else $ ?study :study/kit-id-prefix "") ?kit-id-prefix]
[(get-else $ ?study :study/kit-id-regex "") ?kit-id-regex]
[(get-else $ ?study :study/kit-id-validation-message "") ?kit-id-validation-message]]}
filtered-query (if (nil? active)
query
(assoc query :in '[$ ?active]))]
(apply d/q-latest (remove nil? [filtered-query active]))))
(defn cohort-associated-with-study
[study-uuid cohort-uuid]
(seq (d/q-latest '[:find ?cohort ?study
:in $ ?cohort-uuid ?study-uuid
:where
[?study :study/uuid ?study-uuid]
[?study :study/cohorts ?cohort-tuple]
[(untuple ?cohort-tuple) [?cohort ?active]]
[?cohort :cohort/uuid ?cohort-uuid]]
cohort-uuid study-uuid)))
(defn update-study
[uuid name]
(d/transact [{:db/id [:study/uuid uuid]
:study/name name}]))
(defn update-study-active-status
[uuid status]
(d/transact [{:db/id [:study/uuid uuid]
:study/active status}]))

View File

@@ -0,0 +1,68 @@
(ns org.parkerici.sample-tracking.db.timepoint
(:require [org.parkerici.sample-tracking.db.datomic :as d]
[org.parkerici.sample-tracking.db.core :as db]))
(defn create-timepoint
[name]
(let [uuid (db/squuid)
txn {:timepoint/name name :timepoint/uuid uuid}]
(db/transact [txn])
uuid))
; There should only be one timepoint with a given name.
; Returns the ID of the timepoint with the passed in name if it exists.
(defn find-timepoint-uuid-from-name
[name]
(ffirst (d/q-latest '[:find ?timepoint-uuid
:in $ ?timepoint-name
:where
[?timepoint :timepoint/name ?timepoint-name]
[?timepoint :timepoint/uuid ?timepoint-uuid]]
name)))
(defn find-timepoint-by-uuid
[uuid]
(first (d/q-latest '[:find ?timepoint-name
:keys name
:in $ ?uuid
:where
[?timepoint :timepoint/uuid ?uuid]
[?timepoint :timepoint/name ?timepoint-name]]
uuid)))
(defn list-sorted-kit-type-timepoints
"Gets the timepoints associated with a given kit type
in the order they were associated with that kit type"
[kit-type-uuid]
(let [results (d/q-latest '[:find ?timepoint-uuid ?timepoint-name ?tx-inst
:keys uuid name sort-time
:in $ ?kit-type-uuid
:where
[?kit-type :kit-type/uuid ?kit-type-uuid]
[?kit-type :kit-type/timepoints ?timepoint ?tx-eid]
[?tx-eid :db/txInstant ?tx-inst]
[?kit-type :kit-type/timepoints ?timepoint]
[?timepoint :timepoint/name ?timepoint-name]
[?timepoint :timepoint/uuid ?timepoint-uuid]]
kit-type-uuid)
sorted-results (sort-by :sort-time results)]
(map #(dissoc % :sort-time) sorted-results)))
(defn update-timepoint
[uuid name]
(d/transact [{:db/id [:timepoint/uuid uuid]
:timepoint/name name}]))
(defn list-kit-timepoints
[config-map]
(let [kit-uuid (:uuid config-map)
query {:find '[?timepoint-uuid ?timepoint-name ?kit-uuid]
:keys '[uuid timepoint-name kit-uuid]
:where '[[?kit :kit/uuid ?kit-uuid]
[?kit :kit/timepoints ?timepoint]
[?timepoint :timepoint/name ?timepoint-name]
[?timepoint :timepoint/uuid ?timepoint-uuid]]}
query-fn (if-let [tx-id (:tx-id config-map)] (d/q-as-of tx-id) d/q-latest)
results (query-fn query)]
(cond-> results
kit-uuid (db/reducer-filter :kit-uuid kit-uuid))))

View File

@@ -0,0 +1,73 @@
(ns org.parkerici.sample-tracking.db.user
(:require [org.parkerici.sample-tracking.db.datomic :as d]
[org.parkerici.sample-tracking.db.core :as db]))
(defn create-user
[email]
(let [uuid (db/squuid)]
(db/transact [{:user/email email :user/uuid uuid}])
uuid))
(defn find-user-uuid
[email]
(ffirst (d/q-latest '[:find ?uuid
:in $ ?email
:where
[?user :user/email ?email]
[?user :user/uuid ?uuid]]
email)))
(defn add-role-to-user
[user-uuid role-uuid]
(d/transact [[:db/add [:user/uuid user-uuid] :user/roles [:role/uuid role-uuid]]]))
(defn remove-role-from-user
[user-uuid role-uuid]
(d/transact [[:db/retract [:user/uuid user-uuid] :user/roles [:role/uuid role-uuid]]]))
(defn set-user-deactivated-status
[email status]
(d/transact [{:db/id [:user/email email]
:user/deactivated status}]))
(defn user-has-role
[user-uuid role-uuid]
(seq (d/q-latest '[:find ?email
:in $ ?user-uuid ?role-uuid
:where
[?user :user/uuid ?user-uuid]
[?user :user/email ?email]
[?user :user/roles ?role]
[?role :role/uuid ?role-uuid]] user-uuid role-uuid)))
(defn get-users-roles
[email]
(d/q-latest '[:find ?role-name
:in $ ?email
:where
[?user :user/email ?email]
[?user :user/roles ?role]
[?role :role/name ?role-name]]
email))
(defn get-users-with-role
[role-name]
(d/q-latest '[:find ?email
:in $ ?role-name
:where
[?role :role/name ?role-name]
[?user :user/roles ?role]
[?user :user/email ?email]]
role-name))
(defn list-users
[options]
(let [all-users (map first (d/q-latest '[:find (pull ?user [[:user/uuid :as :uuid]
[:user/email :as :email]
[:user/deactivated :default false :as :deactivated]
{[:user/roles :as :roles] [[:role/name :as :name]
[:role/uuid :as :uuid]]}])
:where [?user :user/uuid]]))]
(if (:email options)
(db/reducer-filter all-users :email (:email options))
all-users)))

View File

@@ -0,0 +1,173 @@
(ns org.parkerici.sample-tracking.handler
(:require [compojure.core :refer [defroutes context routes POST GET PATCH DELETE make-route]]
[compojure.route :as route]
[ring.middleware.format-params :refer [wrap-transit-json-params]]
[ring.middleware.format-response :refer [wrap-transit-json-response]]
[ring.logger :as logger]
[ring.middleware.session.memory :as ring-memory]
[ring.middleware.gzip :refer [wrap-gzip]]
[taoensso.timbre :as log]
[ring.middleware.defaults :as middleware]
[ring.util.response :as response]
[org.parkerici.sample-tracking.api :as api]
[org.parkerici.sample-tracking.utils.ring :as ring-utils]
[org.parkerici.sample-tracking.handlers.auth :as auth]
[org.parkerici.sample-tracking.db.datomic :as datomic]))
(defroutes site-routes
;; Things handled by SPA
(GET "*" [] (response/content-type (response/resource-response "index.html" {:root "public"}) "text/html")))
;;; Weird that this isn't a standard part of ring
(defn wrap-exception-handling
[handler]
(fn [request]
(try
(handler request)
(catch clojure.lang.ExceptionInfo e
{:status 400 :headers {} :body (str "Error: " (ex-message e))})
(catch Throwable e
{:status 500 :headers {} :body (str "Error: " (print-str e))}))))
;;; Weird that this isn't a standard part of ring
(defn wrap-no-read-eval
[handler]
(fn [request]
(binding [*read-eval* false]
(handler request))))
;;; Ensure API and site pages use the same store, so authentication works for API.
(def common-store (ring-memory/memory-store))
;;; Note: static resources are handled by middleware, see middleware/site-defaults
(def site-defaults
(-> middleware/site-defaults
auth/set-auth-site-defaults
(assoc-in [:security :anti-forgery] false) ;necessary for upload (TODO not great from sec viewpoint)
(assoc :cookies true)
(assoc-in [:params :multipart] true) ;to support file uploads
(assoc-in [:session :flash] false)
(assoc-in [:session :store] common-store)))
(defn wrap-logger
"Hook Ring logger to timbre unless logger is disabled"
[handler options]
(if (:disable-logger options)
handler
(logger/wrap-with-logger
handler
{:log-fn (fn [{:keys [level throwable message]}]
(log/log level throwable message))})))
(defn make-site
[options]
(-> site-routes
(auth/wrap-auth options)
datomic/wrap-datomic
(middleware/wrap-defaults site-defaults)
wrap-no-read-eval
(wrap-logger options)
wrap-exception-handling))
(defroutes api-routes
(context "/api" []
(GET "/" [] (api/api-version))
(context "/kit" []
(POST "/" request (api/submit-kit-shipment request))
(PATCH "/" request (api/update-kit-shipment request))
(GET "/" request (api/list-kit-shipments request))
(GET "/submitted" [kit-id] (api/kit-shipment-submitted kit-id))
(PATCH "/set-archived" [uuid archived :as request] (api/set-kit-shipment-archived request uuid archived))
(context "/share" []
(POST "/" request (api/create-incomplete-kit-shipment request))
(PATCH "/" request (api/update-incomplete-kit-shipment request))
(GET "/" [uuid] (api/get-incomplete-kit-shipment uuid)))
(context "/propose-edit" []
(GET "/" request (api/get-kit-shipment-or-proposed-edit request))
(GET "/view" request (api/get-proposed-kit-shipment-edit-for-view request))
(GET "/list" [status] (api/list-proposed-kit-shipment-edits status))
(POST "/" request (api/propose-kit-shipment-edit request))
(POST "/set-status" request (api/set-kit-shipment-edit-status request))))
(context "/upload" []
(POST "/kit-type" request (api/upload-kit-types request))
(POST "/form-type" request (api/upload-form-types request))
(POST "/site" request (api/upload-sites request))
(POST "/study" request (api/upload-studies request)))
(context "/site" []
(GET "/" [study active] (api/list-sites study active))
(POST "/" request (api/update-site request)))
(context "/study" []
(GET "/" [active] (api/list-studies active))
(POST "/" request (api/update-study request)))
(context "/cohort" []
(GET "/" [study active] (api/list-cohorts study active))
(POST "/" request (api/update-cohort request)))
(context "/kit-type" []
(GET "/" [cohort active] (api/list-kit-types cohort active))
(POST "/" request (api/update-kit-type request)))
(context "/timepoint" []
(GET "/" [kit-type] (api/list-timepoints kit-type))
(POST "/" request (api/update-timepoint request)))
(context "/sample-type" []
(GET "/" [kit-type] (api/list-sample-types kit-type))
(POST "/" request (api/update-sample-type request)))
(context "/sample" []
(GET "/export" [uuid complete archived uncollected]
(api/export-samples->csv uuid complete archived uncollected)))
(context "/user" []
(GET "/" [] (api/list-users))
(POST "/" request (api/create-user request))
(DELETE "/" request (api/deactivate-user request))
(GET "/current" request (api/user-info request))
(context "/role" []
(POST "/" request (api/add-role-to-user request))
(DELETE "/" request (api/remove-role-from-user request))))
(GET "/role" [] (api/list-roles))
(GET "/form-type-fields" [kit-type] (api/get-form-type-fields kit-type))
(GET "/history" [uuid] (api/list-history uuid))
(POST "/set-active" request (api/set-active request))
(GET "/configuration" [] (api/list-configuration))
(POST "/log-in" request (api/log-in request))
(POST "/log-out" request (api/log-out request))
(GET "/firebase-credentials" [] (api/firebase-js-credentials))
(GET "/health" [] (ring-utils/json-response {:success true} :status 200))
(route/not-found (ring-utils/json-response {:error "Not Found"} :status 404))))
(def api-defaults
(-> middleware/api-defaults
auth/set-auth-site-defaults
(assoc :cookies true)
(assoc-in [:session :flash] false)
(assoc-in [:session :store] common-store)))
;;; Must be something built-in for this?
(defn wrap-filter
[handler path]
(make-route nil path handler))
(defn make-api
[options]
(-> api-routes
(auth/wrap-auth options)
(middleware/wrap-defaults api-defaults)
wrap-no-read-eval
datomic/wrap-datomic
wrap-transit-json-params
(wrap-logger options)
wrap-exception-handling
wrap-transit-json-response
wrap-gzip
(wrap-filter "/api/*")))
; Returns a blank response for anything called to /__/auth/*
; Used for firebase auth stuff. Hopefully works.
(defn make-firebase
[]
(wrap-filter (GET "/__/auth/*" [] {}) "/__/auth/*"))
(defn make-app
[options]
(routes (make-api options) (make-firebase) (make-site options)))
(def app
(make-app {}))

View File

@@ -0,0 +1,127 @@
(ns org.parkerici.sample-tracking.handlers.auth
(:require [clojure.string :as str]
[ring.util.response :as response]
[buddy.auth :refer [authenticated?]]
[buddy.auth.backends.session :refer [session-backend]]
[buddy.auth.middleware :refer [wrap-authentication wrap-authorization]]
[buddy.auth.accessrules :refer [wrap-access-rules]]
[org.parkerici.sample-tracking.utils.ring :as ring-utils]
[org.parkerici.sample-tracking.configuration :as config]))
(defn set-auth-site-defaults
[site-defaults]
(assoc-in site-defaults [:session :cookie-attrs :same-site] :lax))
; Default unauthorized handler. If the request is to an API page return a json response
; Otherwise redirect the user to the unauthorized page.
(defn unauthorized-handler
[request _metadata]
(if (str/starts-with? (:uri request) "/api")
(if (authenticated? request)
(ring-utils/json-response {:error "Unauthorized"} :status 403)
(ring-utils/json-response {:error "Unauthorized"} :status 401))
(let [{:keys [auth-error is-a-user email-verified]} (:session request)]
(cond
(false? is-a-user) (response/redirect "/auth/not-a-user")
(false? email-verified) (response/redirect "/auth/verify-email")
auth-error (response/redirect "/auth/auth-error")
:else (response/redirect "/auth/unauthorized")))))
; Create an instance of session auth backend.
(def session-auth-backend
(session-backend {:unauthorized-handler unauthorized-handler}))
; Checks if the logged in user has been added to the database
; if their email is verified and if there were any errors during authentication
(defn auth-successful?
[request]
(let [{:keys [auth-error is-a-user email-verified]} (:session request)]
(and is-a-user email-verified (not auth-error))))
; Admin access handler.
; Checks if the session roles has the admin role in it.
(defn admin-access
[request]
(let [roles (get-in request [:session :roles])]
(contains? roles (config/application-admin-role))))
(defn admin-or-editor-access
[request]
(let [roles (get-in request [:session :roles])]
(or
(contains? roles (config/application-admin-role))
(contains? roles (config/application-editor-role)))))
(defn internal-access
[request]
(let [roles (get-in request [:session :roles])]
(or
(contains? roles (config/application-admin-role))
(contains? roles (config/application-editor-role))
(contains? roles (config/application-viewer-role)))))
(defn site-access
[request]
(let [roles (get-in request [:session :roles])]
(or
(contains? roles (config/site-admin-role))
(contains? roles (config/site-coordinator-role)))))
(defn valid-api-key?
[request]
(let [auth-header (get-in request [:headers "authorization"])
api-key (if auth-header (second (str/split auth-header #" ")) nil)]
(= api-key (config/api-key))))
; Open access. Always returns true.
(defn open-access
[_request]
true)
; Access rules for the buddy-auth system
(def rules
[{:uris ["/" "/auth/*" "/manifest" "/api/" "/api/study" "/api/cohort" "/api/timepoint" "/api/kit-type"
"/api/sample-type" "/api/form-type-fields" "/index.html" "/favicon.ico" "/api/health" "/api/site"
"/cljs-out/main.js" "/css/*" "/oauth2/*" "/__/auth/*" "/api/current-user" "/share/*" "/images/*"
"/api/user/current" "/api/kit/submitted" "/api/firebase-credentials"]
:handler open-access
:request-method :get}
{:uris ["/api/kit" "/api/log-in" "/api/log-out"]
:handler open-access
:request-method :post}
{:uri "/api/kit/share"
:handler open-access
:request-method #{:post :patch :get}}
{:uris ["/console" "/console/kit/list" "/console/kit/propose/new/*" "/api/kit"]
:handler {:and [auth-successful? {:or [internal-access site-access]}]}
:request-method #{:get}}
{:uri "/api/kit/propose-edit"
:handler {:and [auth-successful? {:or [internal-access site-access]}]}
:request-method #{:post :get}}
{:uris ["/console/*" "/api/history"]
:handler {:and [auth-successful? internal-access]}
:request-method #{:get}}
{:uri "/api/sample/export"
:handler {:or [valid-api-key? {:and [auth-successful? internal-access]}]}
:request-method #{:get}}
{:uri "/api/kit/set-archived"
:handler {:and [auth-successful? admin-or-editor-access]}
:request-method #{:patch}}
{:uris ["/console/kit/propose/*" "/api/kit/propose-edit*"]
:handler admin-or-editor-access
:request-method #{:get :post}}
{:uris ["/api/upload/*" "/api/site" "/api/study" "/api/cohort" "/api/timepoint" "/api/kit-type" "/api/kit"
"/api/sample-type" "/api/set-active" "/api/user" "/api/user/*" "/api/role" "/api/configuration"]
:handler {:and [auth-successful? admin-access]}
:request-method #{:post :patch :get :delete}}])
(defn wrap-auth
[handler options]
(let [buddy-auth-handler (-> handler
(wrap-access-rules {:rules rules
:policy :reject})
(wrap-authorization session-auth-backend)
(wrap-authentication session-auth-backend))]
(if-let [auth-wrapper-override (:auth-wrapper options)]
(auth-wrapper-override buddy-auth-handler)
buddy-auth-handler)))

View File

@@ -0,0 +1,19 @@
(ns org.parkerici.sample-tracking.server
(:require [ring.adapter.jetty :as jetty]
[taoensso.timbre :as log]
[trptcolin.versioneer.core :as version]
[org.parkerici.sample-tracking.handler :as handler]))
(def server (atom nil))
(defn stop
[]
(when @server
(.stop @server)))
(defn start
([port] (start port handler/app))
([port handler]
(log/infof "Starting sample-tracking server version %s at port %s" (version/get-version "sample-tracking" "sample-tracking") port)
(stop)
(reset! server (jetty/run-jetty handler {:port port :join? false}))))

View File

@@ -0,0 +1,74 @@
(ns org.parkerici.sample-tracking.utils.csv
(:require [clojure.java.io :as io]
[clojure.set :as set]
[clojure.string :as str]
[clojure.data.csv :as csv]))
; Might be worth switching to https://github.com/jimpil/clj-bom if we have more encoding issues in the future.
(defn read-csv-file
"Encoding can be any valid encoding like 'UTF-8' or 'UTF-16LE'. Defaults to 'UTF-8'.
Delimiter for read-csv-file defaults to comma, but can be any character (e.g. \tab)"
[fpath & {:keys [encoding delimiter] :or {delimiter \,}}]
(with-open [reader (io/reader fpath :encoding encoding)]
(doall
(csv/read-csv reader :separator delimiter))))
(defn split-csv-string
[value]
(doall (map str/trim (str/split value #","))))
(defn generate-raw-headers
"Generates a list of all of the distinct keys from the maps in data-seq as strings"
[data-seq column-order]
(let [headers-set (set (reduce (fn [headers row] (concat headers (keys row))) [] data-seq))
headers-missing-from-order (set/difference headers-set (set column-order))]
(concat column-order (vec headers-missing-from-order))))
(defn generate-csv-rows
[headers data-seq]
(map (fn [row] (mapv row headers)) data-seq))
(defn generate-csv-data
"Takes input of a seq of maps
Outputs a seq of seqs of the format csv/write-csv expects.
The first seq being the header and the rest being data.
Expects a list or nil for column order. If passed in uses it to order the columns.
Any missing columns are appended to the end in random order.
Expects map or nil for renamed-columns. If passed in uses the values in the map to rename the columns.
Otherwise uses (name)."
[data-seq column-order columns-to-rename]
(let [raw-headers (generate-raw-headers data-seq column-order)
string-headers (map (fn [header]
(let [renamed-header (get columns-to-rename header)]
(if renamed-header
renamed-header
(name header)))) raw-headers)]
(cons string-headers (generate-csv-rows raw-headers data-seq))))
(defn csv-output-stream-fn
"Takes input of a seq of maps
Outputs a function that writes the csv data to a stream"
[data-seq options]
(let [csv-data (generate-csv-data data-seq (:column-order options) (:columns-to-rename options))]
(fn [out-stream] (csv/write-csv out-stream csv-data)
(.flush out-stream))))
(defn write-csv-file
[fpath data-seq options]
(with-open [w (io/writer fpath)]
(doall
(csv/write-csv w (generate-csv-data data-seq (:column-order options) (:columns-to-rename options))))))
(defn read-csv-into-map
"Reads a CSV at fpath. Expects it to have a header
Returns a list of maps where each column value is keyed on the csv-headers passed in
If csv-headers is empty or missing values will use the column/header names from the file.
Applies required-values-fn to each map value to filter out bad rows."
[fpath csv-headers required-values-fn]
(let [raw-csv (read-csv-file fpath)
csv-header (first raw-csv)
extra-headers (subvec csv-header (count csv-headers))
all-headers (concat csv-headers extra-headers)
csv-rows (drop 1 raw-csv)
csv-map (map #(zipmap all-headers %) csv-rows)]
(filter required-values-fn csv-map)))

View File

@@ -0,0 +1,22 @@
(ns org.parkerici.sample-tracking.utils.date-time
(:require [java-time :as time]
[org.parkerici.sample-tracking.utils.str :as str]))
(defn parse-zoned-date-time
[date-time-string timezone-string]
(let [timezone-id (time/zone-id timezone-string)]
(time/zoned-date-time (time/java-date date-time-string) timezone-id)))
(defn timestamp-parsable
[timestamp]
(and (some? timestamp) (if (string? timestamp) (str/not-blank? timestamp) true)))
(defn generate-date-string
[timestamp timezone]
(when (timestamp-parsable timestamp)
(time/format "MM/dd/yyyy" (parse-zoned-date-time timestamp timezone))))
(defn generate-time-string
[timestamp timezone]
(when (timestamp-parsable timestamp)
(time/format "HH:mm" (parse-zoned-date-time timestamp timezone))))

Some files were not shown because too many files have changed in this diff Show More