fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

Merge branch 'master' into feat/external-apis

Browse Source
This commit is contained in:
Gregor Kleen 2021-02-09 13:57:30 +01:00
commit 7435d45fd6
51 changed files with 2231 additions and 1399 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
.gitignore vendored
View File

@ -41,4 +41,7 @@ tunnel.log
/.well-known-cache
/**/tmp-*
/testdata/bigAlloc_*.csv
/sessions
/sessions
/changelog.json
/.current-version
/.current-changelog.md

173
.gitlab-ci.yml
View File

@ -1,3 +1,9 @@
workflow:
rules:
- if: '$CI_PIPELINE_SOURCE == "push"'
when: always
- when: never
default:
image:
name: fpco/stack-build:lts-16.11
@ -21,6 +27,7 @@ variables:
UPLOAD_S3_KEY_ID: gOel7KvadwNKgjjy
UPLOAD_S3_KEY: ugO5pkEla7F0JW9MdPwLi4MWLT5ZbqAL
N_PREFIX: "${HOME}/.n"
PACKAGE_REGISTRY_URL: "${CI_API_V4_URL}/projects/${CI_PROJECT_ID}/packages/generic/uni2work"
stages:
- setup
@ -28,7 +35,10 @@ stages:
- yesod:build
- lint
- test
- deploy
- prepare release
- upload packages
- release
# - deploy
npm install:
stage: setup
@ -51,7 +61,7 @@ npm install:
artifacts:
paths:
- node_modules/
name: "${CI_JOB_NAME}"
name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}"
expire_in: "1 day"
retry: 2
interruptible: true
@ -68,7 +78,7 @@ frontend:build:
- static
- well-known
- config/webpack.yml
name: "${CI_JOB_NAME}"
name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}"
expire_in: "1 day"
dependencies:
- npm install
@ -112,14 +122,16 @@ yesod:build:dev:
artifacts:
paths:
- bin/
name: "${CI_JOB_NAME}"
name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}"
expire_in: "1 week"
dependencies:
- frontend:build
only:
variables:
- $CI_COMMIT_REF_NAME !~ /^v[0-9].*/
rules:
- if: $CI_COMMIT_REF_NAME =~ /(^v[0-9].*)|((^|\/)profile($|\/))/
when: manual
- when: always
retry: 2
interruptible: true
@ -135,13 +147,42 @@ yesod:build:
artifacts:
paths:
- bin/
name: "${CI_JOB_NAME}"
name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}"
dependencies:
- frontend:build
only:
variables:
- $CI_COMMIT_REF_NAME =~ /^v[0-9].*/
rules:
- if: $CI_COMMIT_REF_NAME =~ /^v[0-9].*/
when: always
- when: manual
retry: 2
interruptible: true
resource_group: ram
yesod:build:profile:
cache:
<<: *global_cache
policy: pull
stage: yesod:build
script:
- stack build --profile --copy-bins --local-bin-path $(pwd)/bin --flag uniworx:-library-only --flag uniworx:-dev --flag uniworx:pedantic --no-strip
needs:
- frontend:build
before_script: *haskell
artifacts:
paths:
- bin/
name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}"
dependencies:
- frontend:build
rules:
- if: $CI_COMMIT_REF_NAME =~ /(^|\/)profile($|\/)/
when: always
- when: manual
retry: 2
interruptible: true
resource_group: ram
@ -170,28 +211,106 @@ frontend:test:
retry: 2
interruptible: true
deploy:uniworx3:
parse-changelog:
cache: {}
stage: deploy
variables:
GIT_STRATEGY: none
script:
- zip -qj - bin/uniworx bin/uniworxdb | ssh root@uniworx3.ifi.lmu.de /root/bin/accept_uni2work
stage: prepare release
dependencies:
- npm install
needs:
- yesod:build
- frontend:test # For sanity
- npm install
rules:
- if: $CI_COMMIT_REF_NAME =~ /^v[0-9].*/
when: always
before_script:
- rm -rvf /etc/apt/sources.list /etc/apt/sources.list.d
- install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list
- apt-get update -y
- apt-get install -y --no-install-recommends openssh-client
- install -v -m 0700 -d ~/.ssh
- install -v -T -m 0644 ${SSH_KNOWN_HOSTS} ~/.ssh/known_hosts
- install -v -T -m 0400 ${SSH_PRIVATE_KEY_UNIWORX3} ~/.ssh/uniworx3; echo "IdentityFile ~/.ssh/uniworx3" >> ~/.ssh/config;
- apt-get install -y --no-install-recommends jq
script:
- npm run parse-changelog
- |
jq -r '.versions[0].version' changelog.json > .current-version
- |
jq -r '.versions[0].body' changelog.json > .current-changelog.md
artifacts:
paths:
- .current-version
- .current-changelog.md
name: "changelog-${CI_COMMIT_SHORT_SHA}"
expire_in: "1 day"
retry: 2
interruptible: true
upload:
cache: {}
stage: upload packages
image: curlimages/curl:latest
needs:
- yesod:build
- parse-changelog
dependencies:
- yesod:build
- parse-changelog
rules:
- if: $CI_COMMIT_REF_NAME =~ /^v[0-9].*/
when: always
before_script:
- export VERSION="$(cat .current-version)"
script:
- |
curl --header "JOB-TOKEN: ${CI_JOB_TOKEN}" --upload-file bin/uniworx ${PACKAGE_REGISTRY_URL}/${VERSION}/uniworx
- |
curl --header "JOB-TOKEN: ${CI_JOB_TOKEN}" --upload-file bin/uniworxdb ${PACKAGE_REGISTRY_URL}/${VERSION}/uniworxdb
- |
curl --header "JOB-TOKEN: ${CI_JOB_TOKEN}" --upload-file bin/uniworxload ${PACKAGE_REGISTRY_URL}/${VERSION}/uniworxload
- |
curl --header "JOB-TOKEN: ${CI_JOB_TOKEN}" --upload-file bin/uniworx-wflint ${PACKAGE_REGISTRY_URL}/${VERSION}/uniworx-wflint
release:
cache: {}
stage: release
image: registry.gitlab.com/gitlab-org/release-cli:latest
needs:
- upload
- parse-changelog
dependencies:
- parse-changelog
rules:
- if: $CI_COMMIT_REF_NAME =~ /^v[0-9].*/
when: always
before_script:
- export VERSION="$(cat .current-version)"
script:
- |
release-cli create --name "${VERSION}" --tag-name $CI_COMMIT_TAG --description ./current-changelog.md \
--assets-link "{\"name\":\"uniworx\",\"url\":\"${PACKAGE_REGISTRY_URL}/${VERSION}/uniworx\",\"filepath\":\"uniworx\"}" \
--assets-link "{\"name\":\"uniworxdb\",\"url\":\"${PACKAGE_REGISTRY_URL}/${VERSION}/uniworxdb\",\"filepath\":\"uniworxdb\"}" \
--assets-link "{\"name\":\"uniworxload\",\"url\":\"${PACKAGE_REGISTRY_URL}/${VERSION}/uniworxload\",\"filepath\":\"uniworxload\"}" \
--assets-link "{\"name\":\"uniworx-wflint\",\"url\":\"${PACKAGE_REGISTRY_URL}/${VERSION}/uniworx-wflint\",\"filepath\":\"uniworx-wflint\"}"
# deploy:uniworx3:
# cache: {}
# stage: deploy
# variables:
# GIT_STRATEGY: none
# script:
# - zip -qj - bin/uniworx bin/uniworxdb | ssh root@uniworx3.ifi.lmu.de /root/bin/accept_uni2work
# needs:
# - yesod:build
# - frontend:test # For sanity
# before_script:
# - rm -rvf /etc/apt/sources.list /etc/apt/sources.list.d
# - install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list
# - apt-get update -y
# - apt-get install -y --no-install-recommends openssh-client
# - install -v -m 0700 -d ~/.ssh
# - install -v -T -m 0644 ${SSH_KNOWN_HOSTS} ~/.ssh/known_hosts
# - install -v -T -m 0400 ${SSH_PRIVATE_KEY_UNIWORX3} ~/.ssh/uniworx3; echo "IdentityFile ~/.ssh/uniworx3" >> ~/.ssh/config;
# dependencies:
# - yesod:build
only:
variables:
- $CI_COMMIT_REF_NAME =~ /^v[0-9].*/
resource_group: uniworx3
# only:
# variables:
# - $CI_COMMIT_REF_NAME =~ /^v[0-9].*/
# resource_group: uniworx3

289
CHANGELOG.md
View File

@ -2,6 +2,53 @@
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
## [24.1.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v24.1.1...v24.1.2) (2021-02-09)
## [24.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v24.1.0...v24.1.1) (2021-02-09)
## [24.1.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v24.0.0...v24.1.0) (2021-02-08)
### Features
* ensure cached study feature relevance is up to date ([8798f54](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8798f547a60a7fa7c0849e20e1b0e9d012ac9312))
### Bug Fixes
* restore storting for exam-office exams ([5698e9c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5698e9ca0bb19585b9a9d2d3c10f8b5f99ae5db9))
## [24.0.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v23.7.0...v24.0.0) (2021-02-01)
### ⚠ BREAKING CHANGES
* **jobs:** Job offloading
### Features
* **jobs:** batch job offloading ([09fb26f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/09fb26f1a892feba32185166223f8f95611ea9ef))
### Bug Fixes
* **workflows:** don't cache instance-list empty for correctness ([cb1e715](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cb1e715e9b2da2f5ac0bd03b636de0f961307efd))
## [23.7.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v23.6.0...v23.7.0) (2021-01-27)
### Features
* **dbtable:** extra representations ([2c0fc63](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2c0fc63be1de02e8acffbc6a9c5ee83b061c5825))
* **exams:** exam sheets ([500000b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/500000ba0f6f3b3c32cfd7593e5468796660d46b))
### Bug Fixes
* more verbose watchdog notification failures ([48028c4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/48028c40532577f74430340ed924af7116b8bd96))
* **mass-input:** properly escape query selector ([9a3f401](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9a3f401b38e86e2f9e7fa722698a437d853b422e))
* nonmoving-gc still segfaults ([c404ce9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c404ce9b3529cf402a0f9d649ca3299df09ba089))
## [23.6.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v23.5.0...v23.6.0) (2020-12-15)
@ -23,16 +70,16 @@ All notable changes to this project will be documented in this file. See [standa
* **tokens:** introduce clock leniency and remove start for downloads ([8939a8b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8939a8b90a39a26614da18dd3985aee253cd191f))
* hopefully improve workflow auth performance ([1d3fd8c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1d3fd8c8a7824d6c6d043f4114067238af4bdc6e))
### [23.4.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v23.4.2...v23.4.3) (2020-12-10)
## [23.4.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v23.4.2...v23.4.3) (2020-12-10)
### [23.4.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v23.4.1...v23.4.2) (2020-12-10)
## [23.4.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v23.4.1...v23.4.2) (2020-12-10)
### Bug Fixes
* hopefully speed up aeson via ffi ([a00ba10](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a00ba10e9cf1ffa534908b9125730e88179052eb))
### [23.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v23.4.0...v23.4.1) (2020-12-10)
## [23.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v23.4.0...v23.4.1) (2020-12-10)
## [23.4.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v23.3.0...v23.4.0) (2020-12-09)
@ -55,14 +102,14 @@ All notable changes to this project will be documented in this file. See [standa
* **admin-crontab:** export as json ([bbd4916](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bbd4916f3a556ce4c05eb3b2b5268c9c072fdfdd))
* **jobs:** queue by jobctl priority ([a27a553](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a27a553e0a9782eda6023ec0b8b1055757bb511f))
### [23.2.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v23.2.1...v23.2.2) (2020-12-09)
## [23.2.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v23.2.1...v23.2.2) (2020-12-09)
### Bug Fixes
* **jobs:** adjust job handling to hopefully reduce load ([ed38f93](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ed38f93537b57b5b3e4563dc0259d805760071bc))
### [23.2.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v23.2.0...v23.2.1) (2020-12-08)
## [23.2.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v23.2.0...v23.2.1) (2020-12-08)
### Bug Fixes
@ -82,14 +129,14 @@ All notable changes to this project will be documented in this file. See [standa
* **auth:** fix infinite auth loop for workflow files ([21cf6cf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/21cf6cfa873b841c2f9f8ab9f69c08ea72fc2420))
### [23.1.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v23.1.1...v23.1.2) (2020-12-05)
## [23.1.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v23.1.1...v23.1.2) (2020-12-05)
### Bug Fixes
* submission download token generation broke viewing ([e1b6084](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e1b60844cb77b1fd41900d0a3c4829ba21b6b3fe))
### [23.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v23.1.0...v23.1.1) (2020-12-05)
## [23.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v23.1.0...v23.1.1) (2020-12-05)
### Bug Fixes
@ -118,7 +165,7 @@ All notable changes to this project will be documented in this file. See [standa
* **tests:** generate sensible WorkflowPayloadLabels ([8a888d3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8a888d3945f0fd0d67ef83bae621744c943b99de))
* **workflows:** properly offer previous payload files ([aa0404a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/aa0404a0075acbcd4c6f94984acdbb4d68f08d0a))
### [23.0.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v23.0.2...v23.0.3) (2020-11-29)
## [23.0.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v23.0.2...v23.0.3) (2020-11-29)
### Bug Fixes
@ -129,7 +176,7 @@ All notable changes to this project will be documented in this file. See [standa
* build ([43bb0ab](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/43bb0abe7218f6d43b52d9a64e62f0dc29b9972e))
* **rooms:** honor roomHidden ([ed5d871](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ed5d871182954e2f0a9a5063f61277d925628c40))
### [23.0.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v23.0.1...v23.0.2) (2020-11-28)
## [23.0.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v23.0.1...v23.0.2) (2020-11-28)
### Bug Fixes
@ -137,7 +184,7 @@ All notable changes to this project will be documented in this file. See [standa
* **tests:** remove invalid claim of commutativity ([d2f0361](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d2f0361e49114e6dc6c55e64b677b8c842e93bee))
* build ([23a21b9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/23a21b905c902bea5fe88abd84da600e757a194e))
### [23.0.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v23.0.0...v23.0.1) (2020-11-27)
## [23.0.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v23.0.0...v23.0.1) (2020-11-27)
### Bug Fixes
@ -196,7 +243,7 @@ Also improve efficiency of marking workflow files as referenced
* **workflows:** refer by id in model ([94f78a0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/94f78a07d9376670122a2adce01cf7180a64d33d))
* **workflows:** ui improvements ([c7f4fa0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c7f4fa0e412d2b920a3819ffed5b79b8aeea2842))
### [22.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v22.1.0...v22.1.1) (2020-11-14)
## [22.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v22.1.0...v22.1.1) (2020-11-14)
## [22.1.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v22.0.0...v22.1.0) (2020-11-10)
@ -222,7 +269,7 @@ Also improve efficiency of marking workflow files as referenced
* **html-field:** introduce stored-markup ([e25e8a2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e25e8a2f4ca65afc29acc8a3884df9acf77d4398))
### [21.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.1.0...v21.1.1) (2020-11-06)
## [21.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.1.0...v21.1.1) (2020-11-06)
### Bug Fixes
@ -236,21 +283,21 @@ Also improve efficiency of marking workflow files as referenced
* **sheets:** upload-empty-ok ([ab1940c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ab1940cb09e824fbba03264b5451fa8b17c5c804))
### [21.0.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.0.2...v21.0.3) (2020-11-05)
## [21.0.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.0.2...v21.0.3) (2020-11-05)
### Bug Fixes
* **mails:** prevent emails being resent to due archiving errors ([8cf39dc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8cf39dcbe68cefcc50691ae8a7194315d18420d6))
### [21.0.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.0.1...v21.0.2) (2020-11-04)
## [21.0.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.0.1...v21.0.2) (2020-11-04)
### Bug Fixes
* build ([fa61b46](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fa61b46d308753354623df17241b5312f324321e))
### [21.0.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.0.0...v21.0.1) (2020-11-04)
## [21.0.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.0.0...v21.0.1) (2020-11-04)
### Bug Fixes
@ -301,7 +348,7 @@ Also improve efficiency of marking workflow files as referenced
* **allocations:** fix allocation-course-accept-substitutes ([b4df980](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b4df98069982752e36e69571f5557a6179b44cff))
### [20.12.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.12.0...v20.12.1) (2020-10-14)
## [20.12.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.12.0...v20.12.1) (2020-10-14)
### Bug Fixes
@ -316,7 +363,7 @@ Also improve efficiency of marking workflow files as referenced
* **ldap:** expose active directory errors ([51ed7e0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/51ed7e0a26a94d2178a4ca10ad7ea36b99076b54))
### [20.11.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.11.0...v20.11.1) (2020-10-14)
## [20.11.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.11.0...v20.11.1) (2020-10-14)
### Bug Fixes
@ -351,7 +398,7 @@ Also improve efficiency of marking workflow files as referenced
* **exams:** auth ExamResults by ExamExamOfficeSchools ([29a3e24](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/29a3e24bcf01cd9c893857eda00dcd249e6cbbe2))
* **exams:** exam staff & additional schools ([94436ee](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/94436ee0e1ce2cbf13a66f9ad81883d7286acb9b))
### [20.8.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.8.0...v20.8.1) (2020-10-12)
## [20.8.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.8.0...v20.8.1) (2020-10-12)
### Bug Fixes
@ -384,7 +431,7 @@ Also improve efficiency of marking workflow files as referenced
* **study-features:** also apply caching to table columns ([564c0b9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/564c0b975ae65881cb3a168855b36e4b1614a6cb))
### [20.5.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.5.0...v20.5.1) (2020-09-29)
## [20.5.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.5.0...v20.5.1) (2020-09-29)
### Bug Fixes
@ -409,7 +456,7 @@ Also improve efficiency of marking workflow files as referenced
* **allocations:** notify for new course upon registration ([9e0b43a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9e0b43a60d26a05f6e1b9d4dae2b2f75dd52fff1))
* tests ([ca81f3b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ca81f3b0f2913431cbaf399c33ed30a21979ce69))
### [20.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.4.0...v20.4.1) (2020-09-23)
## [20.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.4.0...v20.4.1) (2020-09-23)
### Bug Fixes
@ -428,14 +475,14 @@ Also improve efficiency of marking workflow files as referenced
* **jobs:** better flushing, correct metrics, better etas ([e4416e7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e4416e7f0e2ea2cf9db0e61cf2d20c27260ccaf8))
### [20.3.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.3.1...v20.3.2) (2020-09-22)
## [20.3.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.3.1...v20.3.2) (2020-09-22)
### Bug Fixes
* **files:** don't inject serializable ([2ca024b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2ca024b9351df800b57d3235c4a00776cd669952))
### [20.3.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.3.0...v20.3.1) (2020-09-22)
## [20.3.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.3.0...v20.3.1) (2020-09-22)
### Bug Fixes
@ -463,7 +510,7 @@ Also improve efficiency of marking workflow files as referenced
* **exam-form:** sort occurrences and parts ([6d47549](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6d475497c0caee49ad34c5c3c6e7b1bf91ca0ba2))
### [20.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.1.0...v20.1.1) (2020-09-18)
## [20.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.1.0...v20.1.1) (2020-09-18)
### Bug Fixes
@ -505,7 +552,7 @@ Also improve efficiency of marking workflow files as referenced
* zip handling & tests ([350ee79](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/350ee79af3c8fcc480970166a559596873beab2a))
### [19.3.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v19.3.0...v19.3.1) (2020-09-10)
## [19.3.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v19.3.0...v19.3.1) (2020-09-10)
### Bug Fixes
@ -539,14 +586,14 @@ Also improve efficiency of marking workflow files as referenced
* tests ([018d26f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/018d26f4a1a1cf411324aeac56ce4d4203670942))
* tests ([5541619](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5541619372f4a4e46ccc403004e869afdfaed7b0))
### [19.2.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v19.2.1...v19.2.2) (2020-08-26)
## [19.2.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v19.2.1...v19.2.2) (2020-08-26)
### Bug Fixes
* have exam deregistration always delete stored grades ([24f428b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/24f428b13bb181bec99417b4e69fc538e35acbcf))
### [19.2.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v19.2.0...v19.2.1) (2020-08-26)
## [19.2.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v19.2.0...v19.2.1) (2020-08-26)
### Bug Fixes
@ -568,23 +615,23 @@ Also improve efficiency of marking workflow files as referenced
### [19.1.5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v19.1.4...v19.1.5) (2020-08-19)
## [19.1.5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v19.1.4...v19.1.5) (2020-08-19)
### [19.1.4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v19.1.3...v19.1.4) (2020-08-18)
## [19.1.4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v19.1.3...v19.1.4) (2020-08-18)
### [19.1.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v19.1.2...v19.1.3) (2020-08-17)
## [19.1.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v19.1.2...v19.1.3) (2020-08-17)
### [19.1.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v19.1.1...v19.1.2) (2020-08-17)
## [19.1.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v19.1.1...v19.1.2) (2020-08-17)
### [19.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v19.1.0...v19.1.1) (2020-08-17)
## [19.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v19.1.0...v19.1.1) (2020-08-17)
@ -728,7 +775,7 @@ Also improve efficiency of marking workflow files as referenced
### [18.2.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v18.2.1...v18.2.2) (2020-07-23)
## [18.2.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v18.2.1...v18.2.2) (2020-07-23)
### Bug Fixes
@ -738,7 +785,7 @@ Also improve efficiency of marking workflow files as referenced
### [18.2.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v18.2.0...v18.2.1) (2020-07-22)
## [18.2.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v18.2.0...v18.2.1) (2020-07-22)
@ -824,7 +871,7 @@ Also improve efficiency of marking workflow files as referenced
### [17.6.5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v17.6.4...v17.6.5) (2020-06-26)
## [17.6.5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v17.6.4...v17.6.5) (2020-06-26)
### Bug Fixes
@ -833,19 +880,19 @@ Also improve efficiency of marking workflow files as referenced
### [17.6.4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v17.6.3...v17.6.4) (2020-06-24)
## [17.6.4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v17.6.3...v17.6.4) (2020-06-24)
### [17.6.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v17.6.2...v17.6.3) (2020-06-24)
## [17.6.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v17.6.2...v17.6.3) (2020-06-24)
### [17.6.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v17.6.1...v17.6.2) (2020-06-24)
## [17.6.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v17.6.1...v17.6.2) (2020-06-24)
### [17.6.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v17.6.0...v17.6.1) (2020-06-24)
## [17.6.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v17.6.0...v17.6.1) (2020-06-24)
### Bug Fixes
@ -890,7 +937,7 @@ Also improve efficiency of marking workflow files as referenced
### [17.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v17.4.0...v17.4.1) (2020-06-15)
## [17.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v17.4.0...v17.4.1) (2020-06-15)
@ -925,7 +972,7 @@ Also improve efficiency of marking workflow files as referenced
### [17.2.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v17.2.0...v17.2.1) (2020-05-28)
## [17.2.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v17.2.0...v17.2.1) (2020-05-28)
@ -944,7 +991,7 @@ Also improve efficiency of marking workflow files as referenced
### [17.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v17.1.0...v17.1.1) (2020-05-26)
## [17.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v17.1.0...v17.1.1) (2020-05-26)
### Bug Fixes
@ -1013,11 +1060,11 @@ Also improve efficiency of marking workflow files as referenced
### [16.4.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v16.4.1...v16.4.2) (2020-05-13)
## [16.4.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v16.4.1...v16.4.2) (2020-05-13)
### [16.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v16.4.0...v16.4.1) (2020-05-13)
## [16.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v16.4.0...v16.4.1) (2020-05-13)
### Bug Fixes
@ -1045,7 +1092,7 @@ Also improve efficiency of marking workflow files as referenced
### [16.3.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v16.3.0...v16.3.1) (2020-05-10)
## [16.3.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v16.3.0...v16.3.1) (2020-05-10)
### Bug Fixes
@ -1063,7 +1110,7 @@ Also improve efficiency of marking workflow files as referenced
### [16.2.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v16.2.1...v16.2.2) (2020-05-08)
## [16.2.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v16.2.1...v16.2.2) (2020-05-08)
### Bug Fixes
@ -1072,7 +1119,7 @@ Also improve efficiency of marking workflow files as referenced
### [16.2.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v16.2.0...v16.2.1) (2020-05-08)
## [16.2.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v16.2.0...v16.2.1) (2020-05-08)
### Bug Fixes
@ -1110,7 +1157,7 @@ Also improve efficiency of marking workflow files as referenced
### [16.0.5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v16.0.4...v16.0.5) (2020-05-06)
## [16.0.5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v16.0.4...v16.0.5) (2020-05-06)
### Bug Fixes
@ -1119,7 +1166,7 @@ Also improve efficiency of marking workflow files as referenced
### [16.0.4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v16.0.3...v16.0.4) (2020-05-06)
## [16.0.4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v16.0.3...v16.0.4) (2020-05-06)
### Bug Fixes
@ -1128,7 +1175,7 @@ Also improve efficiency of marking workflow files as referenced
### [16.0.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v16.0.2...v16.0.3) (2020-05-05)
## [16.0.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v16.0.2...v16.0.3) (2020-05-05)
### Bug Fixes
@ -1138,7 +1185,7 @@ Also improve efficiency of marking workflow files as referenced
### [16.0.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v16.0.1...v16.0.2) (2020-05-05)
## [16.0.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v16.0.1...v16.0.2) (2020-05-05)
### Bug Fixes
@ -1148,7 +1195,7 @@ Also improve efficiency of marking workflow files as referenced
### [16.0.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v16.0.0...v16.0.1) (2020-05-05)
## [16.0.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v16.0.0...v16.0.1) (2020-05-05)
### Bug Fixes
@ -1177,7 +1224,7 @@ Also improve efficiency of marking workflow files as referenced
### [15.6.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v15.6.0...v15.6.1) (2020-04-30)
## [15.6.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v15.6.0...v15.6.1) (2020-04-30)
### Bug Fixes
@ -1221,7 +1268,7 @@ Also improve efficiency of marking workflow files as referenced
### [15.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v15.4.0...v15.4.1) (2020-04-26)
## [15.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v15.4.0...v15.4.1) (2020-04-26)
### Bug Fixes
@ -1281,7 +1328,7 @@ Also improve efficiency of marking workflow files as referenced
### [15.1.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v15.1.1...v15.1.2) (2020-04-19)
## [15.1.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v15.1.1...v15.1.2) (2020-04-19)
### Bug Fixes
@ -1290,7 +1337,7 @@ Also improve efficiency of marking workflow files as referenced
### [15.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v15.1.0...v15.1.1) (2020-04-17)
## [15.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v15.1.0...v15.1.1) (2020-04-17)
### Bug Fixes
@ -1442,7 +1489,7 @@ Also improve efficiency of marking workflow files as referenced
### [14.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v14.1.0...v14.1.1) (2020-03-06)
## [14.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v14.1.0...v14.1.1) (2020-03-06)
### Bug Fixes
@ -1497,7 +1544,7 @@ relative when priorities are ordinal
### [13.0.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v13.0.0...v13.0.1) (2020-02-24)
## [13.0.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v13.0.0...v13.0.1) (2020-02-24)
### Bug Fixes
@ -1566,7 +1613,7 @@ relative when priorities are ordinal
### [11.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v11.1.0...v11.1.1) (2020-02-14)
## [11.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v11.1.0...v11.1.1) (2020-02-14)
### Bug Fixes
@ -1764,7 +1811,7 @@ relative when priorities are ordinal
### [10.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v10.4.0...v10.4.1) (2020-01-17)
## [10.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v10.4.0...v10.4.1) (2020-01-17)
### Bug Fixes
@ -1874,7 +1921,7 @@ relative when priorities are ordinal
### [10.0.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v10.0.0...v10.0.1) (2019-12-19)
## [10.0.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v10.0.0...v10.0.1) (2019-12-19)
### Bug Fixes
@ -1934,7 +1981,7 @@ relative when priorities are ordinal
### [9.0.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v9.0.2...v9.0.3) (2019-12-03)
## [9.0.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v9.0.2...v9.0.3) (2019-12-03)
### Bug Fixes
@ -1943,7 +1990,7 @@ relative when priorities are ordinal
### [9.0.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v9.0.1...v9.0.2) (2019-12-02)
## [9.0.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v9.0.1...v9.0.2) (2019-12-02)
### Bug Fixes
@ -1952,7 +1999,7 @@ relative when priorities are ordinal
### [9.0.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v9.0.0...v9.0.1) (2019-11-28)
## [9.0.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v9.0.0...v9.0.1) (2019-11-28)
### Bug Fixes
@ -1975,7 +2022,7 @@ relative when priorities are ordinal
### [8.0.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v8.0.0...v8.0.1) (2019-11-27)
## [8.0.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v8.0.0...v8.0.1) (2019-11-27)
### Bug Fixes
@ -2013,7 +2060,7 @@ relative when priorities are ordinal
### [7.25.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.25.0...v7.25.1) (2019-11-22)
## [7.25.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.25.0...v7.25.1) (2019-11-22)
@ -2043,7 +2090,7 @@ relative when priorities are ordinal
### [7.23.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.23.1...v7.23.2) (2019-11-19)
## [7.23.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.23.1...v7.23.2) (2019-11-19)
### Bug Fixes
@ -2053,7 +2100,7 @@ relative when priorities are ordinal
### [7.23.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.23.0...v7.23.1) (2019-11-19)
## [7.23.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.23.0...v7.23.1) (2019-11-19)
### Bug Fixes
@ -2080,7 +2127,7 @@ relative when priorities are ordinal
### [7.22.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.22.0...v7.22.1) (2019-11-14)
## [7.22.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.22.0...v7.22.1) (2019-11-14)
@ -2102,23 +2149,23 @@ relative when priorities are ordinal
### [7.21.5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.21.4...v7.21.5) (2019-11-13)
## [7.21.5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.21.4...v7.21.5) (2019-11-13)
### [7.21.4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.21.3...v7.21.4) (2019-11-13)
## [7.21.4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.21.3...v7.21.4) (2019-11-13)
### [7.21.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.21.2...v7.21.3) (2019-11-13)
## [7.21.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.21.2...v7.21.3) (2019-11-13)
### [7.21.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.21.1...v7.21.2) (2019-11-12)
## [7.21.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.21.1...v7.21.2) (2019-11-12)
### [7.21.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.21.0...v7.21.1) (2019-11-11)
## [7.21.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.21.0...v7.21.1) (2019-11-11)
@ -2187,7 +2234,7 @@ relative when priorities are ordinal
### [7.19.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.19.1...v7.19.2) (2019-10-28)
## [7.19.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.19.1...v7.19.2) (2019-10-28)
### Bug Fixes
@ -2196,7 +2243,7 @@ relative when priorities are ordinal
### [7.19.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.19.0...v7.19.1) (2019-10-25)
## [7.19.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.19.0...v7.19.1) (2019-10-25)
### Bug Fixes
@ -2219,7 +2266,7 @@ relative when priorities are ordinal
### [7.18.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.18.2...v7.18.3) (2019-10-23)
## [7.18.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.18.2...v7.18.3) (2019-10-23)
### Bug Fixes
@ -2228,11 +2275,11 @@ relative when priorities are ordinal
### [7.18.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.18.1...v7.18.2) (2019-10-20)
## [7.18.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.18.1...v7.18.2) (2019-10-20)
### [7.18.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.18.0...v7.18.1) (2019-10-20)
## [7.18.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.18.0...v7.18.1) (2019-10-20)
### Bug Fixes
@ -2256,7 +2303,7 @@ relative when priorities are ordinal
### [7.17.14](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.13...v7.17.14) (2019-10-17)
## [7.17.14](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.13...v7.17.14) (2019-10-17)
### Bug Fixes
@ -2265,7 +2312,7 @@ relative when priorities are ordinal
### [7.17.13](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.12...v7.17.13) (2019-10-17)
## [7.17.13](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.12...v7.17.13) (2019-10-17)
### Bug Fixes
@ -2274,11 +2321,11 @@ relative when priorities are ordinal
### [7.17.12](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.11...v7.17.12) (2019-10-17)
## [7.17.12](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.11...v7.17.12) (2019-10-17)
### [7.17.11](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.10...v7.17.11) (2019-10-16)
## [7.17.11](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.10...v7.17.11) (2019-10-16)
### Bug Fixes
@ -2287,7 +2334,7 @@ relative when priorities are ordinal
### [7.17.10](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.9...v7.17.10) (2019-10-16)
## [7.17.10](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.9...v7.17.10) (2019-10-16)
### Bug Fixes
@ -2296,7 +2343,7 @@ relative when priorities are ordinal
### [7.17.9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.8...v7.17.9) (2019-10-16)
## [7.17.9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.8...v7.17.9) (2019-10-16)
### Bug Fixes
@ -2305,7 +2352,7 @@ relative when priorities are ordinal
### [7.17.8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.7...v7.17.8) (2019-10-16)
## [7.17.8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.7...v7.17.8) (2019-10-16)
### Bug Fixes
@ -2314,7 +2361,7 @@ relative when priorities are ordinal
### [7.17.7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.6...v7.17.7) (2019-10-15)
## [7.17.7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.6...v7.17.7) (2019-10-15)
### Bug Fixes
@ -2323,7 +2370,7 @@ relative when priorities are ordinal
### [7.17.6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.5...v7.17.6) (2019-10-15)
## [7.17.6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.5...v7.17.6) (2019-10-15)
### Bug Fixes
@ -2332,7 +2379,7 @@ relative when priorities are ordinal
### [7.17.5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.4...v7.17.5) (2019-10-15)
## [7.17.5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.4...v7.17.5) (2019-10-15)
### Bug Fixes
@ -2341,7 +2388,7 @@ relative when priorities are ordinal
### [7.17.4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.3...v7.17.4) (2019-10-15)
## [7.17.4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.3...v7.17.4) (2019-10-15)
### Bug Fixes
@ -2350,11 +2397,11 @@ relative when priorities are ordinal
### [7.17.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.2...v7.17.3) (2019-10-14)
## [7.17.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.2...v7.17.3) (2019-10-14)
### [7.17.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.1...v7.17.2) (2019-10-14)
## [7.17.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.1...v7.17.2) (2019-10-14)
### Bug Fixes
@ -2363,7 +2410,7 @@ relative when priorities are ordinal
### [7.17.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.0...v7.17.1) (2019-10-14)
## [7.17.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.17.0...v7.17.1) (2019-10-14)
### Bug Fixes
@ -2401,7 +2448,7 @@ relative when priorities are ordinal
### [7.14.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.14.0...v7.14.1) (2019-10-13)
## [7.14.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.14.0...v7.14.1) (2019-10-13)
### Bug Fixes
@ -2490,7 +2537,7 @@ relative when priorities are ordinal
### [7.9.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.9.0...v7.9.1) (2019-10-07)
## [7.9.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.9.0...v7.9.1) (2019-10-07)
### Bug Fixes
@ -2508,7 +2555,7 @@ relative when priorities are ordinal
### [7.8.5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.8.4...v7.8.5) (2019-10-05)
## [7.8.5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.8.4...v7.8.5) (2019-10-05)
### Bug Fixes
@ -2517,7 +2564,7 @@ relative when priorities are ordinal
### [7.8.4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.8.3...v7.8.4) (2019-10-05)
## [7.8.4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.8.3...v7.8.4) (2019-10-05)
### Bug Fixes
@ -2526,7 +2573,7 @@ relative when priorities are ordinal
### [7.8.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.8.2...v7.8.3) (2019-10-05)
## [7.8.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.8.2...v7.8.3) (2019-10-05)
### Bug Fixes
@ -2535,7 +2582,7 @@ relative when priorities are ordinal
### [7.8.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.8.1...v7.8.2) (2019-10-04)
## [7.8.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.8.1...v7.8.2) (2019-10-04)
### Bug Fixes
@ -2544,7 +2591,7 @@ relative when priorities are ordinal
### [7.8.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.8.0...v7.8.1) (2019-10-04)
## [7.8.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.8.0...v7.8.1) (2019-10-04)
### Bug Fixes
@ -2597,7 +2644,7 @@ relative when priorities are ordinal
### [7.4.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.4.1...v7.4.2) (2019-10-01)
## [7.4.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.4.1...v7.4.2) (2019-10-01)
### Bug Fixes
@ -2606,7 +2653,7 @@ relative when priorities are ordinal
### [7.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.4.0...v7.4.1) (2019-10-01)
## [7.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.4.0...v7.4.1) (2019-10-01)
### Bug Fixes
@ -2624,7 +2671,7 @@ relative when priorities are ordinal
### [7.3.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.3.1...v7.3.2) (2019-10-01)
## [7.3.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.3.1...v7.3.2) (2019-10-01)
### Bug Fixes
@ -2634,7 +2681,7 @@ relative when priorities are ordinal
### [7.3.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.3.0...v7.3.1) (2019-09-30)
## [7.3.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.3.0...v7.3.1) (2019-09-30)
### Bug Fixes
@ -2657,7 +2704,7 @@ relative when priorities are ordinal
### [7.2.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.2.1...v7.2.2) (2019-09-30)
## [7.2.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.2.1...v7.2.2) (2019-09-30)
### Bug Fixes
@ -2666,7 +2713,7 @@ relative when priorities are ordinal
### [7.2.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.2.0...v7.2.1) (2019-09-28)
## [7.2.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.2.0...v7.2.1) (2019-09-28)
### Bug Fixes
@ -2691,7 +2738,7 @@ relative when priorities are ordinal
### [7.1.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.1.1...v7.1.2) (2019-09-26)
## [7.1.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.1.1...v7.1.2) (2019-09-26)
### Bug Fixes
@ -2700,7 +2747,7 @@ relative when priorities are ordinal
### [7.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.1.0...v7.1.1) (2019-09-26)
## [7.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.1.0...v7.1.1) (2019-09-26)
### Bug Fixes
@ -2767,7 +2814,7 @@ relative when priorities are ordinal
### [6.11.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v6.11.0...v6.11.1) (2019-09-17)
## [6.11.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v6.11.0...v6.11.1) (2019-09-17)
### Bug Fixes
@ -2916,7 +2963,7 @@ relative when priorities are ordinal
### [6.2.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v6.2.0...v6.2.1) (2019-09-04)
## [6.2.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v6.2.0...v6.2.1) (2019-09-04)
### Bug Fixes
@ -3050,7 +3097,7 @@ relative when priorities are ordinal
### [5.2.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v5.2.2...v5.2.3) (2019-08-22)
## [5.2.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v5.2.2...v5.2.3) (2019-08-22)
### Bug Fixes
@ -3059,11 +3106,11 @@ relative when priorities are ordinal
### [5.2.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v5.2.1...v5.2.2) (2019-08-22)
## [5.2.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v5.2.1...v5.2.2) (2019-08-22)
### [5.2.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v5.2.0...v5.2.1) (2019-08-21)
## [5.2.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v5.2.0...v5.2.1) (2019-08-21)
### Bug Fixes
@ -3103,7 +3150,7 @@ relative when priorities are ordinal
### [5.0.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v5.0.1...v5.0.2) (2019-08-13)
## [5.0.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v5.0.1...v5.0.2) (2019-08-13)
### Bug Fixes
@ -3112,7 +3159,7 @@ relative when priorities are ordinal
### [5.0.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v5.0.0...v5.0.1) (2019-08-12)
## [5.0.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v5.0.0...v5.0.1) (2019-08-12)
@ -3173,7 +3220,7 @@ them together now)
### [4.13.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v4.13.0...v4.13.1) (2019-08-07)
## [4.13.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v4.13.0...v4.13.1) (2019-08-07)
### Bug Fixes
@ -3193,7 +3240,7 @@ them together now)
### [4.12.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v4.12.0...v4.12.1) (2019-08-06)
## [4.12.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v4.12.0...v4.12.1) (2019-08-06)
### Bug Fixes
@ -3357,7 +3404,7 @@ them together now)
### [4.1.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v4.1.1...v4.1.2) (2019-07-17)
## [4.1.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v4.1.1...v4.1.2) (2019-07-17)
### Bug Fixes
@ -3366,7 +3413,7 @@ them together now)
### [4.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v4.1.0...v4.1.1) (2019-07-17)
## [4.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v4.1.0...v4.1.1) (2019-07-17)
### Bug Fixes
@ -3387,7 +3434,7 @@ them together now)
### [4.0.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v4.0.0...v4.0.1) (2019-07-16)
## [4.0.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v4.0.0...v4.0.1) (2019-07-16)
### Bug Fixes
@ -3437,7 +3484,7 @@ them together now)
### [2.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v2.1.0...v2.1.1) (2019-07-10)
## [2.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v2.1.0...v2.1.1) (2019-07-10)
### Bug Fixes
@ -3484,7 +3531,7 @@ them together now)
### [1.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v1.4.0...v1.4.1) (2019-07-04)
## [1.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v1.4.0...v1.4.1) (2019-07-04)

3
config/settings.yml
View File

@ -63,6 +63,9 @@ health-check-matching-cluster-config-timeout: "_env:HEALTHCHECK_MATCHING_CLUSTER
synchronise-ldap-users-within: "_env:SYNCHRONISE_LDAP_WITHIN:1209600"
synchronise-ldap-users-interval: "_env:SYNCHRONISE_LDAP_INTERVAL:3600"
study-features-recache-relevance-within: 172800
study-features-recache-relevance-interval: 293
log-settings:
detailed: "_env:DETAILED_LOGGING:false"
all: "_env:LOG_ALL:false"

11
hlint.sh
View File

@ -4,4 +4,15 @@ set -e
[ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || :
move-back() {
mv -v .stack-work .stack-work-test
[[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work
}
if [[ -d .stack-work-test ]]; then
[[ -d .stack-work ]] && mv -v .stack-work .stack-work-build
mv -v .stack-work-test .stack-work
trap move-back EXIT
fi
exec -- stack build --test --fast --flag uniworx:dev --flag uniworx:library-only uniworx:test:hlint

2
models/study-features.model
View File

@ -8,7 +8,7 @@ StudyFeatures -- multiple entries possible for students pursuing several degree
firstObserved UTCTime Maybe
lastObserved UTCTime default=now() -- last update from LDAP
valid Bool default=true
relevanceCached Bool default=false
relevanceCached UUID Maybe
UniqueStudyFeatures user degree field type semester
deriving Eq Show
-- UniqueUserSubject ubuser degree field -- There exists a counterexample

11
models/workflows.model
View File

@ -1,5 +1,10 @@
WorkflowDefinition
SharedWorkflowGraph
hash WorkflowGraphReference
graph (WorkflowGraph FileReference SqlBackendKey) -- UserId
Primary hash
WorkflowDefinition
graph SharedWorkflowGraphId
scope WorkflowScope'
name WorkflowDefinitionName
instanceCategory WorkflowInstanceCategory Maybe
@ -21,7 +26,7 @@ WorkflowDefinitionInstanceDescription
WorkflowInstance
definition WorkflowDefinitionId Maybe
graph (WorkflowGraph FileReference SqlBackendKey) -- UserId
graph SharedWorkflowGraphId
scope (WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey) -- TermId, SchoolId, CourseId
name WorkflowInstanceName
category WorkflowInstanceCategory Maybe
@ -37,5 +42,5 @@ WorkflowInstanceDescription
WorkflowWorkflow
instance WorkflowInstanceId Maybe
scope (WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey) -- TermId, SchoolId, CourseId
graph (WorkflowGraph FileReference SqlBackendKey) -- UserId
graph SharedWorkflowGraphId
state (WorkflowState FileReference SqlBackendKey) -- UserId

1324
package-lock.json generated
View File

File diff suppressed because it is too large Load Diff

13
package.json
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "23.6.0",
"version": "24.1.2",
"description": "",
"keywords": [],
"author": "",
@ -26,7 +26,8 @@
"i18n:test": "./missing-translations.sh",
"prerelease": "./is-clean.sh && npm run test",
"release": "standard-version -a",
"postrelease": "git push --follow-tags origin master"
"postrelease": "git push --follow-tags origin master",
"parse-changelog": "changelog-parser ./CHANGELOG.md > changelog.json"
},
"husky": {
"hooks": {
@ -42,7 +43,8 @@
},
"standard-version": {
"scripts": {
"postbump": "./sync-versions.hs && git add -- package.yaml"
"postbump": "./sync-versions.hs && git add -- package.yaml",
"postchangelog": "sed 's/^### \\[/## [/g' -i CHANGELOG.md"
},
"commitUrlFormat": "https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/{{hash}}",
"compareUrlFormat": "https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/{{previousTag}}...{{currentTag}}",
@ -70,6 +72,7 @@
"babel-plugin-transform-decorators-legacy": "^1.3.5",
"babel-preset-es2015": "^6.24.1",
"cbt_tunnels": "^1.2.2",
"changelog-parser": "^2.8.0",
"clean-webpack-plugin": "^3.0.0",
"copy-webpack-plugin": "^6.0.3",
"css-loader": "^2.1.1",
@ -104,13 +107,13 @@
"sass": "^1.26.10",
"sass-loader": "^7.3.1",
"semver": "^6.3.0",
"standard-version": "^9.0.0",
"standard-version": "^9.1.0",
"style-loader": "^0.23.1",
"terser-webpack-plugin": "^2.3.8",
"tmp": "^0.1.0",
"typeface-roboto": "0.0.75",
"typeface-source-sans-pro": "0.0.75",
"typeface-source-code-pro": "^1.1.3",
"typeface-source-sans-pro": "0.0.75",
"webpack": "^4.44.1",
"webpack-cli": "^3.3.12",
"webpack-manifest-plugin": "^2.2.0",

2
package.yaml
View File

@ -1,5 +1,5 @@
name: uniworx
version: 23.6.0
version: 24.1.2
dependencies:
- base

69
src/Application.hs
View File

@ -89,6 +89,7 @@ import Control.Concurrent.STM.Delay
import Control.Monad.Trans.Cont (runContT, callCC)
import qualified Data.Set as Set
import qualified Data.Map as Map
import Handler.Utils.Routes (classifyHandler)
@ -148,6 +149,7 @@ mkYesodDispatch "UniWorX" resourcesUniWorX
makeFoundation :: (MonadResource m, MonadUnliftIO m, MonadCatch m) => AppSettings -> m UniWorX
makeFoundation appSettings''@AppSettings{..} = do
registerGHCMetrics
registerHealthCheckInterval appHealthCheckInterval
-- Some basic initializations: HTTP connection manager, logger, and static
-- subsite.
@ -553,41 +555,46 @@ appMain = runResourceT $ do
Just wInterval
| maybe True (== myProcessID) watchdogProcess
-> let notifyWatchdog :: forall a m'. ( MonadLogger m', MonadIO m') => m' a
notifyWatchdog = go Nothing
where
go :: Maybe (Set (UTCTime, HealthReport)) -> m' a
go pResults = do
let delay = floor $ wInterval % 4
d <- liftIO $ newDelay delay
notifyWatchdog = forever' Nothing $ \pResults -> do
let delay = floor $ wInterval % 4
d <- liftIO $ newDelay delay
$logDebugS "Notify" $ "Waiting up to " <> tshow delay <> "µs..."
mResults <- atomically $ asum
[ pResults <$ waitDelay d
, do
results <- readTVar $ foundation ^. _appHealthReport
guardOn (pResults /= Just results) $ Just results
]
$logDebugS "Notify" $ "Waiting up to " <> tshow delay <> "µs..."
mResults <- atomically $ asum
[ pResults <$ waitDelay d
, do
results <- readTVar $ foundation ^. _appHealthReport
guardOn (pResults /= Just results) $ Just results
]
$logDebugS "Notify" "Checking for status/watchdog..."
mResults <$ do
void . runMaybeT $ do
results <- hoistMaybe mResults
$logDebugS "Notify" "Checking for status/watchdog..."
(*> go mResults) . void . runMaybeT $ do
results <- hoistMaybe mResults
let latestResults = Map.fromListWith (\_ x -> x) $ Set.toAscList results
Min status <- hoistMaybe $ ofoldMap1 (Min . healthReportStatus) <$> fromNullable latestResults
$logInfoS "NotifyStatus" $ toPathPiece status
liftIO . void . Systemd.notifyStatus . unpack $ toPathPiece status
Min status <- hoistMaybe $ ofoldMap1 (Min . healthReportStatus . view _2) <$> fromNullable results
$logInfoS "NotifyStatus" $ toPathPiece status
liftIO . void . Systemd.notifyStatus . unpack $ toPathPiece status
now <- liftIO getCurrentTime
let missing = flip ifoldMap (foundation ^. _appHealthCheckInterval) $ \hc mInterval -> fromMaybe mempty $ do
interval <- mInterval
let lastSuccess = maybeMonoid mResults
& Set.filter (\(_, rep) -> classifyHealthReport rep == hc)
& Set.filter (\(_, rep) -> healthReportStatus rep >= HealthSuccess)
& Set.mapMonotonic (view _1)
& Set.lookupMax
now <- liftIO getCurrentTime
iforM_ (foundation ^. _appHealthCheckInterval) . curry $ \case
(_, Nothing) -> return ()
(hc, Just interval) -> do
lastSuccess <- hoistMaybe $ results
& Set.filter (\(_, rep) -> classifyHealthReport rep == hc)
& Set.filter (\(_, rep) -> healthReportStatus rep >= HealthSuccess)
& Set.mapMonotonic (view _1)
& Set.lookupMax
guard $ lastSuccess > addUTCTime (negate interval) now
$logInfoS "NotifyWatchdog" "Notify"
liftIO $ void Systemd.notifyWatchdog
successIsCurrent = lastSuccess > Just (negate interval `addUTCTime` now)
return . guardMonoid (not successIsCurrent) $ Set.singleton hc
if | Set.null missing -> do
$logInfoS "NotifyWatchdog" "Notify"
liftIO $ void Systemd.notifyWatchdog
| otherwise ->
$logWarnS "NotifyWatchdog" $ "No notify; missing \n\t " <> tshow (toList missing) <> "\n\tin " <> tshow (toList <$> mResults)
in do
$logDebugS "Notify" "Spawning notify thread..."
void $ allocateLinkedAsync notifyWatchdog

21
src/Foundation/Authorization.hs
View File

@ -1254,7 +1254,7 @@ tagAccessPredicate AuthRegisterGroup = APDB $ \_ _ mAuthId route _ -> case route
return Authorized
r -> $unsupportedAuthPredicate AuthRegisterGroup r
tagAccessPredicate AuthEmpty = APDB $ \_ _ mAuthId route _
-> let workflowInstanceWorkflowsEmpty rScope win = selectLanguageI18n <=< $memcacheAuthHere' (Right diffDay) (mAuthId, route) . maybeT (unauthorizedI18n MsgUnauthorizedWorkflowWorkflowsNotEmpty) $ do
-> let workflowInstanceWorkflowsEmpty rScope win = selectLanguageI18n <=< $cachedHereBinary (mAuthId, route) . maybeT (unauthorizedI18n MsgUnauthorizedWorkflowWorkflowsNotEmpty) $ do
scope <- fromRouteWorkflowScope rScope
let dbScope = scope ^. _DBWorkflowScope
getWorkflowWorkflows = E.selectSource . E.from $ \(workflowWorkflow `E.InnerJoin` workflowInstance) -> do
@ -1416,9 +1416,8 @@ tagAccessPredicate AuthWorkflow = APDB $ \evalCtx eval' mAuthId route isWrite ->
wInitiate win rScope = selectLanguageI18n <=< $memcacheAuthHere' (Right diffDay) (evalCtx, route, mAuthId) . maybeT (unauthorizedI18n MsgUnauthorizedWorkflowInitiate) $ do -- @isWrite@ not included since it should make no difference regarding initiation (in the end that will always be a write)
scope <- MaybeT . $cachedHereBinary rScope . runMaybeT $ fromRouteWorkflowScope rScope
Entity _ WorkflowInstance{..} <- $cachedHereBinary (win, scope) . MaybeT . getBy . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope
wiGraph <- lift $ getSharedIdWorkflowGraph workflowInstanceGraph
let
wiGraph :: IdWorkflowGraph
wiGraph = _DBWorkflowGraph # workflowInstanceGraph
edges = do
WGN{..} <- wiGraph ^.. _wgNodes . folded
WorkflowGraphEdgeInitial{..} <- wgnEdges ^.. folded
@ -1434,11 +1433,9 @@ tagAccessPredicate AuthWorkflow = APDB $ \evalCtx eval' mAuthId route isWrite ->
(wwId, edges) <- memcacheAuth' (Right diffDay) (AuthCacheWorkflowWorkflowEdgeActors cID) $ do
wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId
wwGraph <- lift $ getSharedIdWorkflowGraph workflowWorkflowGraph
let
wwGraph :: IdWorkflowGraph
wwGraph = _DBWorkflowGraph # workflowWorkflowGraph
wwNode = wpTo $ last workflowWorkflowState
return . (wwId, ) . (Set.fromList :: _ -> Set (WorkflowRole UserId)) . foldMap toNullable $ do
@ -1455,11 +1452,9 @@ tagAccessPredicate AuthWorkflow = APDB $ \evalCtx eval' mAuthId route isWrite ->
(wwId, roles) <- memcacheAuth' (Right diffDay) (AuthCacheWorkflowWorkflowViewers cID) $ do
wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId
wwGraph <- lift $ getSharedIdWorkflowGraph workflowWorkflowGraph
let
wwGraph :: IdWorkflowGraph
wwGraph = _DBWorkflowGraph # workflowWorkflowGraph
nodeViewers = do
WorkflowAction{..} <- otoList workflowWorkflowState
(node, WGN{..}) <- itoListOf (_wgNodes . ifolded) wwGraph
@ -1483,9 +1478,7 @@ tagAccessPredicate AuthWorkflow = APDB $ \evalCtx eval' mAuthId route isWrite ->
wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt wwCID
WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId
stIx <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decryptWorkflowStateIndex wwId stCID
let
wwGraph :: IdWorkflowGraph
wwGraph = _DBWorkflowGraph # workflowWorkflowGraph
wwGraph <- lift $ getSharedIdWorkflowGraph workflowWorkflowGraph
act <- workflowStateIndex stIx $ _DBWorkflowState # workflowWorkflowState
let
cState = wpTo act
@ -1764,8 +1757,8 @@ mayViewWorkflowAction' eval mAuthId wwId WorkflowAction{..} = hoist (withReaderT
WorkflowWorkflow{..} <- MaybeT . lift $ get wwId
rScope <- hoist lift . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
cID <- hoist lift . catchMaybeT (Proxy @CryptoIDError) . lift $ encrypt wwId
let WorkflowGraph{..} = _DBWorkflowGraph # workflowWorkflowGraph
canonRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
WorkflowGraph{..} <- lift . lift $ getSharedIdWorkflowGraph workflowWorkflowGraph
let canonRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
evalWorkflowRole'' role = lift $ is _Authorized <$> evalWorkflowRoleFor' eval mAuthId (Just wwId) role canonRoute False
WorkflowNodeView{..} <- hoistMaybe $ Map.lookup wpTo wgNodes >>= wgnViewers
guardM $ orM

2
src/Foundation/Yesod/Auth.hs
View File

@ -352,7 +352,7 @@ upsertCampusUser upsertMode ldapData = do
, studyFeaturesFirstObserved = Just now
, studyFeaturesLastObserved = now
, studyFeaturesValid = True
, studyFeaturesRelevanceCached = False
, studyFeaturesRelevanceCached = Nothing
}
(sf :) <$> assimilateSubTerms subterms unusedFeats
Nothing

4
src/Foundation/Yesod/Middleware.hs
View File

@ -143,6 +143,7 @@ yesodMiddleware = cacheControlMiddleware . storeBearerMiddleware . csrfMiddlewar
MetricsR -> mzero
HealthR -> mzero
InstanceR -> mzero
AdminCrontabR -> mzero
_other -> return ()
reqHost <- MaybeT $ W.requestHeaderHost <$> waiRequest
@ -313,7 +314,8 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .
(_, WorkflowWorkflowR cID (WWFilesR wpl _)) <- hoistMaybe $ route ^? _WorkflowScopeRoute
wwId <- decrypt cID
WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId . lift $ get wwId
[wpl'] <- return . filter (== wpl) . sortOn (CI.original . unWorkflowPayloadLabel) . foldMap Map.keys $ wgnPayloadView <$> wgNodes workflowWorkflowGraph
wwGraph <- lift . lift $ getSharedDBWorkflowGraph workflowWorkflowGraph
[wpl'] <- return . filter (== wpl) . sortOn (CI.original . unWorkflowPayloadLabel) . foldMap Map.keys $ wgnPayloadView <$> wgNodes wwGraph
(caseChanged `on` unWorkflowPayloadLabel) wpl wpl'
return $ route
& typesUsing @RouteChildren @WorkflowPayloadLabel . filtered (== wpl) .~ wpl'

9
src/Handler/Admin/Crontab.hs
View File

@ -17,6 +17,8 @@ import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified Data.HashSet as HashSet
import qualified Data.HashMap.Strict as HashMap
import qualified Data.UUID as UUID
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1
@ -32,9 +34,12 @@ getAdminCrontabR = do
let mCrontab = mCrontab' <&> _2 %~ filter (hasn't $ _3 . _MatchNone)
instanceId <- getsYesod appInstanceID
selectRep $ do
provideRep $ do
crontabBearer <- runMaybeT . hoist runDB $ do
guardM $ hasGlobalGetParam GetGenerateToken
uid <- MaybeT maybeAuthId
guardM . lift . existsBy $ UniqueUserGroupMember UserGroupCrontab uid
@ -49,6 +54,10 @@ getAdminCrontabR = do
<section>
<pre .token>
#{toPathPiece t}
<section>
<dl .deflist>
<dt .deflist__dt>_{MsgInstanceId}
<dd .deflist__dd .uuid>#{UUID.toText instanceId}
<section>
$maybe (genTime, crontab) <- mCrontab
<p>

94
src/Handler/ExamOffice/Exams.hs
View File

@ -15,6 +15,8 @@ import qualified Database.Esqueleto.Utils as E
import qualified Colonnade
import qualified Data.Conduit.Combinators as C
type ExamsTableExpr = ( E.SqlExpr (Maybe (Entity Exam))
`E.InnerJoin` E.SqlExpr (Maybe (Entity Course))
@ -38,54 +40,6 @@ querySchool = to $ $(E.sqlIJproj 3 3) . $(E.sqlFOJproj 2 1)
queryExternalExam :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity ExternalExam)))
queryExternalExam = to $(E.sqlFOJproj 2 2)
querySynchronised :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Word64))
querySynchronised office = to . runReader $ do
exam' <- view queryExam
externalExam' <- view queryExternalExam
let
examSynchronised examId = E.subSelectCount . E.from $ \examResult -> do
E.where_ $ examResult E.^. ExamResultExam E.==. examId
E.where_ $ Exam.examOfficeExamResultAuth office examResult
E.where_ $ Exam.resultIsSynced office examResult
externalExamSynchronised externalExamId = E.subSelectCount . E.from $ \externalExamResult -> do
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. externalExamId
E.where_ $ ExternalExam.examOfficeExternalExamResultAuth office externalExamResult
E.where_ $ ExternalExam.resultIsSynced office externalExamResult
return $ E.maybe (E.val 0) examSynchronised (exam' E.?. ExamId) E.+. E.maybe (E.val 0) externalExamSynchronised (externalExam' E.?. ExternalExamId)
queryResults :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Word64))
queryResults office = to . runReader $ do
exam' <- view queryExam
externalExam' <- view queryExternalExam
let
results examId = E.subSelectCount . E.from $ \examResult -> do
E.where_ $ examResult E.^. ExamResultExam E.==. examId
E.where_ $ Exam.examOfficeExamResultAuth office examResult
externalResults externalExamId = E.subSelectCount . E.from $ \externalExamResult -> do
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. externalExamId
E.where_ $ ExternalExam.examOfficeExternalExamResultAuth office externalExamResult
return $ E.maybe (E.val 0) results (exam' E.?. ExamId) E.+. E.maybe (E.val 0) externalResults (externalExam' E.?. ExternalExamId)
queryIsSynced :: UTCTime -> E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Bool))
queryIsSynced now office = to . runReader $ do
exam' <- view queryExam
externalExam' <- view queryExternalExam
school' <- view querySchool
let
examSynchronised examId = E.not_ . E.exists . E.from $ \examResult -> do
E.where_ $ examResult E.^. ExamResultExam E.==. examId
E.where_ $ Exam.examOfficeExamResultAuth office examResult
E.where_ . E.not_ $ Exam.resultIsSynced office examResult
externalExamSynchronised externalExamId = E.not_ . E.exists . E.from $ \externalExamResult -> do
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. externalExamId
E.where_ $ ExternalExam.examOfficeExternalExamResultAuth office externalExamResult
E.where_ . E.not_ $ ExternalExam.resultIsSynced office externalExamResult
open examClosed' examFinished'
= E.bool (E.maybe E.true (E.>. E.val now) $ E.min examClosed' examFinished')
(E.maybe E.true (E.>. E.val now) examClosed')
(E.maybe E.false (E.==. E.val ExamCloseSeparate) (school' E.?. SchoolExamCloseMode))
return $ E.maybe E.false examSynchronised (exam' E.?. ExamId) E.||. E.maybe2 E.false open (exam' E.?. ExamClosed) (exam' E.?. ExamFinished) E.||. E.maybe E.false externalExamSynchronised (externalExam' E.?. ExternalExamId)
resultExam :: Traversal' ExamsTableData (Entity Exam)
resultExam = _dbrOutput . _1 . _Right . _1
@ -128,10 +82,6 @@ getEOExamsR = do
externalExamLink ExternalExam{..}
= SomeRoute $ EExamR externalExamTerm externalExamSchool externalExamCourseName externalExamExamName EEGradesR
querySynchronised' = querySynchronised $ E.val uid
queryResults' = queryResults $ E.val uid
queryIsSynced' = queryIsSynced now $ E.val uid
examsDBTable = DBTable{..}
where
dbtSQLQuery = runReaderT $ do
@ -140,19 +90,15 @@ getEOExamsR = do
school <- view querySchool
externalExam <- view queryExternalExam
synchronised <- view querySynchronised'
results <- view queryResults'
lift $ do
E.on E.false
E.on $ school E.?. SchoolId E.==. course E.?. CourseSchool
E.on $ exam E.?. ExamCourse E.==. course E.?. CourseId
E.where_ $ results E.>. E.val 0
E.where_ $ (E.not_ (E.isNothing $ exam E.?. ExamId) E.&&. E.not_ (E.isNothing $ course E.?. CourseId) E.&&. E.isNothing (externalExam E.?. ExternalExamId))
E.||. ( E.isNothing (exam E.?. ExamId) E.&&. E.isNothing (course E.?. CourseId) E.&&. E.not_ (E.isNothing $ externalExam E.?. ExternalExamId))
return (exam, course, school, externalExam, synchronised, results)
return (exam, course, school, externalExam)
dbtRowKey = views ($(multifocusG 2) queryExam queryExternalExam) (bimap (E.?. ExamId) (E.?. ExternalExamId))
dbtProj :: DBRow _ -> DB ExamsTableData
@ -162,11 +108,24 @@ getEOExamsR = do
school <- view _3
externalExam <- view _4
let
getExamResults = for_ exam $ \(Entity examId _) -> E.selectSource . E.from $ \examResult -> do
E.where_ $ examResult E.^. ExamResultExam E.==. E.val examId
E.where_ $ Exam.examOfficeExamResultAuth (E.val uid) examResult
return $ Exam.resultIsSynced (E.val uid) examResult
getExternalExamResults = for_ externalExam $ \(Entity externalExamId _) -> E.selectSource . E.from $ \externalExamResult -> do
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. E.val externalExamId
E.where_ $ ExternalExam.examOfficeExternalExamResultAuth (E.val uid) externalExamResult
return $ ExternalExam.resultIsSynced (E.val uid) externalExamResult
getResults = getExamResults >> getExternalExamResults
foldResult (E.Value isSynced) = (Sum 1, guardMonoid isSynced $ Sum 1)
(Sum resultCount, Sum syncedCount) <- lift . runConduit $ getResults .| C.foldMap foldResult
case (exam, course, school, externalExam) of
(Just exam', Just course', Just school', Nothing) ->
(Right (exam', course', school'),,) <$> view (_5 . _Value . _Integral) <*> view (_6 . _Value . _Integral)
(Nothing, Nothing, Nothing, Just externalExam') ->
(Left externalExam',,) <$> view (_5 . _Value . _Integral) <*> view (_6 . _Value . _Integral)
(Just exam', Just course', Just school', Nothing) -> return
(Right (exam', course', school'), syncedCount, resultCount)
(Nothing, Nothing, Nothing, Just externalExam') -> return
(Left externalExam', syncedCount, resultCount)
_other -> return $ error "Got exam & externalExam in same result"
@ -216,8 +175,10 @@ getEOExamsR = do
, emptyOpticColonnade (resultCourse . _entityVal . _courseTerm <> resultExternalExam . _entityVal . _externalExamTerm) colTermShort
]
dbtSorting = mconcat
[ singletonMap "synced" . SortColumn $ (E./.) <$> view querySynchronised' <*> view queryResults'
, singletonMap "is-synced" . SortColumn $ view queryIsSynced'
[ singletonMap "synced" $
SortProjected . comparing $ ((/) `on` toRational) <$> view resultSynchronised <*> view resultResults
, singletonMap "is-synced" $
SortProjected . comparing $ (>=) <$> view resultSynchronised <*> view resultResults
, sortExamName (to $ E.unsafeCoalesce . sequence [views queryExam (E.?. ExamName), views queryExternalExam (E.?. ExternalExamExamName)])
, sortExamTime (queryExam . $(multifocusG 2) (to $ E.joinV . (E.?. ExamStart)) (to $ E.joinV . (E.?. ExamEnd)))
, sortExamFinished (queryExam . to (E.joinV . (E.?. ExamFinished)))
@ -236,12 +197,14 @@ getEOExamsR = do
-> hasReadAccessTo . urlRoute $ externalExamLink eexam :: DB Bool
| otherwise
-> return $ error "Got neither exam nor externalExam in result"
, singletonMap "has-results" . FilterProjected $ \(Any b) r -> (return $ b == (r ^. resultResults > 0) :: DB Bool)
, singletonMap "is-synced" . FilterProjected $ \(Any b) r -> (return $ b == (r ^. resultSynchronised >= r ^. resultResults) :: DB Bool)
]
dbtFilterUI = mconcat
[
[ flip (prismAForm $ singletonFilter "is-synced" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamSynchronised)
]
dbtStyle = def -- { dbsFilterLayout = defaultDBSFilterLayout }
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = def
dbtIdent :: Text
@ -255,6 +218,7 @@ getEOExamsR = do
examsDBTableValidator = def
& defaultSorting [SortAscBy "is-synced", SortAscBy "exam-time"]
& forceFilter "may-access" (Any True)
& forceFilter "has-results" (Any True)
dbTableWidget' examsDBTableValidator examsDBTable

1
src/Handler/Metrics.hs
View File

@ -26,6 +26,7 @@ getMetricsR = selectRep $ do
samples <- sortBy metricSort <$> collectMetrics
metricsBearer <- runMaybeT . hoist runDB $ do
guardM $ hasGlobalGetParam GetGenerateToken
uid <- MaybeT maybeAuthId
guardM . lift . existsBy $ UniqueUserGroupMember UserGroupMetrics uid

34
src/Handler/Utils/StudyFeatures.hs
View File

@ -30,6 +30,8 @@ import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.PostgreSQL as E
import qualified Database.Esqueleto.Utils as E
import qualified Data.Conduit.Combinators as C
data UserTableStudyFeature = UserTableStudyFeature
{ userTableField
@ -114,20 +116,16 @@ isRelevantStudyFeature termField record studyFeatures
E.&&. overlap studyFeatures' E.>. overlap studyFeatures
isRelevantStudyFeatureCached :: PersistEntity record
=> EntityField record TermId
-> E.SqlExpr (Entity record)
-> E.SqlExpr (Entity StudyFeatures)
-> E.SqlExpr (E.Value Bool)
=> EntityField record TermId
-> E.SqlExpr (Entity record)
-> E.SqlExpr (Entity StudyFeatures)
-> E.SqlExpr (E.Value Bool)
isRelevantStudyFeatureCached termField record studyFeatures
= E.bool calcNow useCache $ studyFeatures E.^. StudyFeaturesRelevanceCached
where
useCache
= E.exists . E.from $ \relevantStudyFeatures ->
E.where_ $ relevantStudyFeatures E.^. RelevantStudyFeaturesTerm E.==. record E.^. termField
E.&&. relevantStudyFeatures E.^. RelevantStudyFeaturesStudyFeatures E.==. studyFeatures E.^. StudyFeaturesId
calcNow = isRelevantStudyFeature termField record studyFeatures
= E.exists . E.from $ \relevantStudyFeatures ->
E.where_ $ relevantStudyFeatures E.^. RelevantStudyFeaturesTerm E.==. record E.^. termField
E.&&. relevantStudyFeatures E.^. RelevantStudyFeaturesStudyFeatures E.==. studyFeatures E.^. StudyFeaturesId
cacheStudyFeatureRelevance :: MonadIO m
cacheStudyFeatureRelevance :: MonadResource m
=> (E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool))
-> SqlPersistT m ()
cacheStudyFeatureRelevance fFilter = do
@ -139,9 +137,15 @@ cacheStudyFeatureRelevance fFilter = do
return $ RelevantStudyFeatures E.<# (term E.^. TermId) E.<&> (studyFeatures E.^. StudyFeaturesId)
)
( \_current _excluded -> [] )
E.update $ \studyFeatures -> do
E.set studyFeatures [ StudyFeaturesRelevanceCached E.=. E.true ]
E.where_ $ fFilter studyFeatures
let getStudyFeatures = E.selectSource . E.from $ \studyFeatures -> do
E.where_ $ fFilter studyFeatures
E.where_ . E.isNothing $ studyFeatures E.^. StudyFeaturesRelevanceCached
return $ studyFeatures E.^. StudyFeaturesId
migrateStudyFeatures genUUID lift' (E.Value sfId) = do
uuid <- genUUID
lift' $ update sfId [ StudyFeaturesRelevanceCached =. Just uuid ]
in runConduit $ getStudyFeatures .| randUUIDC (\genUUID lift' -> C.mapM_ $ migrateStudyFeatures genUUID lift')
isCourseStudyFeature :: E.SqlExpr (Entity Course) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool)
isCourseStudyFeature = isRelevantStudyFeatureCached CourseTerm

2
src/Handler/Utils/StudyFeatures/Parse.hs
View File

@ -43,7 +43,7 @@ pStudyFeatures studyFeaturesUser now = do
studyFeaturesSuperField = Nothing
studyFeaturesFirstObserved = Just now
studyFeaturesLastObserved = now
studyFeaturesRelevanceCached = False
studyFeaturesRelevanceCached = Nothing
return StudyFeatures{..}
pStudyFeature `sepBy1` char '#'

2
src/Handler/Utils/Users.hs
View File

@ -758,7 +758,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
, StudyFeaturesFirstObserved =. (min `on` studyFeaturesFirstObserved) oldStudyFeatures newStudyFeatures
, StudyFeaturesLastObserved =. (max `on` studyFeaturesLastObserved) oldStudyFeatures newStudyFeatures
, StudyFeaturesValid =. ((||) `on` studyFeaturesValid) oldStudyFeatures newStudyFeatures
, StudyFeaturesRelevanceCached =. ((||) `on` studyFeaturesRelevanceCached) oldStudyFeatures newStudyFeatures
, StudyFeaturesRelevanceCached =. ((<|>) `on` studyFeaturesRelevanceCached) oldStudyFeatures newStudyFeatures
]
E.insertSelectWithConflict
UniqueRelevantStudyFeatures

17
src/Handler/Utils/Workflow/EdgeForm.hs
View File

@ -81,14 +81,15 @@ workflowEdgeForm mwwId mPrev = runMaybeT $ do
MsgRenderer mr <- getMsgRenderer
ctx' <- bitraverse (MaybeT . getEntity) (MaybeT . getEntity) mwwId
let (scope, graph) = case ctx of
Left WorkflowInstance{..} -> ( _DBWorkflowScope # workflowInstanceScope
, _DBWorkflowGraph # workflowInstanceGraph
)
Right WorkflowWorkflow{..} -> ( _DBWorkflowScope # workflowWorkflowScope
, _DBWorkflowGraph # workflowWorkflowGraph
)
wState = ctx ^? _Right . _workflowWorkflowState . to last . _wpTo
let (scope, sharedGraphId) = case ctx' of
Left (Entity _ WorkflowInstance{..}) -> ( _DBWorkflowScope # workflowInstanceScope
, workflowInstanceGraph
)
Right (Entity _ WorkflowWorkflow{..}) -> ( _DBWorkflowScope # workflowWorkflowScope
, workflowWorkflowGraph
)
graph <- lift $ getSharedIdWorkflowGraph sharedGraphId
let wState = ctx ^? _Right . _workflowWorkflowState . to last . _wpTo
wPayload' = ctx ^? _Right . _workflowWorkflowState . re _DBWorkflowState
ctx = bimap entityVal entityVal ctx'
mAuthId <- maybeAuthId

6
src/Handler/Workflow/Definition/Edit.hs
View File

@ -5,6 +5,7 @@ module Handler.Workflow.Definition.Edit
) where
import Import
import Utils.Workflow
import Handler.Utils
import Handler.Workflow.Definition.Form
@ -29,7 +30,7 @@ postAWDEditR wds' wdn = do
| Entity _ WorkflowDefinitionInstanceDescription{..} <- iDescs
]
wdfGraph <- toWorkflowGraphForm workflowDefinitionGraph
wdfGraph <- toWorkflowGraphForm =<< getSharedDBWorkflowGraph workflowDefinitionGraph
return WorkflowDefinitionForm
{ wdfScope = workflowDefinitionScope
@ -44,9 +45,10 @@ postAWDEditR wds' wdn = do
act <- formResultMaybe editRes $ \WorkflowDefinitionForm{..} -> do
wdfGraph' <- fromWorkflowGraphForm wdfGraph
wdfGraph'' <- insertSharedWorkflowGraph wdfGraph'
insConflict <- replaceUnique wdId WorkflowDefinition
{ workflowDefinitionGraph = wdfGraph'
{ workflowDefinitionGraph = wdfGraph''
, workflowDefinitionScope = wdfScope
, workflowDefinitionName = wdfName
, workflowDefinitionInstanceCategory = wdfInstanceCategory

4
src/Handler/Workflow/Definition/Instantiate.hs
View File

@ -3,6 +3,7 @@ module Handler.Workflow.Definition.Instantiate
) where
import Import
import Utils.Workflow
import Handler.Utils
import Handler.Utils.Workflow.Form
@ -22,9 +23,10 @@ postAWDInstantiateR wds' wdn = do
& over _wisTerm unTermKey
& over _wisSchool unSchoolKey
& over _wisCourse (view _SqlKey)
workflowInstanceGraph <- insertSharedWorkflowGraph wifGraph'
instId <- insertUnique WorkflowInstance
{ workflowInstanceDefinition = Just wdId
, workflowInstanceGraph = wifGraph'
, workflowInstanceGraph
, workflowInstanceScope = wifScope'
, workflowInstanceName = wifName
, workflowInstanceCategory = wifCategory

4
src/Handler/Workflow/Definition/New.hs
View File

@ -5,6 +5,7 @@ module Handler.Workflow.Definition.New
import Import
import Handler.Utils
import Handler.Workflow.Definition.Form
import Utils.Workflow
getAdminWorkflowDefinitionNewR, postAdminWorkflowDefinitionNewR :: Handler Html
@ -15,9 +16,10 @@ postAdminWorkflowDefinitionNewR = do
act <- formResultMaybe newRes $ \WorkflowDefinitionForm{ .. } -> do
wdfGraph' <- fromWorkflowGraphForm wdfGraph
workflowDefinitionGraph <- insertSharedWorkflowGraph wdfGraph'
insRes <- insertUnique WorkflowDefinition
{ workflowDefinitionGraph = wdfGraph'
{ workflowDefinitionGraph
, workflowDefinitionScope = wdfScope
, workflowDefinitionName = wdfName
, workflowDefinitionInstanceCategory = wdfInstanceCategory

2
src/Handler/Workflow/Instance/Form.hs
View File

@ -64,7 +64,7 @@ workflowInstanceForm forcedDefId template = renderWForm FormStandard $ do
[ (workflowDefinitionInstanceDescriptionLanguage, (workflowDefinitionInstanceDescriptionTitle, workflowDefinitionInstanceDescriptionDescription))
| Entity _ WorkflowDefinitionInstanceDescription{..} <- descs
]
defGraph <- for defEnt $ toWorkflowGraphForm . workflowDefinitionGraph . entityVal
defGraph <- for defEnt $ toWorkflowGraphForm <=< lift . lift . getSharedDBWorkflowGraph . workflowDefinitionGraph . entityVal
wifScopeRes <- aFormToWForm . hoistAForm lift $ workflowInstanceScopeForm (workflowDefinitionScope . entityVal <$> defEnt) (fslI MsgWorkflowScope) (wifScope <$> template)
wifNameRes <- wreq ciField (fslI MsgWorkflowInstanceName) (fmap wifName template <|> fmap (workflowDefinitionName . entityVal) defEnt)

3
src/Handler/Workflow/Instance/Initiate.hs
View File

@ -45,7 +45,8 @@ workflowInstanceInitiateR rScope win = do
((edgeRes, edgeView), edgeEnc) <- liftHandler . runFormPost $ renderAForm FormStandard edgeForm
edgeAct <- formResultMaybe edgeRes $ \edgeRes' -> do
workflowWorkflowState <- view _DBWorkflowState <$> followEdge (_DBWorkflowGraph # workflowInstanceGraph) edgeRes' Nothing
wGraph <- getSharedIdWorkflowGraph workflowInstanceGraph
workflowWorkflowState <- view _DBWorkflowState <$> followEdge wGraph edgeRes' Nothing
wwId <- insert WorkflowWorkflow
{ workflowWorkflowInstance = Just wiId

3
src/Handler/Workflow/Instance/New.hs
View File

@ -25,13 +25,14 @@ adminWorkflowInstanceNewR wdId = do
act <- formResultMaybe instRes $ \WorkflowInstanceForm{..} -> do
wifGraph' <- fromWorkflowGraphForm wifGraph
workflowInstanceGraph <- insertSharedWorkflowGraph wifGraph'
let wifScope' = wifScope
& over _wisTerm unTermKey
& over _wisSchool unSchoolKey
& over _wisCourse (view _SqlKey)
instId <- insertUnique WorkflowInstance
{ workflowInstanceDefinition = wdId
, workflowInstanceGraph = wifGraph'
, workflowInstanceGraph
, workflowInstanceScope = wifScope'
, workflowInstanceName = wifName
, workflowInstanceCategory = wifCategory

8
src/Handler/Workflow/Workflow/List.hs
View File

@ -231,8 +231,8 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do
MaybeT $ selectWorkflowInstanceDescription wiId
cID <- encrypt wwId
rScope <- lift . runMaybeT . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
let WorkflowGraph{..} = ww ^. _entityVal . _workflowWorkflowGraph . from _DBWorkflowGraph
hasWorkflowRole' :: WorkflowRole UserId -> DB Bool
WorkflowGraph{..} <- lift . getSharedIdWorkflowGraph $ ww ^. _entityVal . _workflowWorkflowGraph
let hasWorkflowRole' :: WorkflowRole UserId -> DB Bool
hasWorkflowRole' role = maybeT (return False) $ do
rScope' <- hoistMaybe rScope
let canonRoute = _WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR)
@ -360,6 +360,8 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do
jwiScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope
let jwiName = workflowInstanceName
return JsonWorkflowInstance{..}
let Entity _ WorkflowWorkflow{..} = res ^. resultWorkflowWorkflow
WorkflowGraph{..} <- getSharedIdWorkflowGraph workflowWorkflowGraph
(fmap getLast -> wState) <-
let go :: forall m.
( MonadHandler m
@ -410,9 +412,7 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do
tell . Just $ Last (stCID, nTo, aUser, wpTime, payload)
Entity _ WorkflowWorkflow{..} = res ^. resultWorkflowWorkflow
wState = review _DBWorkflowState workflowWorkflowState
WorkflowGraph{..} = _DBWorkflowGraph # workflowWorkflowGraph
in runConduit $ sourceWorkflowActionInfos wwId wState .| execWriterC (C.mapM_ go)
let jwwLastAction = wState <&> \(jwaIx, jwaTo, jwaUser, jwaTime, _) -> JsonWorkflowAction{..}

2
src/Handler/Workflow/Workflow/Workflow.hs
View File

@ -83,8 +83,8 @@ workflowR rScope cID = do
WorkflowWorkflow{..} <- get404 wwId
maybeT notFound . void . assertM (== review _DBWorkflowScope workflowWorkflowScope) $ fromRouteWorkflowScope rScope
mEdgeForm <- workflowEdgeForm (Right wwId) Nothing
wGraph <- getSharedIdWorkflowGraph workflowWorkflowGraph
let canonRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
wGraph = _DBWorkflowGraph # workflowWorkflowGraph
mEdge <- for mEdgeForm $ \edgeForm -> do
((edgeRes, edgeView), edgeEnc) <- liftHandler . runFormPost $ renderAForm FormStandard edgeForm

111
src/Jobs.hs
View File

@ -10,6 +10,7 @@ module Jobs
import Import hiding (StateT)
import Jobs.Types as Types hiding (JobCtl(JobCtlQueue))
import Jobs.Queue
import Jobs.Offload
import Jobs.Crontab
import qualified Data.Conduit.List as C
@ -64,6 +65,7 @@ import Jobs.Handler.Files
import Jobs.Handler.ExternalApis
import Jobs.Handler.PersonalisedSheetFiles
import Jobs.Handler.PruneOldSentMails
import Jobs.Handler.StudyFeatures
import Jobs.HealthReport
@ -106,6 +108,7 @@ handleJobs foundation@UniWorX{..}
jobShutdown <- liftIO newEmptyTMVarIO
jobCurrentCrontab <- liftIO $ newTVarIO Nothing
jobHeldLocks <- liftIO $ newTVarIO Set.empty
jobOffload <- liftIO newEmptyTMVarIO
registerJobHeldLocksCount jobHeldLocks
registerJobWorkerQueueDepth appJobState
atomically $ putTMVar appJobState JobState
@ -156,7 +159,9 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc ->
atomically . asum $
[ spawnMissingWorkers
, reapDeadWorkers
] ++ maybe [] (\(cTime, delay) -> [return () <$ waitDelay delay, transferJobs cTime]) transferInfo ++
] ++ maybe [] (\(cTime, delay) -> [return () <$ waitDelay delay, transferJobs cTime]) transferInfo
++ maybeToList (manageOffloadHandler <$> mkJobOffloadHandler (appDatabaseConf appSettings') (appJobMode appSettings'))
++
[ terminateGracefully terminate'
]
where
@ -287,6 +292,27 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc ->
return $ $logWarnS "JobPoolManager" [st|Moved #{tshow (olength movePairs)} long-unadressed jobs from #{tshow (olength senders)} senders to #{tshow (olength receivers)} receivers|]
manageOffloadHandler :: ReaderT UniWorX m JobOffloadHandler -> STM (ContT () m ())
manageOffloadHandler spawn = do
shouldTerminate' <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown
guard $ not shouldTerminate'
JobContext{jobOffload} <- jobContext <$> readTMVar appJobState
cOffload <- tryReadTMVar jobOffload
let respawn = do
nOffload <- lift $ runReaderT spawn foundation
atomically $ do
putTMVar jobOffload nOffload
whenIsJust cOffload $ \pOffload -> do
pOutgoing <- readTVar $ jobOffloadOutgoing pOffload
modifyTVar (jobOffloadOutgoing nOffload) (pOutgoing <>)
respawn <$ case cOffload of
Nothing -> return ()
Just JobOffloadHandler{..} -> waitSTM jobOffloadHandler
stopJobCtl :: MonadUnliftIO m => UniWorX -> m ()
-- ^ Stop all worker threads currently running
stopJobCtl UniWorX{appJobState} = do
@ -472,46 +498,55 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker
$logDebugS logIdent "JobCtlQueue..."
lift $ queueJob' job
$logInfoS logIdent "JobCtlQueue"
handleCmd (JobCtlPerform jId) = handle handleQueueException . jLocked jId $ \(Entity _ j@QueuedJob{..}) -> lift $ do
content <- case fromJSON queuedJobContent of
Aeson.Success c -> return c
Aeson.Error t -> do
$logErrorS logIdent $ "Aeson decoding error: " <> pack t
throwM $ JInvalid jId j
$logInfoS logIdent $ tshow content
$logDebugS logIdent . LT.toStrict . decodeUtf8 $ Aeson.encode content
handleCmd (JobCtlPerform jId) = do
jMode <- getsYesod $ view _appJobMode
case jMode of
JobsLocal{} -> performLocal
JobsOffload -> performOffload
where
performOffload = hoist atomically $ do
JobOffloadHandler{..} <- lift . readTMVar =<< asks jobOffload
lift $ modifyTVar jobOffloadOutgoing (`snoc` jId)
performLocal = handle handleQueueException . jLocked jId $ \(Entity _ j@QueuedJob{..}) -> lift $ do
content <- case fromJSON queuedJobContent of
Aeson.Success c -> return c
Aeson.Error t -> do
$logErrorS logIdent $ "Aeson decoding error: " <> pack t
throwM $ JInvalid jId j
instanceID' <- getsYesod $ view instanceID
now <- liftIO getCurrentTime
$logInfoS logIdent $ tshow content
$logDebugS logIdent . LT.toStrict . decodeUtf8 $ Aeson.encode content
let cleanup = do
when queuedJobWriteLastExec $
void $ upsertBy
(UniqueCronLastExec queuedJobContent)
CronLastExec
{ cronLastExecJob = queuedJobContent
, cronLastExecTime = now
, cronLastExecInstance = instanceID'
}
[ CronLastExecTime =. now
, CronLastExecInstance =. instanceID'
]
delete jId
instanceID' <- getsYesod $ view instanceID
now <- liftIO getCurrentTime
case performJob content of
JobHandlerAtomic act -> runDBJobs . setSerializableBatch $ do
act & withJobWorkerState wNum (JobWorkerExecJob content)
hoist lift cleanup
JobHandlerException act -> do
act & withJobWorkerState wNum (JobWorkerExecJob content)
runDB $ setSerializableBatch cleanup
JobHandlerAtomicWithFinalizer act fin -> do
res <- runDBJobs . setSerializableBatch $ do
res <- act & withJobWorkerState wNum (JobWorkerExecJob content)
hoist lift cleanup
return res
fin res
let cleanup = do
when queuedJobWriteLastExec $
void $ upsertBy
(UniqueCronLastExec queuedJobContent)
CronLastExec
{ cronLastExecJob = queuedJobContent
, cronLastExecTime = now
, cronLastExecInstance = instanceID'
}
[ CronLastExecTime =. now
, CronLastExecInstance =. instanceID'
]
delete jId
case performJob content of
JobHandlerAtomic act -> runDBJobs . setSerializableBatch $ do
act & withJobWorkerState wNum (JobWorkerExecJob content)
hoist lift cleanup
JobHandlerException act -> do
act & withJobWorkerState wNum (JobWorkerExecJob content)
runDB $ setSerializableBatch cleanup
JobHandlerAtomicWithFinalizer act fin -> do
res <- runDBJobs . setSerializableBatch $ do
res <- act & withJobWorkerState wNum (JobWorkerExecJob content)
hoist lift cleanup
return res
fin res
handleCmd JobCtlDetermineCrontab = do
$logDebugS logIdent "DetermineCrontab..."
newCTab <- liftHandler . runDB $ setSerializableBatch determineCrontab'

846
src/Jobs/Crontab.hs
View File

@ -27,17 +27,6 @@ determineCrontab :: DB (Crontab JobCtl)
determineCrontab = execWriterT $ do
UniWorX{ appSettings' = AppSettings{..} } <- getYesod
case appJobFlushInterval of
Just interval -> tell $ HashMap.singleton
JobCtlFlush
Cron
{ cronInitial = CronAsap
, cronRepeat = CronRepeatScheduled CronAsap
, cronRateLimit = interval
, cronNotAfter = Right CronNotScheduled
}
Nothing -> return ()
whenIsJust appJobCronInterval $ \interval ->
tell $ HashMap.singleton
JobCtlDetermineCrontab
@ -48,77 +37,6 @@ determineCrontab = execWriterT $ do
, cronNotAfter = Right CronNotScheduled
}
oldestInvitationMUTC <- lift $ preview (_head . _entityVal . _invitationExpiresAt . _Just) <$> selectList [InvitationExpiresAt !=. Nothing] [Asc InvitationExpiresAt, LimitTo 1]
whenIsJust oldestInvitationMUTC $ \oldestInvUTC -> tell $ HashMap.singleton
(JobCtlQueue JobPruneInvitations)
Cron
{ cronInitial = CronTimestamp $ utcToLocalTime oldestInvUTC
, cronRepeat = CronRepeatOnChange
, cronRateLimit = nominalDay
, cronNotAfter = Right CronNotScheduled
}
oldestSessionFile <- lift $ preview (_head . _entityVal . _sessionFileTouched) <$> selectList [] [Asc SessionFileTouched, LimitTo 1]
whenIsJust oldestSessionFile $ \oldest -> tell $ HashMap.singleton
(JobCtlQueue JobPruneSessionFiles)
Cron
{ cronInitial = CronTimestamp . utcToLocalTime $ addUTCTime appSessionFilesExpire oldest
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appSessionFilesExpire / 2
, cronNotAfter = Right CronNotScheduled
}
oldestFallbackPersonalisedSheetFilesKey <- lift $ preview (_head . _entityVal . _fallbackPersonalisedSheetFilesKeyGenerated) <$> selectList [] [Asc FallbackPersonalisedSheetFilesKeyGenerated, LimitTo 1]
whenIsJust oldestFallbackPersonalisedSheetFilesKey $ \oldest -> tell $ HashMap.singleton
(JobCtlQueue JobPruneFallbackPersonalisedSheetFilesKeys)
Cron
{ cronInitial = CronTimestamp . utcToLocalTime $ addUTCTime appFallbackPersonalisedSheetFilesKeysExpire oldest
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appFallbackPersonalisedSheetFilesKeysExpire / 2
, cronNotAfter = Right CronNotScheduled
}
oldestSentMail <- lift $ preview (_head . _entityVal . _sentMailSentAt) <$> selectList [] [Asc SentMailSentAt, LimitTo 1]
whenIsJust ((,) <$> appMailRetainSent <*> oldestSentMail) $ \(retain, oldest) -> tell $ HashMap.singleton
(JobCtlQueue JobPruneOldSentMails)
Cron
{ cronInitial = CronTimestamp . utcToLocalTime $ addUTCTime retain oldest
, cronRepeat = CronRepeatOnChange
, cronRateLimit = retain / 2
, cronNotAfter = Right CronNotScheduled
}
whenIsJust (appInjectFiles <* appUploadCacheConf) $ \iInterval ->
tell $ HashMap.singleton
(JobCtlQueue JobInjectFiles)
Cron
{ cronInitial = CronAsap
, cronRepeat = CronRepeatScheduled CronAsap
, cronRateLimit = iInterval
, cronNotAfter = Right CronNotScheduled
}
whenIsJust appRechunkFiles $ \rInterval ->
tell $ HashMap.singleton
(JobCtlQueue JobRechunkFiles)
Cron
{ cronInitial = CronAsap
, cronRepeat = CronRepeatScheduled CronAsap
, cronRateLimit = rInterval
, cronNotAfter = Right CronNotScheduled
}
whenIsJust appCheckMissingFiles $ \rInterval ->
tell $ HashMap.singleton
(JobCtlQueue JobDetectMissingFiles)
Cron
{ cronInitial = CronAsap
, cronRepeat = CronRepeatScheduled CronAsap
, cronRateLimit = rInterval
, cronNotAfter = Right CronNotScheduled
}
tell . flip foldMap universeF $ \kind ->
case appHealthCheckInterval kind of
Just int -> HashMap.singleton
@ -131,368 +49,478 @@ determineCrontab = execWriterT $ do
}
Nothing -> mempty
let newyear = cronCalendarAny
{ cronDayOfYear = cronMatchOne 1
}
in tell $ HashMap.singleton
(JobCtlQueue JobTruncateTransactionLog)
when (is _JobsLocal appJobMode) $ do
case appJobFlushInterval of
Just interval -> tell $ HashMap.singleton
JobCtlFlush
Cron
{ cronInitial = newyear
, cronRepeat = CronRepeatScheduled newyear
, cronRateLimit = minNominalYear
{ cronInitial = CronAsap
, cronRepeat = CronRepeatScheduled CronAsap
, cronRateLimit = interval
, cronNotAfter = Right CronNotScheduled
}
Nothing -> return ()
oldestLogEntry <- fmap listToMaybe . lift . E.select . E.from $ \transactionLog -> do
E.where_ . E.not_ . E.isNothing $ transactionLog E.^. TransactionLogRemote
E.orderBy [E.asc $ transactionLog E.^. TransactionLogTime]
E.limit 1
return $ transactionLog E.^. TransactionLogTime
for_ oldestLogEntry $ \(E.Value oldestEntry) ->
tell $ HashMap.singleton
(JobCtlQueue JobDeleteTransactionLogIPs)
oldestInvitationMUTC <- lift $ preview (_head . _entityVal . _invitationExpiresAt . _Just) <$> selectList [InvitationExpiresAt !=. Nothing] [Asc InvitationExpiresAt, LimitTo 1]
whenIsJust oldestInvitationMUTC $ \oldestInvUTC -> tell $ HashMap.singleton
(JobCtlQueue JobPruneInvitations)
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appTransactionLogIPRetentionTime oldestEntry
{ cronInitial = CronTimestamp $ utcToLocalTime oldestInvUTC
, cronRepeat = CronRepeatOnChange
, cronRateLimit = nominalDay
, cronNotAfter = Right CronNotScheduled
}
let
getNextIntervals within interval cInterval = do
now <- liftIO getPOSIXTime
return $ do
let
epochInterval = within / 2
(currEpoch, epochNow) = now `divMod'` epochInterval
currInterval = epochNow `div'` interval
numIntervals = max 1 . floor $ epochInterval / interval
n = ceiling $ 4 * cInterval / interval
i <- [ negate (ceiling $ n % 2) .. ceiling $ n % 2 ]
let
((+ currEpoch) -> nextEpoch, nextInterval) = (currInterval + i) `divMod` numIntervals
nextIntervalTime
= posixSecondsToUTCTime $ fromInteger nextEpoch * epochInterval + fromInteger nextInterval * interval
return (nextEpoch, nextInterval, nextIntervalTime, numIntervals)
if
| is _Just appLdapConf
, Just syncWithin <- appSynchroniseLdapUsersWithin
, Just cInterval <- appJobCronInterval
-> do
nextIntervals <- getNextIntervals syncWithin appSynchroniseLdapUsersInterval cInterval
forM_ nextIntervals $ \(nextEpoch, nextInterval, nextIntervalTime, numIntervals) -> do
tell $ HashMap.singleton
(JobCtlQueue JobSynchroniseLdap
{ jEpoch = fromInteger nextEpoch
, jNumIterations = fromInteger numIntervals
, jIteration = fromInteger nextInterval
})
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ nextIntervalTime
, cronRepeat = CronRepeatNever
, cronRateLimit = appSynchroniseLdapUsersInterval
, cronNotAfter = Left syncWithin
}
| otherwise
-> return ()
whenIsJust ((,) <$> appPruneUnreferencedFilesWithin <*> appJobCronInterval) $ \(within, cInterval) -> do
nextIntervals <- getNextIntervals within appPruneUnreferencedFilesInterval cInterval
forM_ nextIntervals $ \(nextEpoch, nextInterval, nextIntervalTime, numIntervals) -> do
tell $ HashMap.singleton
(JobCtlQueue JobPruneUnreferencedFiles
{ jEpoch = fromInteger nextEpoch
, jNumIterations = fromInteger numIntervals
, jIteration = fromInteger nextInterval
}
)
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ nextIntervalTime
, cronRepeat = CronRepeatNever
, cronRateLimit = appPruneUnreferencedFilesInterval
, cronNotAfter = Left within
}
let
sheetJobs (Entity nSheet Sheet{..}) = do
for_ (max <$> sheetVisibleFrom <*> sheetActiveFrom) $ \aFrom ->
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationSheetActive{..})
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ aFrom
, cronRepeat = CronRepeatNever
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = maybe (Left appNotificationExpiration) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) sheetActiveTo
}
for_ (max <$> sheetVisibleFrom <*> sheetHintFrom) $ \hFrom -> maybeT (return ()) $ do
guard $ maybe True (\aFrom -> abs (diffUTCTime aFrom hFrom) > 300) sheetActiveFrom
guardM $ or2M (return $ maybe True (\sFrom -> abs (diffUTCTime sFrom hFrom) > 300) sheetSolutionFrom)
(fmap not . lift . lift $ exists [SheetFileType ==. SheetSolution, SheetFileSheet ==. nSheet])
guardM . lift . lift $ exists [SheetFileType ==. SheetHint, SheetFileSheet ==. nSheet]
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationSheetHint{..})
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ hFrom
, cronRepeat = CronRepeatNever
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = maybe (Left appNotificationExpiration) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) sheetActiveTo
}
for_ (max <$> sheetVisibleFrom <*> sheetSolutionFrom) $ \sFrom -> maybeT (return ()) $ do
guard $ maybe True (\aFrom -> abs (diffUTCTime aFrom sFrom) > 300) sheetActiveFrom
guardM . lift . lift $ exists [SheetFileType ==. SheetSolution, SheetFileSheet ==. nSheet]
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationSheetSolution{..})
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sFrom
, cronRepeat = CronRepeatNever
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Left nominalDay
}
for_ sheetActiveTo $ \aTo -> do
whenIsJust (max aTo <$> sheetVisibleFrom) $ \aTo' -> do
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationSheetSoonInactive{..})
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . maybe id max sheetActiveFrom $ addUTCTime (-nominalDay) aTo'
, cronRepeat = CronRepeatOnChange -- Allow repetition of the notification (if something changes), but wait at least an hour
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ aTo
}
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationSheetInactive{..})
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ aTo
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Left appNotificationExpiration
}
when sheetAutoDistribute $
tell $ HashMap.singleton
(JobCtlQueue $ JobDistributeCorrections nSheet)
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ aTo
, cronRepeat = CronRepeatNever
, cronRateLimit = 3600 -- Irrelevant due to `cronRepeat`
, cronNotAfter = Left nominalDay
}
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ sheetJobs
let
correctorNotifications :: Map (UserId, SheetId) (Max UTCTime) -> WriterT (Crontab JobCtl) DB ()
correctorNotifications = (tell .) . Map.foldMapWithKey $ \(nUser, nSheet) (Max time) -> HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationCorrectionsAssigned { nUser, nSheet } )
oldestSessionFile <- lift $ preview (_head . _entityVal . _sessionFileTouched) <$> selectList [] [Asc SessionFileTouched, LimitTo 1]
whenIsJust oldestSessionFile $ \oldest -> tell $ HashMap.singleton
(JobCtlQueue JobPruneSessionFiles)
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appNotificationCollateDelay time
, cronRepeat = CronRepeatNever
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Left appNotificationExpiration
{ cronInitial = CronTimestamp . utcToLocalTime $ addUTCTime appSessionFilesExpire oldest
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appSessionFilesExpire / 2
, cronNotAfter = Right CronNotScheduled
}
submissionsByCorrector :: Entity Submission -> Map (UserId, SheetId) (Max UTCTime)
submissionsByCorrector (Entity _ sub)
| Just ratingBy <- submissionRatingBy sub
, Just assigned <- submissionRatingAssigned sub
, not $ submissionRatingDone sub
= Map.singleton (ratingBy, submissionSheet sub) $ Max assigned
| otherwise
= Map.empty
oldestFallbackPersonalisedSheetFilesKey <- lift $ preview (_head . _entityVal . _fallbackPersonalisedSheetFilesKeyGenerated) <$> selectList [] [Asc FallbackPersonalisedSheetFilesKeyGenerated, LimitTo 1]
whenIsJust oldestFallbackPersonalisedSheetFilesKey $ \oldest -> tell $ HashMap.singleton
(JobCtlQueue JobPruneFallbackPersonalisedSheetFilesKeys)
Cron
{ cronInitial = CronTimestamp . utcToLocalTime $ addUTCTime appFallbackPersonalisedSheetFilesKeysExpire oldest
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appFallbackPersonalisedSheetFilesKeysExpire / 2
, cronNotAfter = Right CronNotScheduled
}
collateSubmissionsByCorrector acc entity = Map.unionWith (<>) acc $ submissionsByCorrector entity
correctorNotifications <=< runConduit $
transPipe lift ( selectSource [ SubmissionRatingBy !=. Nothing, SubmissionRatingAssigned !=. Nothing ] []
)
.| C.fold collateSubmissionsByCorrector Map.empty
oldestSentMail <- lift $ preview (_head . _entityVal . _sentMailSentAt) <$> selectList [] [Asc SentMailSentAt, LimitTo 1]
whenIsJust ((,) <$> appMailRetainSent <*> oldestSentMail) $ \(retain, oldest) -> tell $ HashMap.singleton
(JobCtlQueue JobPruneOldSentMails)
Cron
{ cronInitial = CronTimestamp . utcToLocalTime $ addUTCTime retain oldest
, cronRepeat = CronRepeatOnChange
, cronRateLimit = retain / 2
, cronNotAfter = Right CronNotScheduled
}
let
examSelect = E.selectSource . E.from $ \(exam `E.InnerJoin` course `E.InnerJoin` school) -> do
E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
return (exam, course, school)
examJobs (Entity nExam Exam{..}, _, Entity _ School{..}) = do
newestResult <- lift . E.select . E.from $ \examResult -> do
E.where_ $ examResult E.^. ExamResultExam E.==. E.val nExam
return . E.max_ $ examResult E.^. ExamResultLastChanged
whenIsJust (appInjectFiles <* appUploadCacheConf) $ \iInterval ->
tell $ HashMap.singleton
(JobCtlQueue JobInjectFiles)
Cron
{ cronInitial = CronAsap
, cronRepeat = CronRepeatScheduled CronAsap
, cronRateLimit = iInterval
, cronNotAfter = Right CronNotScheduled
}
whenIsJust examVisibleFrom $ \visibleFrom -> do
case over (mapped . _Value) ((max `on` NTop) examFinished) newestResult of
[E.Value (NTop (Just ts))] ->
whenIsJust appRechunkFiles $ \rInterval ->
tell $ HashMap.singleton
(JobCtlQueue JobRechunkFiles)
Cron
{ cronInitial = CronAsap
, cronRepeat = CronRepeatScheduled CronAsap
, cronRateLimit = rInterval
, cronNotAfter = Right CronNotScheduled
}
whenIsJust appCheckMissingFiles $ \rInterval ->
tell $ HashMap.singleton
(JobCtlQueue JobDetectMissingFiles)
Cron
{ cronInitial = CronAsap
, cronRepeat = CronRepeatScheduled CronAsap
, cronRateLimit = rInterval
, cronNotAfter = Right CronNotScheduled
}
let newyear = cronCalendarAny
{ cronDayOfYear = cronMatchOne 1
}
in tell $ HashMap.singleton
(JobCtlQueue JobTruncateTransactionLog)
Cron
{ cronInitial = newyear
, cronRepeat = CronRepeatScheduled newyear
, cronRateLimit = minNominalYear
, cronNotAfter = Right CronNotScheduled
}
oldestLogEntry <- fmap listToMaybe . lift . E.select . E.from $ \transactionLog -> do
E.where_ . E.not_ . E.isNothing $ transactionLog E.^. TransactionLogRemote
E.orderBy [E.asc $ transactionLog E.^. TransactionLogTime]
E.limit 1
return $ transactionLog E.^. TransactionLogTime
for_ oldestLogEntry $ \(E.Value oldestEntry) ->
tell $ HashMap.singleton
(JobCtlQueue JobDeleteTransactionLogIPs)
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appTransactionLogIPRetentionTime oldestEntry
, cronRepeat = CronRepeatOnChange
, cronRateLimit = nominalDay
, cronNotAfter = Right CronNotScheduled
}
let
getNextIntervals within interval cInterval = do
now <- liftIO getPOSIXTime
return $ do
let
epochInterval = within / 2
(currEpoch, epochNow) = now `divMod'` epochInterval
currInterval = epochNow `div'` interval
numIntervals = max 1 . floor $ epochInterval / interval
n = ceiling $ 4 * cInterval / interval
i <- [ negate (ceiling $ n % 2) .. ceiling $ n % 2 ]
let
((+ currEpoch) -> nextEpoch, nextInterval) = (currInterval + i) `divMod` numIntervals
nextIntervalTime
= posixSecondsToUTCTime $ fromInteger nextEpoch * epochInterval + fromInteger nextInterval * interval
return (nextEpoch, nextInterval, nextIntervalTime, numIntervals)
if
| is _Just appLdapConf
, Just syncWithin <- appSynchroniseLdapUsersWithin
, Just cInterval <- appJobCronInterval
-> do
nextIntervals <- getNextIntervals syncWithin appSynchroniseLdapUsersInterval cInterval
forM_ nextIntervals $ \(nextEpoch, nextInterval, nextIntervalTime, numIntervals) -> do
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationExamResult{..})
(JobCtlQueue JobSynchroniseLdap
{ jEpoch = fromInteger nextEpoch
, jNumIterations = fromInteger numIntervals
, jIteration = fromInteger nextInterval
})
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ max visibleFrom ts
, cronRepeat = CronRepeatOnChange
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ nextIntervalTime
, cronRepeat = CronRepeatNever
, cronRateLimit = appSynchroniseLdapUsersInterval
, cronNotAfter = Left syncWithin
}
| otherwise
-> return ()
whenIsJust ((,) <$> appPruneUnreferencedFilesWithin <*> appJobCronInterval) $ \(within, cInterval) -> do
nextIntervals <- getNextIntervals within appPruneUnreferencedFilesInterval cInterval
forM_ nextIntervals $ \(nextEpoch, nextInterval, nextIntervalTime, numIntervals) -> do
tell $ HashMap.singleton
(JobCtlQueue JobPruneUnreferencedFiles
{ jEpoch = fromInteger nextEpoch
, jNumIterations = fromInteger numIntervals
, jIteration = fromInteger nextInterval
}
)
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ nextIntervalTime
, cronRepeat = CronRepeatNever
, cronRateLimit = appPruneUnreferencedFilesInterval
, cronNotAfter = Left within
}
whenIsJust ((,) <$> appStudyFeaturesRecacheRelevanceWithin <*> appJobCronInterval) $ \(within, cInterval) -> do
nextIntervals <- getNextIntervals within appStudyFeaturesRecacheRelevanceInterval cInterval
forM_ nextIntervals $ \(nextEpoch, nextInterval, nextIntervalTime, numIntervals) -> do
tell $ HashMap.singleton
(JobCtlQueue JobStudyFeaturesRecacheRelevance
{ jEpoch = fromInteger nextEpoch
, jNumIterations = fromInteger numIntervals
, jIteration = fromInteger nextInterval
}
)
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ nextIntervalTime
, cronRepeat = CronRepeatNever
, cronRateLimit = appStudyFeaturesRecacheRelevanceInterval
, cronNotAfter = Left within
}
let
sheetJobs (Entity nSheet Sheet{..}) = do
for_ (max <$> sheetVisibleFrom <*> sheetActiveFrom) $ \aFrom ->
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationSheetActive{..})
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ aFrom
, cronRepeat = CronRepeatNever
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = maybe (Left appNotificationExpiration) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) sheetActiveTo
}
for_ (max <$> sheetVisibleFrom <*> sheetHintFrom) $ \hFrom -> maybeT (return ()) $ do
guard $ maybe True (\aFrom -> abs (diffUTCTime aFrom hFrom) > 300) sheetActiveFrom
guardM $ or2M (return $ maybe True (\sFrom -> abs (diffUTCTime sFrom hFrom) > 300) sheetSolutionFrom)
(fmap not . lift . lift $ exists [SheetFileType ==. SheetSolution, SheetFileSheet ==. nSheet])
guardM . lift . lift $ exists [SheetFileType ==. SheetHint, SheetFileSheet ==. nSheet]
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationSheetHint{..})
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ hFrom
, cronRepeat = CronRepeatNever
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = maybe (Left appNotificationExpiration) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) sheetActiveTo
}
for_ (max <$> sheetVisibleFrom <*> sheetSolutionFrom) $ \sFrom -> maybeT (return ()) $ do
guard $ maybe True (\aFrom -> abs (diffUTCTime aFrom sFrom) > 300) sheetActiveFrom
guardM . lift . lift $ exists [SheetFileType ==. SheetSolution, SheetFileSheet ==. nSheet]
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationSheetSolution{..})
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sFrom
, cronRepeat = CronRepeatNever
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Left nominalDay
}
for_ sheetActiveTo $ \aTo -> do
whenIsJust (max aTo <$> sheetVisibleFrom) $ \aTo' -> do
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationSheetSoonInactive{..})
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . maybe id max sheetActiveFrom $ addUTCTime (-nominalDay) aTo'
, cronRepeat = CronRepeatOnChange -- Allow repetition of the notification (if something changes), but wait at least an hour
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ . addUTCTime appNotificationExpiration $ max visibleFrom ts
, cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ aTo
}
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationSheetInactive{..})
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ aTo
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Left appNotificationExpiration
}
when sheetAutoDistribute $
tell $ HashMap.singleton
(JobCtlQueue $ JobDistributeCorrections nSheet)
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ aTo
, cronRepeat = CronRepeatNever
, cronRateLimit = 3600 -- Irrelevant due to `cronRepeat`
, cronNotAfter = Left nominalDay
}
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ sheetJobs
let
correctorNotifications :: Map (UserId, SheetId) (Max UTCTime) -> WriterT (Crontab JobCtl) DB ()
correctorNotifications = (tell .) . Map.foldMapWithKey $ \(nUser, nSheet) (Max time) -> HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationCorrectionsAssigned { nUser, nSheet } )
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appNotificationCollateDelay time
, cronRepeat = CronRepeatNever
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Left appNotificationExpiration
}
submissionsByCorrector :: Entity Submission -> Map (UserId, SheetId) (Max UTCTime)
submissionsByCorrector (Entity _ sub)
| Just ratingBy <- submissionRatingBy sub
, Just assigned <- submissionRatingAssigned sub
, not $ submissionRatingDone sub
= Map.singleton (ratingBy, submissionSheet sub) $ Max assigned
| otherwise
= Map.empty
collateSubmissionsByCorrector acc entity = Map.unionWith (<>) acc $ submissionsByCorrector entity
correctorNotifications <=< runConduit $
transPipe lift ( selectSource [ SubmissionRatingBy !=. Nothing, SubmissionRatingAssigned !=. Nothing ] []
)
.| C.fold collateSubmissionsByCorrector Map.empty
let
examSelect = E.selectSource . E.from $ \(exam `E.InnerJoin` course `E.InnerJoin` school) -> do
E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
return (exam, course, school)
examJobs (Entity nExam Exam{..}, _, Entity _ School{..}) = do
newestResult <- lift . E.select . E.from $ \examResult -> do
E.where_ $ examResult E.^. ExamResultExam E.==. E.val nExam
return . E.max_ $ examResult E.^. ExamResultLastChanged
whenIsJust examVisibleFrom $ \visibleFrom -> do
case over (mapped . _Value) ((max `on` NTop) examFinished) newestResult of
[E.Value (NTop (Just ts))] ->
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationExamResult{..})
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ max visibleFrom ts
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ . addUTCTime appNotificationExpiration $ max visibleFrom ts
}
_other -> return ()
whenIsJust examRegisterFrom $ \registerFrom ->
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationExamRegistrationActive{..})
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ max visibleFrom registerFrom
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = maybe (Left appNotificationExpiration) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) examRegisterTo
}
whenIsJust ((,) <$> examRegisterFrom <*> examRegisterTo) $ \(registerFrom, registerTo) ->
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationExamRegistrationSoonInactive{..})
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . max visibleFrom . max registerFrom $ addUTCTime (-nominalDay) registerTo
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ registerTo
}
whenIsJust ((,) <$> examRegisterFrom <*> examDeregisterUntil) $ \(registerFrom, deregisterUntil) ->
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationExamDeregistrationSoonInactive{..})
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . max visibleFrom . max registerFrom $ addUTCTime (-nominalDay) deregisterUntil
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ deregisterUntil
}
let closeTime = case (examClosed, examFinished) of
(mClose, Just finish)
| isn't _ExamCloseSeparate schoolExamCloseMode -> Just $ maybe id min mClose finish
(Just close, _)
| is _ExamCloseSeparate schoolExamCloseMode -> Just close
_other -> Nothing
case closeTime of
Just close -> do
-- If an exam that was previously under `ExamCloseSeparate` rules transitions to `ExamCloseOnFinish`, it might suddenly have been closed an arbitrary time ago
-- If `cronNotAfter` was only `appNotificationExpiration` in that case, no notification might ever be sent
-- That's probably fine.
changedResults <- lift . E.select . E.from $ \examResult -> do
E.where_ $ examResult E.^. ExamResultExam E.==. E.val nExam
E.&&. examResult E.^. ExamResultLastChanged E.>. E.val close
return $ examResult E.^. ExamResultId
case newestResult of
[E.Value (Just lastChange)]
| not $ null changedResults
-> tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationExamOfficeExamResultsChanged{ nExamResults = Set.fromList $ map E.unValue changedResults })
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appNotificationCollateDelay lastChange
, cronRepeat = CronRepeatNever
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Left appNotificationExpiration
}
_other -> return ()
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationExamOfficeExamResults{..})
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ close
, cronRepeat = CronRepeatNever
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Left appNotificationExpiration
}
Nothing -> return ()
in runConduit $ transPipe lift examSelect .| C.mapM_ examJobs
let
externalExamJobs nExternalExam = do
newestResult <- lift . E.select . E.from $ \externalExamResult -> do
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. E.val nExternalExam
return . E.max_ $ externalExamResult E.^. ExternalExamResultLastChanged
case newestResult of
[E.Value (Just lastChange)] ->
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationExamOfficeExternalExamResults{..})
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appNotificationCollateDelay lastChange
, cronRepeat = CronRepeatOnChange
, cronRateLimit = nominalDay
, cronNotAfter = Left appNotificationExpiration
}
_other -> return ()
whenIsJust examRegisterFrom $ \registerFrom ->
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationExamRegistrationActive{..})
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ max visibleFrom registerFrom
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = maybe (Left appNotificationExpiration) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) examRegisterTo
}
whenIsJust ((,) <$> examRegisterFrom <*> examRegisterTo) $ \(registerFrom, registerTo) ->
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationExamRegistrationSoonInactive{..})
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . max visibleFrom . max registerFrom $ addUTCTime (-nominalDay) registerTo
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ registerTo
}
whenIsJust ((,) <$> examRegisterFrom <*> examDeregisterUntil) $ \(registerFrom, deregisterUntil) ->
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationExamDeregistrationSoonInactive{..})
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . max visibleFrom . max registerFrom $ addUTCTime (-nominalDay) deregisterUntil
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ deregisterUntil
}
let closeTime = case (examClosed, examFinished) of
(mClose, Just finish)
| isn't _ExamCloseSeparate schoolExamCloseMode -> Just $ maybe id min mClose finish
(Just close, _)
| is _ExamCloseSeparate schoolExamCloseMode -> Just close
_other -> Nothing
case closeTime of
Just close -> do
-- If an exam that was previously under `ExamCloseSeparate` rules transitions to `ExamCloseOnFinish`, it might suddenly have been closed an arbitrary time ago
-- If `cronNotAfter` was only `appNotificationExpiration` in that case, no notification might ever be sent
-- That's probably fine.
changedResults <- lift . E.select . E.from $ \examResult -> do
E.where_ $ examResult E.^. ExamResultExam E.==. E.val nExam
E.&&. examResult E.^. ExamResultLastChanged E.>. E.val close
return $ examResult E.^. ExamResultId
case newestResult of
[E.Value (Just lastChange)]
| not $ null changedResults
-> tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationExamOfficeExamResultsChanged{ nExamResults = Set.fromList $ map E.unValue changedResults })
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appNotificationCollateDelay lastChange
, cronRepeat = CronRepeatNever
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Left appNotificationExpiration
}
_other -> return ()
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationExamOfficeExamResults{..})
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ close
, cronRepeat = CronRepeatNever
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Left appNotificationExpiration
}
Nothing -> return ()
in runConduit $ transPipe lift examSelect .| C.mapM_ examJobs
runConduit $ transPipe lift (selectKeys [] []) .| C.mapM_ externalExamJobs
let
externalExamJobs nExternalExam = do
newestResult <- lift . E.select . E.from $ \externalExamResult -> do
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. E.val nExternalExam
return . E.max_ $ externalExamResult E.^. ExternalExamResultLastChanged
allocations <- lift $ selectList [] []
case newestResult of
[E.Value (Just lastChange)] ->
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationExamOfficeExternalExamResults{..})
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appNotificationCollateDelay lastChange
, cronRepeat = CronRepeatOnChange
, cronRateLimit = nominalDay
, cronNotAfter = Left appNotificationExpiration
}
_other -> return ()
let
allocationTimes :: EntityField Allocation (Maybe UTCTime) -> MergeHashMap UTCTime [Entity Allocation]
allocationTimes aField = flip foldMap allocations $ \allocEnt -> case allocEnt ^. fieldLens aField of
Nothing -> mempty
Just t -> _MergeHashMap # HashMap.singleton t (pure allocEnt)
runConduit $ transPipe lift (selectKeys [] []) .| C.mapM_ externalExamJobs
forM_ allocations $ \(Entity nAllocation _) -> do
doneSince <- lift $ fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \participant -> do
E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation)
return . E.max_ $ participant E.^. CourseParticipantRegistration
whenIsJust doneSince $ \doneSince' ->
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationAllocationResults{..})
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appNotificationCollateDelay doneSince'
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ . addUTCTime appNotificationCollateDelay $ addUTCTime appNotificationExpiration doneSince'
}
allocations <- lift $ selectList [] []
let
allocationTimes :: EntityField Allocation (Maybe UTCTime) -> MergeHashMap UTCTime [Entity Allocation]
allocationTimes aField = flip foldMap allocations $ \allocEnt -> case allocEnt ^. fieldLens aField of
Nothing -> mempty
Just t -> _MergeHashMap # HashMap.singleton t (pure allocEnt)
forM_ allocations $ \(Entity nAllocation _) -> do
doneSince <- lift $ fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \participant -> do
E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation)
return . E.max_ $ participant E.^. CourseParticipantRegistration
whenIsJust doneSince $ \doneSince' ->
iforM_ (allocationTimes AllocationStaffRegisterFrom) $ \staffRegisterFrom allocs ->
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationAllocationResults{..})
(JobCtlQueue $ JobQueueNotification NotificationAllocationStaffRegister{ nAllocations = setOf (folded . _entityKey) allocs })
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appNotificationCollateDelay doneSince'
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ staffRegisterFrom
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ . addUTCTime appNotificationCollateDelay $ addUTCTime appNotificationExpiration doneSince'
, cronNotAfter = maybe (Right CronNotScheduled) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) $ nBot =<< minimumOf (folded . _entityVal . _allocationStaffRegisterTo . to NTop . filtered (> NTop (Just staffRegisterFrom))) allocs
}
iforM_ (allocationTimes AllocationRegisterFrom) $ \registerFrom allocs ->
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationAllocationRegister{ nAllocations = setOf (folded . _entityKey) allocs })
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ registerFrom
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = maybe (Right CronNotScheduled) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) $ nBot =<< minimumOf (folded . _entityVal . _allocationRegisterTo . to NTop . filtered (> NTop (Just registerFrom))) allocs
}
iforM_ (allocationTimes AllocationStaffAllocationFrom) $ \staffAllocationFrom allocs ->
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationAllocationAllocation{ nAllocations = setOf (folded . _entityKey) allocs })
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ staffAllocationFrom
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = maybe (Right CronNotScheduled) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) $ nBot =<< minimumOf (folded . _entityVal . _allocationStaffAllocationTo . to NTop . filtered (> NTop (Just staffAllocationFrom))) allocs
}
iforM_ (allocationTimes AllocationRegisterTo) $ \registerTo allocs' -> do
let allocs = flip filter allocs' $ \(Entity _ Allocation{..}) -> maybe True (> registerTo) allocationStaffAllocationTo
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationAllocationUnratedApplications{ nAllocations = setOf (folded . _entityKey) allocs })
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ registerTo
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = maybe (Right CronNotScheduled) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) $ nBot =<< minimumOf (folded . _entityVal . _allocationStaffAllocationTo . to NTop . filtered (> NTop (Just registerTo))) allocs
}
let externalApiJobs (Entity jExternalApi ExternalApi{..}) =
tell $ HashMap.singleton
(JobCtlQueue JobExternalApiExpire{..})
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appExternalApisExpiry externalApiLastAlive
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appExternalApisExpiry
, cronNotAfter = Right CronNotScheduled
}
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ externalApiJobs
hasRelevanceUncached <- lift $ exists [StudyFeaturesRelevanceCached ==. Nothing]
when hasRelevanceUncached . tell $ HashMap.singleton
(JobCtlQueue JobStudyFeaturesCacheRelevance)
Cron
{ cronInitial = CronAsap
, cronRepeat = CronRepeatOnChange
, cronRateLimit = nominalDay
, cronNotAfter = Right CronNotScheduled
}
iforM_ (allocationTimes AllocationStaffRegisterFrom) $ \staffRegisterFrom allocs ->
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationAllocationStaffRegister{ nAllocations = setOf (folded . _entityKey) allocs })
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ staffRegisterFrom
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = maybe (Right CronNotScheduled) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) $ nBot =<< minimumOf (folded . _entityVal . _allocationStaffRegisterTo . to NTop . filtered (> NTop (Just staffRegisterFrom))) allocs
}
iforM_ (allocationTimes AllocationRegisterFrom) $ \registerFrom allocs ->
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationAllocationRegister{ nAllocations = setOf (folded . _entityKey) allocs })
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ registerFrom
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = maybe (Right CronNotScheduled) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) $ nBot =<< minimumOf (folded . _entityVal . _allocationRegisterTo . to NTop . filtered (> NTop (Just registerFrom))) allocs
}
iforM_ (allocationTimes AllocationStaffAllocationFrom) $ \staffAllocationFrom allocs ->
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationAllocationAllocation{ nAllocations = setOf (folded . _entityKey) allocs })
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ staffAllocationFrom
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = maybe (Right CronNotScheduled) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) $ nBot =<< minimumOf (folded . _entityVal . _allocationStaffAllocationTo . to NTop . filtered (> NTop (Just staffAllocationFrom))) allocs
}
iforM (allocationTimes AllocationRegisterTo) $ \registerTo allocs' -> do
let allocs = flip filter allocs' $ \(Entity _ Allocation{..}) -> maybe True (> registerTo) allocationStaffAllocationTo
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationAllocationUnratedApplications{ nAllocations = setOf (folded . _entityKey) allocs })
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ registerTo
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = maybe (Right CronNotScheduled) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) $ nBot =<< minimumOf (folded . _entityVal . _allocationStaffAllocationTo . to NTop . filtered (> NTop (Just registerTo))) allocs
}
let externalApiJobs (Entity jExternalApi ExternalApi{..}) =
tell $ HashMap.singleton
(JobCtlQueue JobExternalApiExpire{..})
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appExternalApisExpiry externalApiLastAlive
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appExternalApisExpiry
, cronNotAfter = Right CronNotScheduled
}
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ externalApiJobs

56
src/Jobs/Handler/Files.hs
View File

@ -23,14 +23,8 @@ import qualified Network.Minio as Minio
import Crypto.Hash (hashDigestSize, digestFromByteString)
import Data.List ((!!), unfoldr, maximumBy, init, genericLength)
import qualified Data.ByteString as ByteString
import Data.Bits (Bits(shiftR))
import qualified Data.Map.Strict as Map
import Control.Monad.Random.Lazy (evalRand, mkStdGen)
import System.Random.Shuffle (shuffleM)
import System.IO.Unsafe
import Handler.Utils.Files (sourceFileDB)
@ -44,6 +38,8 @@ import qualified Data.Sequence as Seq
import Jobs.Queue (YesodJobDB)
import Jobs.Handler.Intervals.Utils
dispatchJobPruneSessionFiles :: JobHandler UniWorX
dispatchJobPruneSessionFiles = JobHandlerAtomicWithFinalizer act fin
@ -73,9 +69,7 @@ fileReferences (E.just -> fHash)
]
workflowFileReferences :: MonadResource m => ConduitT () FileContentReference (SqlPersistT m) ()
workflowFileReferences = mconcat [ E.selectSource (E.from $ pure . (E.^. WorkflowDefinitionGraph)) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue)
, E.selectSource (E.from $ pure . (E.^. WorkflowInstanceGraph )) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue)
, E.selectSource (E.from $ pure . (E.^. WorkflowWorkflowGraph )) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue)
workflowFileReferences = mconcat [ E.selectSource (E.from $ pure . (E.^. SharedWorkflowGraphGraph)) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue)
, E.selectSource (E.from $ pure . (E.^. WorkflowWorkflowState )) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue)
]
@ -161,52 +155,10 @@ dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtom
( Unwrapped FileContentChunkReference ~ Digest h )
=> Integer
chunkHashBytes = fromIntegral (hashDigestSize (error "hashDigestSize inspected argument" :: h))
chunkHashBits = chunkHashBytes * 8
base :: Integer
base = 2 ^ chunkHashBits
intervals :: [Integer]
-- | Exclusive upper bounds
intervals
| numIterations <= 0 = pure base
| otherwise = go protoIntervals ^.. folded . _1
where
go [] = []
go ints
| maximumOf (folded . _1) ints == Just base = ints
| otherwise = go $ lts ++ over _1 succ (over _2 (subtract $ toInteger numIterations) closest) : map (over _1 succ) gts
where
closest = maximumBy (comparing $ view _2) ints
(lts, geqs) = partition (((>) `on` view _1) closest) ints
gts = filter (((<) `on` view _1) closest) geqs
-- | Exclusive upper bounds
protoIntervals :: [(Integer, Integer)]
protoIntervals = [ over _1 (i *) $ base `divMod` toInteger numIterations
| i <- [1 .. toInteger numIterations]
]
intervalsDgsts' = zipWith (curry . over both $ toDigest <=< assertM' (> 0)) (0 : init intervals) intervals
toDigest :: Integer -> Maybe FileContentChunkReference
toDigest = fmap (review _Wrapped) . digestFromByteString . pad . ByteString.pack . reverse . unfoldr step
where step i
| i <= 0 = Nothing
| otherwise = Just (fromIntegral i, i `shiftR` 8)
pad bs
| toInteger (ByteString.length bs) >= chunkHashBytes = bs
| otherwise = pad $ ByteString.cons 0 bs
intervalsDgsts <- atomically $ do
cachedDgsts <- readTVar pruneUnreferencedFilesIntervalsCache
case Map.lookup numIterations cachedDgsts of
Just c -> return c
Nothing -> do
modifyTVar' pruneUnreferencedFilesIntervalsCache $ force . Map.insert numIterations intervalsDgsts'
return intervalsDgsts'
(minBoundDgst, maxBoundDgst) <- currentIntervalCached pruneUnreferencedFilesIntervalsCache chunkHashBytes (fmap (review _Wrapped) . digestFromByteString) numIterations epoch iteration
let
permIntervalsDgsts = shuffleM intervalsDgsts `evalRand` mkStdGen (hash epoch)
(minBoundDgst, maxBoundDgst) = permIntervalsDgsts !! fromIntegral (toInteger iteration `mod` genericLength permIntervalsDgsts)
chunkIdFilter :: E.SqlExpr (E.Value FileContentChunkReference) -> E.SqlExpr (E.Value Bool)
chunkIdFilter cRef = E.and $ catMaybes
[ minBoundDgst <&> \b -> cRef E.>=. E.val b

77
src/Jobs/Handler/Intervals/Utils.hs Normal file
View File

@ -0,0 +1,77 @@
module Jobs.Handler.Intervals.Utils
( mkIntervals, mkIntervalsCached
, getCurrentInterval
, currentIntervalCached
) where
import Import hiding (init, maximumBy, cached)
import Control.Monad.Random.Lazy (evalRand, mkStdGen)
import System.Random.Shuffle (shuffleM)
import Data.List ((!!), unfoldr, maximumBy, init, genericLength)
import qualified Data.ByteString as ByteString
import Data.Bits (Bits(shiftR))
import qualified Data.Map.Strict as Map
mkIntervals :: forall a. Integer -> (ByteString -> Maybe a) -> Natural -> [(Maybe a, Maybe a)]
mkIntervals bytes fromBS numIterations = zip (Nothing : init intervals') intervals'
where
bits = bytes * 8
base :: Integer
base = 2 ^ bits
-- | Exclusive upper bounds
intervals
| numIterations <= 0 = pure base
| otherwise = go protoIntervals ^.. folded . _1
where
go [] = []
go ints
| maximumOf (folded . _1) ints == Just base = ints
| otherwise = go $ lts ++ over _1 succ (over _2 (subtract $ toInteger numIterations) closest) : map (over _1 succ) gts
where
closest = maximumBy (comparing $ view _2) ints
(lts, geqs) = partition (((>) `on` view _1) closest) ints
gts = filter (((<) `on` view _1) closest) geqs
-- | Exclusive upper bounds
protoIntervals :: [(Integer, Integer)]
protoIntervals = [ over _1 (i *) $ base `divMod` toInteger numIterations
| i <- [1 .. toInteger numIterations]
]
intervals' = map (fromBS' <=< assertM' (> 0)) intervals
fromBS' :: Integer -> Maybe a
fromBS' = fromBS . pad . ByteString.pack . reverse . unfoldr step
where step i
| i <= 0 || i >= base = Nothing
| otherwise = Just (fromIntegral i, i `shiftR` 8)
pad bs
| toInteger (ByteString.length bs) >= bytes = bs
| otherwise = pad $ ByteString.cons 0 bs
getCurrentInterval :: forall a. Natural -> Natural -> [a] -> a
getCurrentInterval epoch iteration intervals = permIntervals !! fromIntegral (toInteger iteration `mod` genericLength permIntervals)
where permIntervals = shuffleM intervals `evalRand` mkStdGen (hash epoch)
mkIntervalsCached :: forall m a. (NFData a, MonadIO m)
=> TVar (Map Natural [(Maybe a, Maybe a)])
-> Integer -> (ByteString -> Maybe a) -> Natural -> m [(Maybe a, Maybe a)]
mkIntervalsCached cacheTVar bytes fromBS numIterations = atomically $ do
cached <- readTVar cacheTVar
case Map.lookup numIterations cached of
Just c -> return c
Nothing -> do
modifyTVar' cacheTVar $ force . Map.insert numIterations intervals'
return intervals'
where intervals' = mkIntervals bytes fromBS numIterations
currentIntervalCached :: forall m a. (NFData a, MonadIO m)
=> TVar (Map Natural [(Maybe a, Maybe a)])
-> Integer -> (ByteString -> Maybe a)
-> Natural -> Natural -> Natural -> m (Maybe a, Maybe a)
currentIntervalCached cacheTVar bytes fromBS numIterations epoch iteration
= getCurrentInterval epoch iteration <$> mkIntervalsCached cacheTVar bytes fromBS numIterations

45
src/Jobs/Handler/StudyFeatures.hs Normal file
View File

@ -0,0 +1,45 @@
module Jobs.Handler.StudyFeatures
( dispatchJobStudyFeaturesCacheRelevance
, dispatchJobStudyFeaturesRecacheRelevance
) where
import Import
import Handler.Utils.StudyFeatures
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import qualified Data.Map.Strict as Map
import System.IO.Unsafe
import Jobs.Handler.Intervals.Utils
import qualified Data.UUID as UUID
dispatchJobStudyFeaturesCacheRelevance :: JobHandler UniWorX
dispatchJobStudyFeaturesCacheRelevance = JobHandlerAtomic $
cacheStudyFeatureRelevance $ \studyFeatures -> E.isNothing $ studyFeatures E.^. StudyFeaturesRelevanceCached
{-# NOINLINE studyFeaturesRecacheRelevanceIntervalsCache #-}
studyFeaturesRecacheRelevanceIntervalsCache :: TVar (Map Natural [(Maybe UUID, Maybe UUID)])
studyFeaturesRecacheRelevanceIntervalsCache = unsafePerformIO $ newTVarIO Map.empty
dispatchJobStudyFeaturesRecacheRelevance :: Natural -> Natural -> Natural -> JobHandler UniWorX
dispatchJobStudyFeaturesRecacheRelevance numIterations epoch iteration = JobHandlerAtomic $ do
(minBoundUUID, maxBoundUUID) <- currentIntervalCached studyFeaturesRecacheRelevanceIntervalsCache 16 (UUID.fromByteString . fromStrict) numIterations epoch iteration
let
uuidFilter :: E.SqlExpr (E.Value (Maybe UUID)) -> E.SqlExpr (E.Value Bool)
uuidFilter cRef = E.and $ catMaybes
[ pure $ E.isJust cRef
, minBoundUUID <&> \b -> cRef E.>=. E.justVal b
, maxBoundUUID <&> \b -> cRef E.<. E.justVal b
]
$logDebugS "StudyFeaturesRecacheRelevance" . tshow $ (minBoundUUID, maxBoundUUID)
cacheStudyFeatureRelevance $ \studyFeatures -> uuidFilter $ studyFeatures E.^. StudyFeaturesRelevanceCached

70
src/Jobs/Offload.hs Normal file
View File

@ -0,0 +1,70 @@
module Jobs.Offload
( mkJobOffloadHandler
) where
import Import hiding (bracket, js)
import Jobs.Types
import Jobs.Queue
import qualified Database.PostgreSQL.Simple as PG
import qualified Database.PostgreSQL.Simple.Types as PG
import qualified Database.PostgreSQL.Simple.Notification as PG
import Database.Persist.Postgresql (PostgresConf, pgConnStr)
import Data.Text.Encoding (decodeUtf8')
import UnliftIO.Exception (bracket)
jobOffloadChannel :: Text
jobOffloadChannel = "job-offload"
mkJobOffloadHandler :: forall m.
( MonadResource m
, MonadUnliftIO m
, MonadThrow m, MonadReader UniWorX m
, MonadLogger m
)
=> PostgresConf -> JobMode
-> Maybe (m JobOffloadHandler)
mkJobOffloadHandler dbConf jMode
| is _JobsLocal jMode, hasn't (_jobsAcceptOffload . only True) jMode = Nothing
| otherwise = Just $ do
jobOffloadOutgoing <- newTVarIO mempty
jobOffloadHandler <- allocateAsync . bracket (liftIO . PG.connectPostgreSQL $ pgConnStr dbConf) (liftIO . PG.close) $ \pgConn -> do
myPid <- liftIO $ PG.getBackendPID pgConn
let shouldListen = has (_jobsAcceptOffload . only True) jMode
when shouldListen $
void . liftIO $ PG.execute pgConn "LISTEN ?" (PG.Only $ PG.Identifier jobOffloadChannel)
foreverBreak $ \(($ ()) -> terminate) -> do
UniWorX{appJobState} <- ask
shouldTerminate <- atomically $ readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown
when shouldTerminate terminate
let
getInput = do
n@PG.Notification{..} <- liftIO $ PG.getNotification pgConn
if | notificationPid == myPid || notificationChannel /= encodeUtf8 jobOffloadChannel -> getInput
| otherwise -> return n
getOutput = atomically $ do
jQueue <- readTVar jobOffloadOutgoing
case jQueue of
j :< js -> j <$ writeTVar jobOffloadOutgoing js
_other -> mzero
io <- lift $ if
| shouldListen -> getInput `race` getOutput
| otherwise -> Right <$> getOutput
case io of
Left PG.Notification{..}
| Just jId <- fromPathPiece =<< either (const Nothing) Just (decodeUtf8' notificationData)
-> writeJobCtl $ JobCtlPerform jId
| otherwise
-> $logErrorS "JobOffloadHandler" $ "Could not parse incoming notification data: " <> tshow notificationData
Right jId -> void . liftIO $ PG.execute pgConn "NOTIFY ?, ?" (PG.Identifier jobOffloadChannel, encodeUtf8 $ toPathPiece jId)
return JobOffloadHandler{..}

13
src/Jobs/Types.hs
View File

@ -9,7 +9,7 @@ module Jobs.Types
, classifyJobCtl
, YesodJobDB
, JobHandler(..), _JobHandlerAtomic, _JobHandlerException
, JobContext(..)
, JobOffloadHandler(..), JobContext(..)
, JobState(..), _jobWorkers, _jobWorkerName, _jobContext, _jobPoolManager, _jobCron, _jobShutdown, _jobCurrentCrontab
, jobWorkerNames
, JobWorkerState(..), _jobWorkerJobCtl, _jobWorkerJob
@ -99,6 +99,11 @@ data Job
| JobRechunkFiles
| JobDetectMissingFiles
| JobPruneOldSentMails
| JobStudyFeaturesCacheRelevance
| JobStudyFeaturesRecacheRelevance { jNumIterations
, jEpoch
, jIteration :: Natural
}
deriving (Eq, Ord, Show, Read, Generic, Typeable)
data Notification
= NotificationSubmissionRated { nSubmission :: SubmissionId }
@ -240,10 +245,16 @@ showWorkerId = tshow . hashUnique . jobWorkerUnique
newWorkerId :: MonadIO m => m JobWorkerId
newWorkerId = JobWorkerId <$> liftIO newUnique
data JobOffloadHandler = JobOffloadHandler
{ jobOffloadHandler :: Async ()
, jobOffloadOutgoing :: TVar (Seq QueuedJobId)
}
data JobContext = JobContext
{ jobCrontab :: TVar (Crontab JobCtl)
, jobConfirm :: TVar (HashMap JobCtl (NonEmpty (TMVar (Maybe SomeException))))
, jobHeldLocks :: TVar (Set QueuedJobId)
, jobOffload :: TMVar JobOffloadHandler
}

72
src/Model/Migration/Definitions.hs
View File

@ -47,6 +47,8 @@ import Data.Time.Format
import qualified Data.Time.Zones as TZ
import Utils.Workflow
data ManualMigration
= Migration20180813SimplifyUserTheme
@ -97,6 +99,8 @@ data ManualMigration
| Migration20201106StoredMarkup
| Migration20201119RoomTypes
| Migration20210115ExamPartsFrom
| Migration20210201SharedWorkflowGraphs
| Migration20210208StudyFeaturesRelevanceCachedUUIDs
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite)
@ -135,6 +139,7 @@ migrateManual = do
, ("file_content_entry_chunk_hash", "CREATE INDEX file_content_entry_chunk_hash ON \"file_content_entry\" (chunk_hash)" )
, ("sent_mail_bounce_secret", "CREATE INDEX sent_mail_bounce_secret ON \"sent_mail\" (bounce_secret) WHERE bounce_secret IS NOT NULL")
, ("sent_mail_recipient", "CREATE INDEX sent_mail_recipient ON \"sent_mail\" (recipient) WHERE recipient IS NOT NULL")
, ("study_features_relevance_cached", "CREATE INDEX study_features_relevance_cached ON \"study_features\" (relevance_cached)")
]
where
addIndex :: Text -> Sql -> Migration
@ -968,6 +973,73 @@ customMigrations = mapF $ \case
migrateExam _ = return ()
in runConduit $ getExam .| C.mapM_ migrateExam
Migration20210201SharedWorkflowGraphs -> do
unlessM (tableExists "shared_workflow_graph")
[executeQQ|CREATE TABLE "shared_workflow_graph" ("hash" bytea primary key, "graph" jsonb not null)|]
whenM (tableExists "workflow_definition") $ do
[executeQQ|ALTER TABLE "workflow_definition" ADD COLUMN "graph_id" bytea references shared_workflow_graph(hash)|]
let getDefinitions = [queryQQ|SELECT "id", "graph" FROM "workflow_definition"|]
migrateDefinition [ fromPersistValue -> Right (wdId :: WorkflowDefinitionId), fromPersistValue -> Right (graph :: DBWorkflowGraph) ] = do
swgId <- insertSharedWorkflowGraph graph
[executeQQ|UPDATE "workflow_definition" SET "graph_id" = #{swgId} WHERE "id" = #{wdId}|]
migrateDefinition _ = return ()
in runConduit $ getDefinitions .| C.mapM_ migrateDefinition
[executeQQ|
ALTER TABLE "workflow_definition" DROP COLUMN "graph";
ALTER TABLE "workflow_definition" ALTER COLUMN "graph_id" SET not null;
ALTER TABLE "workflow_definition" RENAME COLUMN "graph_id" TO "graph";
|]
whenM (tableExists "workflow_instance") $ do
[executeQQ|ALTER TABLE "workflow_instance" ADD COLUMN "graph_id" bytea references shared_workflow_graph(hash)|]
let getInstances = [queryQQ|SELECT "id", "graph" FROM "workflow_instance"|]
migrateInstance [ fromPersistValue -> Right (wiId :: WorkflowInstanceId), fromPersistValue -> Right (graph :: DBWorkflowGraph) ] = do
swgId <- insertSharedWorkflowGraph graph
[executeQQ|UPDATE "workflow_instance" SET "graph_id" = #{swgId} WHERE "id" = #{wiId}|]
migrateInstance _ = return ()
in runConduit $ getInstances .| C.mapM_ migrateInstance
[executeQQ|
ALTER TABLE "workflow_instance" DROP COLUMN "graph";
ALTER TABLE "workflow_instance" ALTER COLUMN "graph_id" SET not null;
ALTER TABLE "workflow_instance" RENAME COLUMN "graph_id" TO "graph";
|]
whenM (tableExists "workflow_workflow") $ do
[executeQQ|ALTER TABLE "workflow_workflow" ADD COLUMN "graph_id" bytea references shared_workflow_graph(hash)|]
let getWorkflows = [queryQQ|SELECT "id", "graph" FROM "workflow_workflow"|]
migrateWorkflow [ fromPersistValue -> Right (wwId :: WorkflowWorkflowId), fromPersistValue -> Right (graph :: DBWorkflowGraph) ] = do
swgId <- insertSharedWorkflowGraph graph
[executeQQ|UPDATE "workflow_workflow" SET "graph_id" = #{swgId} WHERE "id" = #{wwId}|]
migrateWorkflow _ = return ()
in runConduit $ getWorkflows .| C.mapM_ migrateWorkflow
[executeQQ|
ALTER TABLE "workflow_workflow" DROP COLUMN "graph";
ALTER TABLE "workflow_workflow" ALTER COLUMN "graph_id" SET not null;
ALTER TABLE "workflow_workflow" RENAME COLUMN "graph_id" TO "graph";
|]
Migration20210208StudyFeaturesRelevanceCachedUUIDs ->
whenM (tableExists "study_features") $ do
[executeQQ|
ALTER TABLE "study_features" ADD COLUMN "relevance_cached_uuid" uuid
|]
let getStudyFeatures = [queryQQ|SELECT "id" FROM "study_features" WHERE relevance_cached|]
migrateStudyFeatures genUUID lift' [ fromPersistValue -> Right (sfId :: StudyFeaturesId) ] = do
uuid <- genUUID
lift' [executeQQ|UPDATE "study_features" SET "relevance_cached_uuid" = #{uuid} WHERE "id" = #{sfId}|]
migrateStudyFeatures _ _ _ = return ()
in runConduit $ getStudyFeatures .| randUUIDC (\genUUID lift' -> C.mapM_ $ migrateStudyFeatures genUUID lift')
[executeQQ|
ALTER TABLE "study_features" DROP COLUMN "relevance_cached";
ALTER TABLE "study_features" RENAME COLUMN "relevance_cached_uuid" TO "relevance_cached";
|]
tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool
tableExists table = do

5
src/Model/Types/Exam.hs
View File

@ -326,7 +326,10 @@ derivePersistFieldJSON ''ExamGradingRule
newtype ExamPassed = ExamPassed { examPassed :: Bool }
deriving (Read, Show, Generic, Typeable)
deriving newtype (Eq, Ord, Enum, Bounded, PersistField, PersistFieldSql)
deriving newtype (Eq, Ord, Enum, Bounded, PersistField)
instance PersistFieldSql ExamPassed where
sqlType _ = sqlType $ Proxy @Bool
deriveFinite ''ExamPassed
finitePathPiece ''ExamPassed ["failed", "passed"]

12
src/Model/Types/File.hs
View File

@ -19,7 +19,7 @@ module Model.Types.File
import Import.NoModel
import Database.Persist.Sql (PersistFieldSql)
import Database.Persist.Sql (PersistFieldSql(..))
import Web.HttpApiData (ToHttpApiData, FromHttpApiData)
import Data.ByteArray (ByteArrayAccess)
@ -42,24 +42,30 @@ import qualified Data.Map as Map
newtype FileContentChunkReference = FileContentChunkReference (Digest SHA3_512)
deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable)
deriving newtype ( PersistField, PersistFieldSql
deriving newtype ( PersistField
, PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON
, Hashable, NFData
, ByteArrayAccess
, Binary
)
instance PersistFieldSql FileContentChunkReference where
sqlType _ = sqlType $ Proxy @(Digest SHA3_512)
makeWrapped ''FileContentChunkReference
newtype FileContentReference = FileContentReference (Digest SHA3_512)
deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable)
deriving newtype ( PersistField, PersistFieldSql
deriving newtype ( PersistField
, PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON
, Hashable, NFData
, ByteArrayAccess
, Binary
)
instance PersistFieldSql FileContentReference where
sqlType _ = sqlType $ Proxy @(Digest SHA3_512)
makeWrapped ''FileContentReference

12
src/Model/Types/Mail.hs
View File

@ -19,7 +19,7 @@ import qualified Data.HashSet as HashSet
import qualified Data.HashMap.Strict as HashMap
import Crypto.Hash (digestFromByteString, SHAKE128)
import Database.Persist.Sql (PersistFieldSql)
import Database.Persist.Sql (PersistFieldSql(..))
import Data.ByteArray (ByteArrayAccess)
import qualified Data.ByteArray as BA
@ -102,11 +102,14 @@ derivePersistFieldJSON ''NotificationSettings
newtype BounceSecret = BounceSecret (Digest (SHAKE128 64))
deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable)
deriving newtype ( PersistField, PersistFieldSql
deriving newtype ( PersistField
, Hashable, NFData
, ByteArrayAccess
)
instance PersistFieldSql BounceSecret where
sqlType _ = sqlType $ Proxy @(Digest (SHAKE128 64))
instance PathPiece BounceSecret where
toPathPiece = CI.foldCase . encodeBase32Unpadded . BA.convert
fromPathPiece = fmap BounceSecret . digestFromByteString <=< either (const Nothing) Just . decodeBase32Unpadded . encodeUtf8
@ -120,10 +123,13 @@ derivePersistFieldJSON ''MailContent
newtype MailContentReference = MailContentReference (Digest SHA3_512)
deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable)
deriving newtype ( PersistField, PersistFieldSql
deriving newtype ( PersistField
, PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON
, Hashable, NFData
, ByteArrayAccess
)
instance PersistFieldSql MailContentReference where
sqlType _ = sqlType $ Proxy @(Digest SHA3_512)
derivePersistFieldJSON ''MailHeaders

5
src/Model/Types/Submission.hs
View File

@ -52,9 +52,12 @@ type PseudonymWord = CI Text
newtype Pseudonym = Pseudonym Word24
deriving (Eq, Ord, Read, Show, Generic, Data)
deriving newtype ( Bounded, Enum, Integral, Num, Real, Ix
, PersistField, PersistFieldSql, Random
, PersistField, Random
)
instance PersistFieldSql Pseudonym where
sqlType _ = sqlType $ Proxy @Word24
instance FromJSON Pseudonym where
parseJSON v@(Aeson.Number _) = do
w <- parseJSON v :: Aeson.Parser Word32

35
src/Model/Types/Workflow.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE UndecidableInstances #-}
module Model.Types.Workflow
( WorkflowGraph(..)
( WorkflowGraph(..), WorkflowGraphReference(..)
, WorkflowGraphNodeLabel
, WorkflowGraphNode(..)
, WorkflowNodeView(..)
@ -37,6 +37,8 @@ import Model.Types.Security (AuthDNF, PredDNF)
import Model.Types.File (FileContentReference, FileFieldUserOption, FileField, _fieldAdditionalFiles, FileReferenceTitleMapConvertible(..))
import Database.Persist.Sql (PersistFieldSql(..))
import Web.HttpApiData (ToHttpApiData, FromHttpApiData)
import Data.ByteArray (ByteArrayAccess)
import Data.Maybe (fromJust)
@ -77,11 +79,26 @@ deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (F
deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraph fileid userid)
deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraph fileid userid)
newtype WorkflowGraphReference = WorkflowGraphReference (Digest SHA3_256)
deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable)
deriving newtype ( PersistField
, PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON
, Hashable, NFData
, ByteArrayAccess
, Binary
)
instance PersistFieldSql WorkflowGraphReference where
sqlType _ = sqlType $ Proxy @(Digest SHA3_256)
----- WORKFLOW GRAPH: NODES -----
newtype WorkflowGraphNodeLabel = WorkflowGraphNodeLabel { unWorkflowGraphNodeLabel :: CI Text }
deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable)
deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, PersistFieldSql, Binary)
deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, Binary)
instance PersistFieldSql WorkflowGraphNodeLabel where
sqlType _ = sqlType $ Proxy @(CI Text)
data WorkflowGraphNode fileid userid = WGN
{ wgnFinal :: Maybe Icon
@ -112,7 +129,10 @@ data WorkflowNodeMessage userid = WorkflowNodeMessage
newtype WorkflowGraphEdgeLabel = WorkflowGraphEdgeLabel { unWorkflowGraphEdgeLabel :: CI Text }
deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable)
deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, PersistFieldSql, Binary)
deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, Binary)
instance PersistFieldSql WorkflowGraphEdgeLabel where
sqlType _ = sqlType $ Proxy @(CI Text)
data WorkflowGraphRestriction
= WorkflowGraphRestrictionPayloadFilled { wgrPayloadFilled :: WorkflowPayloadLabel }
@ -341,9 +361,12 @@ classifyWorkflowScope = \case
newtype WorkflowPayloadLabel = WorkflowPayloadLabel { unWorkflowPayloadLabel :: CI Text }
deriving stock (Eq, Ord, Show, Read, Data, Generic, Typeable)
deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, PersistFieldSql, Binary)
deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, Binary)
deriving anyclass (Hashable)
instance PersistFieldSql WorkflowPayloadLabel where
sqlType _ = sqlType $ Proxy @(CI Text)
newtype WorkflowStateIndex = WorkflowStateIndex { unWorkflowStateIndex :: Word64 }
deriving stock (Eq, Ord, Show, Read, Data, Generic, Typeable)
deriving newtype (Num, Real, Integral, Enum, Bounded, ToJSON, FromJSON, PathPiece, Binary)
@ -1052,3 +1075,7 @@ instance Binary WorkflowScope'
instance (Binary termid, Binary schoolid, Binary courseid) => Binary (WorkflowScope termid schoolid courseid)
instance Binary userid => Binary (WorkflowRole userid)
----- TH Jail -----
makeWrapped ''WorkflowGraphReference

22
src/Settings.hs
View File

@ -210,9 +210,19 @@ data AppSettings = AppSettings
, appInitialInstanceID :: Maybe (Either FilePath UUID)
, appRibbon :: Maybe Text
, appJobMode :: JobMode
, appStudyFeaturesRecacheRelevanceWithin :: Maybe NominalDiffTime
, appStudyFeaturesRecacheRelevanceInterval :: NominalDiffTime
, appMemcacheAuth :: Bool
} deriving Show
data JobMode = JobsLocal { jobsAcceptOffload :: Bool }
| JobsOffload
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (Hashable)
data ApprootScope = ApprootUserGenerated | ApprootDefault
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite, Hashable)
@ -346,6 +356,11 @@ deriveFromJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 2
} ''UserDefaultConf
deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1
, constructorTagModifier = camelToPathPiece' 1
} ''JobMode
instance FromJSON LdapConf where
parseJSON = withObject "LdapConf" $ \o -> do
ldapTls <- o .:? "tls"
@ -532,7 +547,7 @@ instance FromJSON AppSettings where
appFileChunkingHashWindow <- o .: "file-chunking-hash-window"
appFileChunkingParams <- maybe (fail "Could not recommend FastCDCParameters") return $ recommendFastCDCParameters appFileChunkingTargetExponent appFileChunkingHashWindow
appPruneUnreferencedFilesWithin <- o .: "prune-unreferenced-files-within"
appPruneUnreferencedFilesWithin <- o .:? "prune-unreferenced-files-within"
appPruneUnreferencedFilesInterval <- o .: "prune-unreferenced-files-interval"
appMaximumContentLength <- o .: "maximum-content-length"
@ -603,6 +618,11 @@ instance FromJSON AppSettings where
appMemcacheAuth <- o .:? "memcache-auth" .!= False
appJobMode <- o .:? "job-mode" .!= JobsLocal True
appStudyFeaturesRecacheRelevanceWithin <- o .:? "study-features-recache-relevance-within"
appStudyFeaturesRecacheRelevanceInterval <- o .: "study-features-recache-relevance-interval"
return AppSettings{..}
makeClassy_ ''AppSettings

32
src/Utils.hs
View File

@ -70,6 +70,8 @@ import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Catch
import Control.Monad.Morph (hoist)
import Control.Monad.Fail
import Control.Monad.Trans.Cont (ContT, evalContT, callCC)
import qualified Control.Monad.State.Class as State
import Language.Haskell.TH
import Language.Haskell.TH.Instances ()
@ -97,6 +99,7 @@ import qualified Crypto.MAC.KMAC as KMAC
import qualified Crypto.Hash as Crypto
import Crypto.Hash (HashAlgorithm, Digest)
import Crypto.Hash.Instances ()
import qualified Crypto.Random as Crypto
import Data.ByteArray (ByteArrayAccess)
@ -139,6 +142,9 @@ import Text.Hamlet (Translate)
import Data.Ratio ((%))
import Data.UUID (UUID)
import qualified Data.UUID as UUID
{-# ANN module ("HLint: ignore Use asum" :: String) #-}
@ -462,6 +468,10 @@ guardMonoid True x = x
assertMonoid :: Monoid m => (m -> Bool) -> m -> m
assertMonoid f x = guardMonoid (f x) x
maybeMonoid :: Monoid m => Maybe m -> m
-- ^ Identify `Nothing` with `mempty`
maybeMonoid = fromMaybe mempty
------------
-- Tuples --
------------
@ -935,6 +945,17 @@ diffTimeout timeoutLength timeoutRes act = fromMaybe timeoutRes <$> timeout time
= let (MkFixed micro :: Micro) = realToFrac timeoutLength
in fromInteger micro
forever' :: Monad m
=> a
-> (a -> m a)
-> m b
forever' start cont = cont start >>= flip forever' cont
foreverBreak :: Monad m
=> ((r -> ContT r m b) -> ContT r m a)
-> m r
foreverBreak cont = evalContT . callCC $ forever . cont
--------------
-- Foldable --
@ -1391,6 +1412,17 @@ uniforms :: (RandomGen g, MonadSplit g m, Foldable t) => t a -> m [a]
uniforms xs = LazyRand.evalRand go <$> getSplit
where go = (:) <$> interleave (uniform xs) <*> go
randUUIDC :: MonadIO m
=> (forall m'. Monad m' => m' UUID -> (forall a. m a -> m' a) -> ConduitT i o m' r)
-> ConduitT i o m r
randUUIDC cont = do
drg <- liftIO Crypto.drgNew
let
mkUUID = do
uuidBS <- State.state $ Crypto.randomBytesGenerate 16
return . fromMaybe (error $ "Could not convert bytestring to uuid: " <> show uuidBS) . UUID.fromByteString $ fromStrict uuidBS
evalStateC drg $ cont mkUUID lift
----------
-- Lens --
----------

10
src/Utils/DateTime.hs
View File

@ -16,8 +16,9 @@ module Utils.DateTime
, day
) where
import ClassyPrelude.Yesod hiding (lift)
import ClassyPrelude.Yesod hiding (lift, Proxy(..))
import System.Locale.Read
import Data.Proxy
import Data.Time (NominalDiffTime, nominalDay, LocalTime(..), TimeOfDay, midnight, ZonedTime(..), DiffTime)
import Data.Time.Zones as Zones (TZ)
@ -38,7 +39,7 @@ import Instances.TH.Lift ()
import Data.Data (Data)
import Data.Universe
import Database.Persist.Sql (PersistFieldSql)
import Database.Persist.Sql (PersistFieldSql(..))
import Utils.PathPiece
@ -98,7 +99,10 @@ instance HasLocalTime TimeOfDay where
newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String }
deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)
deriving newtype (ToJSON, FromJSON, PersistField, PersistFieldSql, IsString)
deriving newtype (ToJSON, FromJSON, PersistField, IsString)
instance PersistFieldSql DateTimeFormat where
sqlType _ = sqlType $ Proxy @String
instance Hashable DateTimeFormat

4
src/Utils/Lens.hs
View File

@ -5,6 +5,7 @@
module Utils.Lens ( module Utils.Lens ) where
import Import.NoModel
import Settings
import Model
import Model.Rating
import qualified ClassyPrelude.Yesod as Yesod (HasHttpManager(..))
@ -274,6 +275,9 @@ makePrisms ''AllocationPriority
makePrisms ''RoomReference
makeLenses_ ''RoomReference
makePrisms ''JobMode
makeLenses_ ''JobMode
-- makeClassy_ ''Load
--------------------------

19
src/Utils/Metrics.hs
View File

@ -5,6 +5,7 @@ module Utils.Metrics
, registerGHCMetrics
, observeHTTPRequestLatency
, registerReadyMetric
, registerHealthCheckInterval
, withJobWorkerState
, observeYesodCacheSize
, observeFavouritesQuickActionsDuration
@ -74,6 +75,17 @@ healthReportDuration = unsafeRegister . vector ("check", "status") $ histogram i
"Duration of last health check performed by this Uni2work-instance"
buckets = histogramBuckets 5e-6 100e-3
data HealthCheckInterval = MkHealthCheckInterval
healthCheckInterval :: (HealthCheck -> Maybe NominalDiffTime) -> Metric HealthCheckInterval
healthCheckInterval hcInts = Metric $ return (MkHealthCheckInterval, collectHealthCheckInterval)
where
collectHealthCheckInterval = return . pure . SampleGroup info GaugeType $ do
(hc, Just int) <- itoList hcInts
return . Sample "uni2work_health_check_interval_seconds" [("check", toPathPiece hc)] . encodeUtf8 $ tshow (realToFrac int :: Nano)
info = Info "uni2work_health_check_interval_seconds"
"Target interval at which health checks are executed by this Uni2work-instance"
{-# NOINLINE httpRequestLatency #-}
httpRequestLatency :: Vector Label3 Histogram
httpRequestLatency = unsafeRegister . vector ("handler", "method", "status") $ histogram info buckets
@ -219,9 +231,9 @@ missingFiles = unsafeRegister . vector "ref" $ gauge info
withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport
withHealthReportMetrics act = do
before <- liftIO $ getTime Monotonic
before <- liftIO getPOSIXTime
report <- act
after <- liftIO $ getTime Monotonic
after <- liftIO getPOSIXTime
let checkVal = toPathPiece $ classifyHealthReport report
statusVal = toPathPiece $ healthReportStatus report
@ -258,6 +270,9 @@ observeHTTPRequestLatency classifyHandler app req respond' = do
registerReadyMetric :: MonadIO m => m ()
registerReadyMetric = liftIO $ void . register . readyMetric =<< getPOSIXTime
registerHealthCheckInterval :: MonadIO m => (HealthCheck -> Maybe NominalDiffTime) -> m ()
registerHealthCheckInterval = liftIO . void . register . healthCheckInterval
classifyJobWorkerState :: JobWorkerId -> JobWorkerState -> Prometheus.Label4
classifyJobWorkerState wId jws = (showWorkerId wId, tag, maybe "n/a" pack mJobCtl, maybe "n/a" pack mJob)
where

1
src/Utils/Parameters.hs
View File

@ -32,6 +32,7 @@ data GlobalGetParam = GetLang
| GetDownload
| GetError
| GetSelectTable
| GetGenerateToken
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
deriving anyclass (Universe, Finite)

38
src/Utils/Workflow.hs
View File

@ -10,6 +10,8 @@ module Utils.Workflow
, decryptWorkflowStateIndex, encryptWorkflowStateIndex
, isTopWorkflowScope, isTopWorkflowScopeSql
, selectWorkflowInstanceDescription
, SharedWorkflowGraphException(..), getSharedDBWorkflowGraph, getSharedIdWorkflowGraph
, insertSharedWorkflowGraph
) where
import Import.NoFoundation
@ -19,11 +21,15 @@ import qualified Crypto.MAC.KMAC as Crypto
import qualified Data.ByteArray as BA
import qualified Data.Binary as Binary
import Crypto.Hash.Algorithms (SHAKE256)
import qualified Crypto.Hash as Crypto
import Language.Haskell.TH (nameBase)
import qualified Data.Aeson as Aeson
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
type RouteWorkflowScope = WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)
type DBWorkflowScope = WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey
@ -130,3 +136,35 @@ selectWorkflowInstanceDescription wiId = withReaderT (projectBackend @SqlReadBac
return $ workflowInstanceDescription E.^. WorkflowInstanceDescriptionLanguage
descLang <- traverse selectLanguage . nonEmpty $ E.unValue <$> descLangs
fmap join . for descLang $ \descLang' -> getBy $ UniqueWorkflowInstanceDescription wiId descLang'
data SharedWorkflowGraphException
= SharedWorkflowGraphNotFound SharedWorkflowGraphId
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (Exception)
getSharedDBWorkflowGraph :: ( MonadHandler m
, BackendCompatible SqlReadBackend backend
)
=> SharedWorkflowGraphId
-> ReaderT backend m DBWorkflowGraph
getSharedDBWorkflowGraph swgId = $cachedHereBinary swgId . withReaderT (projectBackend @SqlReadBackend) $ do
maybe (liftHandler . throwM $ SharedWorkflowGraphNotFound swgId) (return . sharedWorkflowGraphGraph) =<< get swgId
getSharedIdWorkflowGraph :: ( MonadHandler m
, BackendCompatible SqlReadBackend backend
)
=> SharedWorkflowGraphId
-> ReaderT backend m IdWorkflowGraph
getSharedIdWorkflowGraph = fmap (review _DBWorkflowGraph) . getSharedDBWorkflowGraph
insertSharedWorkflowGraph :: ( MonadIO m
, BackendCompatible SqlBackend backend
)
=> DBWorkflowGraph
-> ReaderT backend m SharedWorkflowGraphId
insertSharedWorkflowGraph graph = withReaderT (projectBackend @SqlBackend) $
swgId' <$ repsert swgId' (SharedWorkflowGraph swgId graph)
where
swgId = WorkflowGraphReference . Crypto.hashlazy $ Aeson.encode graph
swgId' = SharedWorkflowGraphKey swgId

2
stack.nix
View File

@ -9,7 +9,7 @@ in pkgs.haskell.lib.buildStackProject {
inherit (haskellPackages) stack;
name = "stackenv";
buildInputs = (with pkgs;
[ postgresql zlib libsodium gmp
[ postgresql zlib libsodium gmp llvm_9
]) ++ (with haskellPackages;
[ yesod-bin happy alex
]);

23
test/Database/Fill.hs
View File

@ -34,6 +34,7 @@ import qualified Data.Conduit.Combinators as C
import qualified Data.Yaml as Yaml
import Utils.Workflow
import Utils.Workflow.Lint
import System.Directory (getModificationTime)
@ -532,7 +533,7 @@ fillDb = do
(Just now)
now
True
False
Nothing
insert_ $ StudyFeatures
maxMuster
sdBsc
@ -543,7 +544,7 @@ fillDb = do
(Just now)
now
True
False
Nothing
insert_ $ StudyFeatures
tinaTester
sdBsc
@ -554,7 +555,7 @@ fillDb = do
(Just now)
now
False
False
Nothing
insert_ $ StudyFeatures
tinaTester
sdLAG
@ -565,7 +566,7 @@ fillDb = do
(Just now)
now
True
False
Nothing
insert_ $ StudyFeatures
tinaTester
sdLAR
@ -576,7 +577,7 @@ fillDb = do
(Just now)
now
True
False
Nothing
insert_ $ StudyFeatures
tinaTester
sdMst
@ -587,7 +588,7 @@ fillDb = do
(Just now)
now
True
False
Nothing
-- FFP
let nbrs :: [Int]
@ -1330,8 +1331,9 @@ fillDb = do
displayLinterIssue = liftIO . hPutStrLn stderr . displayException
handleSql displayLinterIssue $ do
workflowDefinitionGraph <- Yaml.decodeFileThrow $ testdataDir </> "workflows" </> "theses.yaml"
for_ (lintWorkflowGraph workflowDefinitionGraph) $ mapM_ throwM
graph <- Yaml.decodeFileThrow $ testdataDir </> "workflows" </> "theses.yaml"
for_ (lintWorkflowGraph graph) $ mapM_ throwM
workflowDefinitionGraph <- insertSharedWorkflowGraph graph
let
thesesWorkflowDef = WorkflowDefinition{..}
where workflowDefinitionInstanceCategory = Just "theses"
@ -1366,8 +1368,9 @@ fillDb = do
}
handleSql displayLinterIssue $ do
workflowDefinitionGraph <- Yaml.decodeFileThrow $ testdataDir </> "workflows" </> "recognitions-ifi.yaml"
for_ (lintWorkflowGraph workflowDefinitionGraph) $ mapM_ throwM
graph <- Yaml.decodeFileThrow $ testdataDir </> "workflows" </> "recognitions-ifi.yaml"
for_ (lintWorkflowGraph graph) $ mapM_ throwM
workflowDefinitionGraph <- insertSharedWorkflowGraph graph
let
recognitionsWorkflowDef = WorkflowDefinition{..}
where workflowDefinitionInstanceCategory = Just "recognitions-ifi"