fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore: merge master

Browse Source
This commit is contained in:
Gregor Kleen 2019-11-25 10:25:52 +01:00
parent 2621d36b7d
commit 38a4e6cdb7
234 changed files with 8012 additions and 1987 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

234
.gitlab-ci.yml Normal file
View File

@ -0,0 +1,234 @@
default:
image:
name: fpco/stack-build:lts-13.21
cache:
paths:
- node_modules
- .stack
- .stack-work
variables:
STACK_ROOT: "${CI_PROJECT_DIR}/.stack"
CHROME_BIN: "/usr/bin/chromium-browser"
POSTGRES_DB: uniworx_test
POSTGRES_USER: uniworx
POSTGRES_PASSWORD: uniworx
stages:
- setup
- frontend:build
- yesod:build
- lint
- test
- deploy
npm install:
stage: setup
script:
- npm install
before_script: &npm
- apt-get update -y
- npm install -g n
- n stable
- npm install -g npm
- hash -r
artifacts:
paths:
- node_modules/
name: "${CI_JOB_NAME}"
expire_in: "1 day"
retry: 2
frontend:build:
stage: frontend:build
script:
- npm run frontend:build
before_script: *npm
needs:
- npm install
artifacts:
paths:
- static/bundles/
name: "${CI_JOB_NAME}"
expire_in: "1 day"
dependencies:
- npm install
retry: 2
frontend:lint:
stage: lint
script:
- npm run frontend:lint
before_script: *npm
needs:
- npm install
dependencies:
- npm install
retry: 2
yesod:build:dev:
stage: yesod:build
script:
- stack build --copy-bins --local-bin-path $(pwd)/bin --fast --flag uniworx:-library-only --flag uniworx:dev --flag uniworx:pedantic
needs:
- frontend:build
before_script:
- apt-get update -y
- apt-get install -y --no-install-recommends locales-all
- ln -s $(which g++-7) $(dirname $(which g++-7))/g++
artifacts:
paths:
- bin/
name: "${CI_JOB_NAME}"
expire_in: "1 week"
dependencies:
- frontend:build
only:
variables:
- $CI_COMMIT_REF_NAME !~ /^v[0-9].*/
retry: 2
yesod:build:
stage: yesod:build
script:
- stack build --copy-bins --local-bin-path $(pwd)/bin --flag uniworx:-library-only --flag uniworx:-dev --flag uniworx:pedantic
needs:
- frontend:build
before_script:
- apt-get update -y
- apt-get install -y --no-install-recommends locales-all
- ln -s $(which g++-7) $(dirname $(which g++-7))/g++
artifacts:
paths:
- bin/
name: "${CI_JOB_NAME}"
dependencies:
- frontend:build
only:
variables:
- $CI_COMMIT_REF_NAME =~ /^v[0-9].*/
retry: 2
frontend:test:
stage: test
script:
- npm run frontend:test
needs:
- npm install
before_script:
- apt-get update -y
- npm install -g n
- n stable
- npm install -g npm
- hash -r
- apt-get install -y --no-install-recommends chromium-browser
dependencies:
- npm install
retry: 2
hlint:dev:
stage: lint
script:
- stack test --fast --flag uniworx:-library-only --flag uniworx:dev --flag uniworx:pedantic uniworx:test:hlint
needs:
- frontend:build
- yesod:build:dev # For caching
before_script:
- apt-get update -y
- apt-get install -y --no-install-recommends locales-all
- ln -s $(which g++-7) $(dirname $(which g++-7))/g++
dependencies:
- frontend:build
only:
variables:
- $CI_COMMIT_REF_NAME !~ /^v[0-9].*/
retry: 2
yesod:test:dev:
services:
- name: postgres:10.10
alias: postgres
stage: test
script:
- stack test --coverage --fast --flag uniworx:-library-only --flag uniworx:dev --flag uniworx:pedantic --skip hlint
needs:
- frontend:build
- yesod:build:dev # For caching
before_script:
- apt-get update -y
- apt-get install -y --no-install-recommends locales-all
- ln -s $(which g++-7) $(dirname $(which g++-7))/g++
dependencies:
- frontend:build
only:
variables:
- $CI_COMMIT_REF_NAME !~ /^v[0-9].*/
retry: 2
hlint:
stage: lint
script:
- stack test --flag uniworx:-library-only --flag uniworx:-dev --flag uniworx:pedantic uniworx:test:hlint
needs:
- frontend:build
- yesod:build # For caching
before_script:
- apt-get update -y
- apt-get install -y --no-install-recommends locales-all
- ln -s $(which g++-7) $(dirname $(which g++-7))/g++
dependencies:
- frontend:build
only:
variables:
- $CI_COMMIT_REF_NAME =~ /^v[0-9].*/
retry: 2
yesod:test:
services:
- name: postgres:10.10
alias: postgres
stage: test
script:
- stack test --coverage --flag uniworx:-library-only --flag uniworx:-dev --flag uniworx:pedantic --skip hlint
needs:
- frontend:build
- yesod:build # For caching
before_script:
- apt-get update -y
- apt-get install -y --no-install-recommends locales-all
- ln -s $(which g++-7) $(dirname $(which g++-7))/g++
dependencies:
- frontend:build
only:
variables:
- $CI_COMMIT_REF_NAME =~ /^v[0-9].*/
retry: 2
deploy:uniworx3:
stage: deploy
script:
- ssh -i ~/.ssh/id root@uniworx3.ifi.lmu.de <bin/uniworx
needs:
- yesod:build
- yesod:test # For sanity
- hlint # For sanity
before_script:
- apt-get update -y
- apt-get install -y --no-install-recommends openssh-client
- install -m 0700 -d ~/.ssh
- install -m 0644 ${SSH_KNOWN_HOSTS} ~/.ssh/known_hosts
- install -m 0400 ${SSH_PRIVATE_KEY_UNIWORX3} ~/.ssh/id
dependencies:
- yesod:build
only:
variables:
- $CI_COMMIT_REF_NAME =~ /^v[0-9].*/

1478
CHANGELOG.md
View File

File diff suppressed because it is too large Load Diff

64
clean.sh
View File

@ -4,39 +4,39 @@ set -e
[ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || :
case $1 in
"")
exec -- stack clean
;;
*)
target=".stack-work-${1}"
shift
if [[ -n "${1}" ]]; then
target=".stack-work-${1}"
else
target=".stack-work"
fi
shift
if [[ ! -d "${target}" ]]; then
printf "%s does not exist or is no directory\n" "${target}" >&2
exit 1
fi
if [[ -e .stack-work-clean ]]; then
printf ".stack-work-clean exists\n" >&2
exit 1
fi
if [[ ! -d "${target}" ]]; then
printf "%s does not exist or is no directory\n" "${target}" >&2
exit 1
fi
move-back() {
if [[ -d .stack-work ]]; then
mv -v .stack-work "${target}"
else
mkdir -v "${target}"
fi
[[ -d .stack-work-clean ]] && mv -v .stack-work-clean .stack-work
}
if [[ "${target}" != ".stack-work" ]]; then
if [[ -e .stack-work-clean ]]; then
printf ".stack-work-clean exists\n" >&2
exit 1
fi
mv -v .stack-work .stack-work-clean
mv -v "${target}" .stack-work
trap move-back EXIT
move-back() {
if [[ -d .stack-work ]]; then
mv -v .stack-work "${target}"
else
mkdir -v "${target}"
fi
[[ -d .stack-work-clean ]] && mv -v .stack-work-clean .stack-work
}
(
set -ex
stack clean $@
)
;;
esac
mv -v .stack-work .stack-work-clean
mv -v "${target}" .stack-work
trap move-back EXIT
fi
(
set -ex
stack clean $@
)

2
config/settings.yml
View File

@ -30,6 +30,8 @@ session-timeout: 7200
jwt-expiration: 604800
jwt-encoding: HS256
maximum-content-length: "_env:MAX_UPLOAD_SIZE:134217728"
session-files-expire: 3600
prune-unreferenced-files: 86400
health-check-interval:
matching-cluster-config: "_env:HEALTHCHECK_INTERVAL_MATCHING_CLUSTER_CONFIG:600"
http-reachable: "_env:HEALTHCHECK_INTERVAL_HTTP_REACHABLE:600"

33
frontend/src/services/i18n/i18n.js
View File

@ -1,3 +1,5 @@
import moment from 'moment';
/**
* I18n
*
@ -13,10 +15,15 @@
export class I18n {
translations = {};
_translations = {};
_datetimeLocale = undefined;
add(id, translation) {
this.translations[id] = translation;
if (!this._translations[id]) {
this._translations[id] = translation;
} else {
throw new Error('I18N Error: Attempting to set translation multiple times for »' + id + '«!');
}
}
addMany(manyTranslations) {
@ -24,9 +31,27 @@ export class I18n {
}
get(id) {
if (!this.translations[id]) {
if (!this._translations[id]) {
throw new Error('I18N Error: Translation missing for »' + id + '«!');
}
return this.translations[id];
return this._translations[id];
}
setDatetimeLocale(locale) {
if (!this._datetimeLocale) {
moment.locale(locale);
this._datetimeLocale = locale;
} else {
throw new Error('I18N Error: Attempting to set datetime locale multiple times!');
}
}
getDatetimeLocale() {
if (!this._datetimeLocale) {
throw new Error('I18N Error: Attempting to access datetime locale when it has not been set!');
}
return this._datetimeLocale;
}
}

4
frontend/src/services/i18n/i18n.spec.js
View File

@ -9,7 +9,7 @@ describe('I18n', () => {
// helper function
function expectTranslation(id, value) {
expect(i18n.translations[id]).toMatch(value);
expect(i18n.get(id)).toMatch(value);
}
it('should create', () => {
@ -38,7 +38,7 @@ describe('I18n', () => {
describe('get()', () => {
it('should return stored translations', () => {
i18n.translations.id1 = 'something';
i18n.add('id1', 'something');
expect(i18n.get('id1')).toMatch('something');
});

31
frontend/src/utils/form/datepicker.js
View File

@ -48,9 +48,6 @@ const DATEPICKER_CONFIG = {
timeMinutes: 0,
timeSeconds: 0,
// german settings
// TODO: hardcoded, get from current language / settings
locale: 'de',
weekStart: 1,
dateFormat: FORM_DATE_FORMAT_DATE_DT,
timeFormat: FORM_DATE_FORMAT_TIME_DT,
@ -86,6 +83,7 @@ export class Datepicker {
datepickerInstance;
_element;
elementType;
_locale;
constructor(element) {
if (!element) {
@ -96,6 +94,8 @@ export class Datepicker {
return false;
}
this._locale = window.App.i18n.getDatetimeLocale();
// initialize datepickerCollections singleton if not already done
if (!Datepicker.datepickerCollections) {
Datepicker.datepickerCollections = new Map();
@ -134,7 +134,7 @@ export class Datepicker {
}
// initialize tail.datetime (datepicker) instance and let it do weird stuff with the element value
this.datepickerInstance = datetime(this._element, { ...datepickerGlobalConfig, ...datepickerConfig });
this.datepickerInstance = datetime(this._element, { ...datepickerGlobalConfig, ...datepickerConfig, locale: this._locale });
// reset date to something sane
if (parsedMomentDate)
@ -180,14 +180,27 @@ export class Datepicker {
// change the selected date in the tail.datetime instance if the value of the input element is changed
this._element.addEventListener('change', setDatepickerDate, { once: true });
// close the instance if something other than the instance was clicked (i.e. if the target is not within the datepicker instance and if any previously clicked calendar view was replaced (is not in the window anymore) because it was clicked). YES, I KNOW
window.addEventListener('click', event => {
if (!this.datepickerInstance.dt.contains(event.target) && window.document.contains(event.target)) {
// close the instance on focusout of any element if another input is focussed that is neither the timepicker nor _element
window.addEventListener('focusout', event => {
const hasFocus = event.relatedTarget !== null;
const focussedIsNotTimepicker = !this.datepickerInstance.dt.contains(event.relatedTarget);
const focussedIsNotElement = event.relatedTarget !== this._element;
const focussedIsInDocument = window.document.contains(event.relatedTarget);
if (hasFocus && focussedIsNotTimepicker && focussedIsNotElement && focussedIsInDocument)
this.datepickerInstance.close();
});
// close the instance on click on any element outside of the datepicker (except the input element itself)
window.addEventListener('click', event => {
const targetIsOutside = !this.datepickerInstance.dt.contains(event.target)
&& event.target !== this.datepickerInstance.dt;
const targetIsInDocument = window.document.contains(event.target);
const targetIsNotElement = event.target !== this._element;
if (targetIsOutside && targetIsInDocument && targetIsNotElement)
this.datepickerInstance.close();
}
});
// close the datepicker on escape keydown events
// close the instance on escape keydown events
this._element.addEventListener('keydown', event => {
if (event.keyCode === KEYCODE_ESCAPE) {
this.datepickerInstance.close();

2
frontend/src/utils/inputs/checkbox.js
View File

@ -5,7 +5,7 @@ var CHECKBOX_CLASS = 'checkbox';
var CHECKBOX_INITIALIZED_CLASS = 'checkbox--initialized';
@Utility({
selector: 'input[type="checkbox"]',
selector: 'input[type="checkbox"]:not([uw-no-checkbox])',
})
export class Checkbox {

19
frontend/src/utils/inputs/checkbox.scss
View File

@ -1,19 +1,20 @@
/* CUSTOM CHECKBOXES */
/* Completely replaces legacy checkbox */
.checkbox [type='checkbox'], #lang-checkbox {
position: fixed;
top: -1px;
left: -1px;
width: 1px;
height: 1px;
overflow: hidden;
display: none;
}
.checkbox {
position: relative;
display: inline-block;
[type='checkbox'] {
position: fixed;
top: -1px;
left: -1px;
width: 1px;
height: 1px;
overflow: hidden;
}
label {
display: block;
height: 20px;

5
frontend/src/utils/inputs/inputs.scss
View File

@ -150,7 +150,6 @@ textarea {
padding: 4px 13px;
font-size: 1rem;
font-family: var(--font-base);
-webkit-appearance: none;
appearance: none;
border: 1px solid #dbdbdb;
border-radius: 2px;
@ -184,8 +183,8 @@ textarea {
/* OPTIONS */
select {
-webkit-appearance: menulist;
select[size = "1"], select:not([size]) {
appearance: menulist;
}
select,

48
frontend/src/utils/navbar/navbar.js Normal file
View File

@ -0,0 +1,48 @@
import { Utility } from '../../core/utility';
import './navbar.scss';
export const LANGUAGE_SELECT_UTIL_SELECTOR = '[uw-language-select]';
const LANGUAGE_SELECT_INITIALIZED_CLASS = 'language-select--initialized';
@Utility({
selector: LANGUAGE_SELECT_UTIL_SELECTOR,
})
export class LanguageSelectUtil {
_element;
checkbox;
constructor(element) {
if (!element) {
throw new Error('Language Select utility needs to be passed an element!');
}
if (element.classList.contains(LANGUAGE_SELECT_INITIALIZED_CLASS)) {
return false;
}
this._element = element;
this.checkbox = element.querySelector('#lang-checkbox');
window.addEventListener('click', event => this.close(event));
element.classList.add(LANGUAGE_SELECT_INITIALIZED_CLASS);
}
close(event) {
if (!this._element.contains(event.target) && window.document.contains(event.target)) {
this.checkbox.checked = false;
}
}
destroy() {
// TODO
}
}
export const NavbarUtils = [
LanguageSelectUtil,
];

56
templates/widgets/navbar/navbar.lucius → frontend/src/utils/navbar/navbar.scss
View File

@ -68,14 +68,7 @@
color: var(--color-lightwhite);
transition: height .2s cubic-bezier(0.03, 0.43, 0.58, 1);
overflow: hidden;
&:hover {
color: var(--color-lightwhite);
.navbar__link-icon {
opacity: 1;
}
}
cursor: pointer;
}
.navbar__link-icon {
@ -88,6 +81,7 @@
transition: opacity .2s ease;
padding: 2px 4px;
text-transform: uppercase;
font-weight: 600;
}
@media (min-width: 769px) {
@ -146,7 +140,9 @@
.navbar__list-item {
position: relative;
transition: background-color .1s ease;
&:not(.navbar__list-item--favorite) + .navbar__list-item--lang-wrapper {
margin-left: 12px;
}
&:not(.navbar__list-item--favorite) + .navbar__list-item {
margin-left: 12px;
}
@ -160,6 +156,9 @@
&:not(.navbar__list-item--favorite) + .navbar__list-item {
margin-left: 0;
}
&:not(.navbar__list-item--favorite) + .navbar__list-item--lang-wrapper {
margin-left: 0;
}
}
}
@ -219,9 +218,13 @@
color: var(--color-dark);
}
.navbar .navbar__list-item:not(.navbar__list-item--active):not(.navbar__list-item--favorite):hover .navbar__link-wrapper {
.navbar .navbar__list-item:not(.navbar__list-item--active):not(.navbar__list-item--favorite):hover .navbar__link-wrapper, #lang-checkbox:checked ~ * .navbar__link-wrapper {
background-color: var(--color-dark);
color: var(--color-lightwhite);
.navbar__link-icon {
opacity: 1;
}
}
/* sticky state */
@ -267,3 +270,36 @@
height: var(--header-height-collapsed);
}
}
#lang-dropdown {
display: none;
position: fixed;
top: var(--header-height);
right: 0;
min-width: 200px;
z-index: 10;
background-color: white;
border-radius: 2px;
box-shadow: 0 0 10px rgba(0,0,0,0.3);
select {
display: block;
}
button {
display: block;
width: 100%;
}
}
#lang-checkbox:checked ~ #lang-dropdown {
display: block;
}
@media (max-width: 768px) {
#lang-dropdown {
top: var(--header-height-collapsed);
}
}

2
frontend/src/utils/utils.js
View File

@ -10,6 +10,7 @@ import { MassInput } from './mass-input/mass-input';
import { Modal } from './modal/modal';
import { Tooltip } from './tooltips/tooltips';
import { CourseTeaser } from './course-teaser/course-teaser';
import { NavbarUtils } from './navbar/navbar';
export const Utils = [
Alerts,
@ -25,4 +26,5 @@ export const Utils = [
ShowHide,
Tooltip,
CourseTeaser,
...NavbarUtils,
];

3
messages/button/en.msg Normal file
View File

@ -0,0 +1,3 @@
AmbiguousButtons: Multiple active submit buttons
WrongButtonValue: Submit button has wrong value
MultipleButtonValues: Submit button has multiple values

1
messages/campus/de.msg
View File

@ -1,5 +1,6 @@
CampusIdentPlaceholder: Vorname.Nachname@campus.lmu.de
CampusIdent: Campus-Kennung
CampusPassword: Passwort
CampusPasswordPlaceholder: Passwort
CampusSubmit: Abschicken
CampusInvalidCredentials: Ungültige Logindaten

6
messages/campus/en.msg Normal file
View File

@ -0,0 +1,6 @@
CampusIdentPlaceholder: First.Last@campus.lmu.de
CampusIdent: Campus account
CampusPassword: Password
CampusPasswordPlaceholder: Password
CampusSubmit: Send
CampusInvalidCredentials: Invalid login

3
messages/dummy/de.msg
View File

@ -1,2 +1,3 @@
DummyIdent: Nutzer-Kennung
DummyIdent: Identifikation
DummyIdentPlaceholder: Identifikation
DummyNoFormData: Keine Formulardaten empfangen

3
messages/dummy/en.msg Normal file
View File

@ -0,0 +1,3 @@
DummyIdent: Identification
DummyIdentPlaceholder: Identification
DummyNoFormData: No form data received

2
messages/frontend/de.msg → messages/frontend/de-de-formal.msg
View File

@ -1,4 +1,4 @@
FilesSelected: Dateien ausgewählt
SelectFile: Datei auswählen
SelectFiles: Datei(en) auswählen
AsyncFormFailure: Da ist etwas schief gelaufen, das tut uns Leid. Falls das erneut passiert schicke uns gerne eine kurze Beschreibung dieses Ereignisses über das Hilfe-Widget rechts oben. Vielen Dank für deine Hilfe!
AsyncFormFailure: Da ist etwas schief gelaufen, das tut uns Leid. Falls das erneut passiert schicken Sie uns bitte eine kurze Beschreibung dieses Ereignisses über das Hilfe-Widget rechts oben. Vielen Dank für Ihre Hilfe!

4
messages/frontend/en.msg Normal file
View File

@ -0,0 +1,4 @@
FilesSelected: Files selected
SelectFile: Select file
SelectFiles: Select file(s)
AsyncFormFailure: Something went wrong, we are sorry. If this error occurs again, please let us know by clicking the Support button in the upper right corner. Thank you very much!

4
messages/pw-hash/de.msg
View File

@ -1,2 +1,4 @@
PWHashIdent: Identifikation
PWHashPassword: Passwort
PWHashIdentPlaceholder: Identifikation
PWHashPassword: Passwort
PWHashPasswordPlaceholder: Passwort

4
messages/pw-hash/en.msg Normal file
View File

@ -0,0 +1,4 @@
PWHashIdent: Identification
PWHashIdentPlaceholder: Identification
PWHashPassword: Password
PWHashPasswordPlaceholder: Password

247
messages/uniworx/de.msg → messages/uniworx/de-de-formal.msg
View File

@ -1,5 +1,7 @@
PrintDebugForStupid name@Text: Debug message "#{name}"
Logo: Uni2work
BtnSubmit: Senden
BtnAbort: Abbrechen
BtnDelete: Löschen
@ -71,9 +73,9 @@ Term: Semester
TermPlaceholder: W/S + vierstellige Jahreszahl
TermStartDay: Erster Tag
TermStartDayTooltip: Üblicherweise immer 1.April oder 1.Oktober
TermStartDayTooltip: Üblicherweise immer 1. April oder 1. Oktober
TermEndDay: Letzter Tag
TermEndDayTooltip: Üblicherweise immer 30.September oder 31.März
TermEndDayTooltip: Üblicherweise immer 30. September oder 31. März
TermHolidays: Feiertage
TermHolidayPlaceholder: Feiertag
TermLectureStart: Beginn Vorlesungen
@ -98,6 +100,7 @@ CourseRegistration: Kursanmeldung
CourseRegisterOpen: Anmeldung möglich
CourseRegisterOk: Erfolgreich zum Kurs angemeldet
CourseDeregisterOk: Erfolgreich vom Kurs abgemeldet
CourseApply: Zum Kurs bewerben
CourseApplyOk: Erfolgreich zum Kurs beworben
CourseRetractApplyOk: Bewerbung zum Kurs erfolgreich zurückgezogen
CourseDeregisterLecturerTip: Wenn Sie den Teilnehmer vom Kurs abmelden kann es sein, dass sie Zugriff auf diese Daten verlieren
@ -109,8 +112,8 @@ CourseTutorial: Tutorium
CourseSecretWrong: Falsches Passwort
CourseSecret: Zugangspasswort
CourseEditOk tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{tid}-#{ssh}-#{csh} wurde erfolgreich geändert.
CourseNewDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{tid}-#{ssh}-#{csh} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{csh} in diesem Semester.
CourseEditDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{tid}-#{ssh}-#{csh} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{csh} in diesem Semester.
CourseNewDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{tid}-#{ssh}-#{csh} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{csh} in diesem Semester und Institut.
CourseEditDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{tid}-#{ssh}-#{csh} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{csh} in diesem Semester und Institut.
FFSheetName: Name
TermCourseListHeading tid@TermId: Kursübersicht #{tid}
TermSchoolCourseListHeading tid@TermId school@SchoolName: Kursübersicht #{tid} für #{school}
@ -128,7 +131,7 @@ CourseMembersCountLimited n@Int max@Int: #{n}/#{max}
CourseMembersCountOf n@Int mbNum@IntMaybe: #{n} Kursanmeldungen #{maybeToMessage " von " mbNum " möglichen"}
CourseName: Name
CourseDescription: Beschreibung
CourseDescriptionTip: Beliebiges HTML-Markup ist gestattet
CourseDescriptionTip: Beliebiges Html-Markup ist gestattet
CourseHomepageExternal: Externe Homepage
CourseShorthand: Kürzel
CourseShorthandUnique: Muss nur innerhalb Institut und Semester eindeutig sein. Wird verbatim in die Url der Kursseite übernommen.
@ -142,14 +145,16 @@ CourseRegisterToTip: Darf auch unbegrenzt offen bleiben
CourseDeregisterUntilTip: Abmeldung ist ab "Anmeldungen von" bis zu diesem Zeitpunkt erlaubt. Die Abmeldung darf auch unbegrenzt erlaubt bleiben.
CourseFilterSearch: Volltext-Suche
CourseFilterRegistered: Registriert
CourseFilterNone: Egal
CourseFilterNone: —
BoolIrrelevant: —
CourseDeleteQuestion: Wollen Sie den unten aufgeführten Kurs wirklich löschen?
CourseDeleted: Kurs gelöscht
CourseUserTutorials: Angemeldete Tutorien
CourseUserNote: Notiz
CourseUserNoteTooltip: Nur für Dozenten dieses Kurses einsehbar
CourseUserNoteTooltip: Nur für Verwalter dieses Kurses einsehbar
CourseUserNoteSaved: Notizänderungen gespeichert
CourseUserNoteDeleted: Teilnehmernotiz gelöscht
CourseUserRegister: Zum Kurs anmelden
CourseUserDeregister: Vom Kurs abmelden
CourseUsersDeregistered count@Int64: #{show count} Teilnehmer vom Kurs abgemeldet
CourseUserRegisterTutorial: Zu einem Tutorium anmelden
@ -184,7 +189,7 @@ CourseApplication: Bewerbung
CourseApplicationIsParticipant: Kursteilnehmer
CourseApplicationExists: Sie haben sich bereits für diesen Kurs beworben
CourseApplicationInvalidAction: Angegeben Aktion kann nicht durchgeführt werden
CourseApplicationInvalidAction: Angegebene Aktion kann nicht durchgeführt werden
CourseApplicationCreated csh@CourseShorthand: Erfolgreich zu #{csh} beworben
CourseApplicationEdited csh@CourseShorthand: Bewerbung zu #{csh} erfolgreich angepasst
CourseApplicationNotEdited csh@CourseShorthand: Bewerbung zu #{csh} hat sich nicht verändert
@ -271,6 +276,8 @@ SheetSubmissionMode: Abgabe-Modus
SheetExercise: Aufgabenstellung
SheetHint: Hinweis
SheetHintFrom: Hinweis ab
SheetHintFromPlaceholder: Datum, sonst nur für Korrektoren
SheetSolutionFromPlaceholder: Datum, sonst nur für Korrektoren
SheetSolution: Lösung
SheetSolutionFrom: Lösung ab
SheetMarking: Hinweise für Korrektoren
@ -282,9 +289,15 @@ SheetDescription: Hinweise für Teilnehmer
SheetGroup: Gruppenabgabe
SheetVisibleFrom: Sichtbar für Teilnehmer ab
SheetVisibleFromTip: Ohne Datum nie sichtbar und keine Abgabe möglich; nur für unfertige Blätter leer lassen, deren Bewertung/Fristen sich noch ändern können
SheetActiveFrom: Beginn Abgabezeitraum
SheetActiveFromTip: Download der Aufgabenstellung erst ab diesem Datum möglich
SheetActiveTo: Ende Abgabezeitraum
SheetActiveFrom: Aktiv ab/Beginn Abgabezeitraum
SheetActiveFromParticipant: Beginn Abgabezeitraum
SheetActiveFromParticipantNoSubmit: Herausgabe der Aufgabestellung
SheetActiveFromTip: Download der Aufgabenstellung und Abgabe erst ab diesem Datum möglich. Ohne Datum keine Abgabe und keine Herausgabe der Aufgabenstellung
SheetActiveFromUnset: Nie
SheetActiveTo: Aktiv bis/Ende Abgabezeitraum
SheetActiveToParticipant: Ende Abgabezeitraum
SheetActiveToTip: Abgabe nur bis zu diesem Datum möglich. Ohne Datum unbeschränkte Abgabe möglich (soweit gefordert).
SheetActiveToUnset: Nie
SheetHintFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen
SheetSolutionFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen
SheetMarkingTip: Hinweise zur Korrektur, sichtbar nur für Korrektoren
@ -315,6 +328,7 @@ SubmissionEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetNa
CorrectionHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{tid}-#{ssh}-#{csh} #{sheetName}: Korrektur
SubmissionMembers: Abgebende
SubmissionMember: Abgebende(r)
CosubmittorTip: Einladungen per E-Mail erhalten genau jene Adressen, für die nicht gesichert werden kann, dass sie mit der dahinter stehenden Person schon einmal für diesen Kurs abgegeben haben. Wenn eine angegebene Adresse einer Person zugeordnet werden kann, mit der Sie in diesem Kurs schon einmal zusammen abgegeben haben, wird der Name der Person angezeigt und die Abgabe erfolgt sofort auch im Namen jener Person.
SubmissionArchive: Zip-Archiv der Abgabedatei(en)
SubmissionFile: Datei zur Abgabe
SubmissionFiles: Abgegebene Dateien
@ -333,6 +347,8 @@ CourseCorrectionsTitle: Korrekturen für diesen Kurs
CorrectorsHead sheetName@SheetName: Korrektoren für #{sheetName}
CorrectorAssignTitle: Korrektor zuweisen
CorrectionsGrade: Abgaben online korrigieren
MaterialName: Name
MaterialType: Art
MaterialTypePlaceholder: Folien, Code, Beispiel, ...
@ -370,6 +386,8 @@ UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig.
UnauthorizedTokenInvalid: Ihr Authorisierungs-Token konnte nicht verarbeitet werden.
UnauthorizedTokenInvalidRoute: Ihr Authorisierungs-Token ist auf dieser Unterseite nicht gültig.
UnauthorizedTokenInvalidAuthority: Ihr Authorisierungs-Token basiert auf den Rechten eines Nutzers, der nicht mehr existiert.
UnauthorizedTokenInvalidAuthorityGroup: Ihr Authorisierungs-Token basiert auf den Rechten einer Gruppe von Nutzern, die nicht mehr existiert.
UnauthorizedTokenInvalidAuthorityValue: Ihr Authorisierungs-Token basiert auf Rechten, deren Spezifikation nicht interpretiert werden konnte.
UnauthorizedToken404: Authorisierungs-Tokens können nicht auf Fehlerseiten ausgewertet werden.
UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator.
UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
@ -478,7 +496,7 @@ HomeOpenAllocations: Offene Zentralanmeldungen
HomeUpcomingSheets: Anstehende Übungsblätter
HomeUpcomingExams: Bevorstehende Prüfungen
NumCourses num@Int64: #{num} Kurse
NumCourses num@Int64: #{num} #{pluralDE num "Kurs" "Kurse"}
CloseAlert: Schliessen
Name: Name
@ -519,15 +537,15 @@ NatField name@Text: #{name} muss eine natürliche Zahl sein!
JSONFieldDecodeFailure aesonFailure@String: Konnte JSON nicht parsen: #{aesonFailure}
SecretJSONFieldDecryptFailure: Konnte versteckte vertrauliche Daten nicht entschlüsseln
SubmissionsAlreadyAssigned num@Int64: #{num} Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert:
SubmissionsAssignUnauthorized num@Int64: #{num} Abgaben können momentan nicht einem Korrektor zugeteilt werden (z.B. weil die Abgabe noch offen ist):
UpdatedAssignedCorrectorSingle num@Int64: #{num} Abgaben wurden dem neuen Korrektor zugeteilt.
SubmissionsAlreadyAssigned num@Int64: #{num} #{pluralDE num "Abgabe" "Abgaben"} waren bereits einem Korrektor zugeteilt und wurden nicht verändert:
SubmissionsAssignUnauthorized num@Int64: #{num} #{pluralDE num "Abgabe" "Abgaben"} können momentan nicht einem Korrektor zugeteilt werden (z.B. weil die Abgabe noch offen ist):
UpdatedAssignedCorrectorSingle num@Int64: #{num} #{pluralDE num "Abgabe" "Abgaben"} wurden dem neuen Korrektor zugeteilt.
NoCorrector: Kein Korrektor
RemovedCorrections num@Int64: Korrektur-Daten wurden von #{num} Abgaben entfernt.
UpdatedAssignedCorrectorsAuto num@Int64: #{num} Abgaben wurden unter den Korrektoren aufgeteilt.
RemovedCorrections num@Int64: Korrektur-Daten wurden von #{num} #{pluralDE num "Abgabe" "Abgaben"} entfernt.
UpdatedAssignedCorrectorsAuto num@Int64: #{num} #{pluralDE num "Abgabe" "Abgaben"} wurden unter den Korrektoren aufgeteilt.
UpdatedSheetCorrectorsAutoAssigned n@Int: #{n} #{pluralDE n "Abgabe wurde einem Korrektor" "Abgaben wurden Korrektoren"} zugteilt.
UpdatedSheetCorrectorsAutoFailed n@Int: #{n} #{pluralDE n "Abgabe konnte" "Abgaben konnten"} nicht automatisch zugewiesen werden.
CouldNotAssignCorrectorsAuto num@Int64: #{num} Abgaben konnten nicht automatisch zugewiesen werden:
CouldNotAssignCorrectorsAuto num@Int64: #{num} #{pluralDE num "Abgabe konnte" "Abgaben konnten"} nicht automatisch zugewiesen werden:
SelfCorrectors num@Int64: #{num} Abgaben wurden Abgebenden als eigenem Korrektor zugeteilt!
SubmissionOriginal: Original
@ -604,20 +622,21 @@ RatingNotUnicode uexc@UnicodeException: Bewertungsdatei nicht in UTF-8 kodiert:
RatingMissingSeparator: Präambel der Bewertungsdatei konnte nicht identifziert werden
RatingMultiple: Bewertungen enthält mehrere Punktzahlen für die gleiche Abgabe
RatingInvalid parseErr@Text: Bewertungspunktzahl konnte nicht als Zahl verstanden werden: #{parseErr}
RatingFileIsDirectory: Unerwarteter Fehler: Datei ist unerlaubterweise ein Verzeichnis
RatingFileIsDirectory: Bewertungsdatei ist unerlaubterweise ein Verzeichnis
RatingNegative: Bewertungspunkte dürfen nicht negativ sein
RatingExceedsMax: Bewertung übersteigt die erlaubte Maximalpunktzahl
RatingNotExpected: Keine Bewertungen erlaubt
RatingBinaryExpected: Bewertung muss 0 (=durchgefallen) oder 1 (=bestanden) sein
RatingPointsRequired: Bewertung erfordert für dieses Blatt eine Punktzahl
RatingFile: Bewertungsdatei
SubmissionSinkExceptionDuplicateFileTitle file@FilePath: Dateiname #{show file} kommt mehrfach im Zip-Archiv vor
SubmissionSinkExceptionDuplicateRating: Mehr als eine Bewertung gefunden.
SubmissionSinkExceptionRatingWithoutUpdate: Bewertung gefunden, es ist hier aber keine Bewertung der Abgabe möglich.
SubmissionSinkExceptionForeignRating smid@CryptoFileNameSubmission: Fremde Bewertung für Abgabe #{toPathPiece smid} enthalten. Bewertungen müssen sich immer auf die gleiche Abgabe beziehen!
SubmissionSinkExceptionInvalidFileTitleExtension file@FilePath: Dateiname #{show file} hat keine der für dieses Übungsblatt zulässigen Dateiendungen.
SubmissionSinkExceptionInvalidFileTitleExtension file@FilePath: Dateiname „#{show file}“ hat keine der für dieses Übungsblatt zulässigen Dateiendungen.
MultiSinkException name@Text error@Text: In Abgabe #{name} ist ein Fehler aufgetreten: #{error}
MultiSinkException name@Text error@Text: In Abgabe „#{name}“ ist ein Fehler aufgetreten: #{error}
NoTableContent: Kein Tabelleninhalt
NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter
@ -627,7 +646,7 @@ AdminHeading: Administration
AdminUserHeading: Benutzeradministration
AdminUserRightsHeading: Benutzerrechte
AdminUserAuthHeading: Benutzer-Authentifizierung
AdminUserHeadingFor: Benuterprofil für
AdminUserHeadingFor: Benutzerprofil für
AdminFor: Administrator
LecturerFor: Dozent
LecturersFor: Dozenten
@ -635,7 +654,6 @@ AssistantFor: Assistent
AssistantsFor: Assistenten
TutorsFor n@Int: #{pluralDE n "Tutor" "Tutoren"}
CorrectorsFor n@Int: #{pluralDE n "Korrektor" "Korrektoren"}
ForSchools n@Int: für #{pluralDE n "Institut" "Institute"}
UserListTitle: Komprehensive Benutzerliste
AccessRightsSaved: Berechtigungen erfolgreich verändert
AccessRightsNotChanged: Berechtigungen wurden nicht verändert
@ -647,7 +665,7 @@ DateTimeFormat: Datums- und Uhrzeitformat
DateFormat: Datumsformat
TimeFormat: Uhrzeitformat
DownloadFiles: Dateien automatisch herunterladen
DownloadFilesTip: Wenn gesetzt werden Dateien von Abgaben und Übungsblättern automatisch als Download behandelt, ansonsten ist das Verhalten browserabhängig (es können z.B. PDFs im Browser geöffnet werden).
DownloadFilesTip: Wenn gesetzt werden Dateien automatisch als Download behandelt, ansonsten ist das Verhalten browserabhängig (es können z.B. PDFs im Browser geöffnet werden).
WarningDays: Fristen-Vorschau
WarningDaysTip: Wie viele Tage im Voraus sollen Fristen von Klausuren etc. auf Ihrer Startseite angezeigt werden?
NotificationSettings: Erwünschte Benachrichtigungen
@ -659,6 +677,10 @@ FormCosmetics: Oberfläche
FormPersonalAppearance: Öffentliche Daten
FormFieldRequiredTip: Gekennzeichnete Pflichtfelder sind immer auszufüllen
PersonalInfoExamAchievementsWip: Die Anzeige von Prüfungsergebnissen wird momentan an dieser Stelle leider noch nicht unterstützt.
PersonalInfoOwnTutorialsWip: Die Anzeige von Tutorien, zu denen Sie als Tutor eingetragen sind wird momentan an dieser Stelle leider noch nicht unterstützt.
PersonalInfoTutorialsWip: Die Anzeige von Tutorien, zu denen Sie angemeldet sind wird momentan an dieser Stelle leider noch nicht unterstützt.
ActiveAuthTags: Aktivierte Authorisierungsprädikate
InvalidDateTimeFormat: Ungültiges Datums- und Zeitformat, JJJJ-MM-TTTHH:MM[:SS] Format erwartet
@ -725,8 +747,8 @@ UploadSpecificFileRequired: Zur Abgabe erforderlich
NoSubmissions: Keine Abgabe
CorrectorSubmissions: Abgabe extern mit Pseudonym
UserSubmissions: Direkte Abgabe
BothSubmissions: Abgabe direkt & extern mit Pseudonym
UserSubmissions: Direkte Abgabe in Uni2work
BothSubmissions: Abgabe direkt in Uni2work & extern mit Pseudonym
SheetCorrectorSubmissionsTip: Abgabe erfolgt über ein Uni2work-externes Verfahren (zumeist in Papierform durch Einwurf) unter Angabe eines persönlichen Pseudonyms. Korrektoren können mithilfe des Pseudonyms später Korrekturergebnisse in Uni2work eintragen, damit Sie sie einsehen können.
@ -738,8 +760,10 @@ SubmissionUpdated: Abgabe erfolgreich ersetzt
AdminFeaturesHeading: Studiengänge
StudyTerms: Studiengänge
StudyTerm: Studiengang
NoStudyTermsKnown: Nicht eingeschrieben
NoStudyTermsKnown: Keine Studiengänge bekannt
StudyFeatureInference: Studiengangschlüssel-Inferenz
StudyFeatureInferenceNoConflicts: Keine Konflikte beobachtet
StudyFeatureInferenceConflictsHeading: Studiengangseinträge mit beobachteten Konflikten
StudyFeatureAge: Fachsemester
StudyFeatureDegree: Abschluss
FieldPrimary: Hauptfach
@ -757,9 +781,9 @@ DegreeShort: Abschlusskürzel
StudyTermsKey: Studiengangschlüssel
StudyTermsName: Studiengang
StudyTermsShort: Studiengangkürzel
StudyTermsChangeSuccess: Zuordnung Abschlüsse aktualisiert
StudyDegreeChangeSuccess: Zuordnung Studiengänge aktualisiert
StudyCandidateIncidence: Anmeldevorgang
StudyTermsChangeSuccess: Zuordnung Studiengänge aktualisiert
StudyDegreeChangeSuccess: Zuordnung Abschlüsse aktualisiert
StudyCandidateIncidence: Synchronisation
AmbiguousCandidatesRemoved n@Int: #{show n} #{pluralDE n "uneindeutiger Kandidat" "uneindeutige Kandiaten"} entfernt
RedundantCandidatesRemoved n@Int: #{show n} bereits #{pluralDE n "bekannter Kandidat" "bekannte Kandiaten"} entfernt
CandidatesInferred n@Int: #{show n} neue #{pluralDE n "Studiengangszuordnung" "Studiengangszuordnungen"} inferiert
@ -778,6 +802,8 @@ MailTestDateTime: Test der Datumsformattierung:
German: Deutsch
GermanGermany: Deutsch (Deutschland)
English: Englisch
EnglishEurope: Englisch (Europa)
MailSubjectSubmissionRated csh@CourseShorthand: Ihre #{csh}-Abgabe wurde korrigiert
MailSubmissionRatedIntro courseName@Text termDesc@Text: Ihre Abgabe im Kurs #{courseName} (#{termDesc}) wurde korrigiert.
@ -859,9 +885,9 @@ MailSubjectExamOfficeUserInvitation displayName@Text: Berücksichtigung von Prü
MailSubjectPasswordReset: Uni2work-Passwort ändern bzw. setzen
SheetGrading: Bewertung
SheetGradingPoints maxPoints@Points: #{maxPoints} Punkte
SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{passingPoints} von #{maxPoints} Punkten
SheetGradingPassBinary: Bestanden/Nicht Bestanden
SheetGradingPoints maxPoints@Points: #{maxPoints} #{pluralDE maxPoints "Punkt" "Punkte"}
SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{passingPoints} von #{maxPoints} #{pluralDE maxPoints "Punkt" "Punkten"}
SheetGradingPassBinary: Bestanden/Nicht Bestanden
SheetGradingInfo: "Bestanden nach Punkten" zählt sowohl zur maximal erreichbaren Gesamtpunktzahl also auch zur Anzahl der zu bestehenden Blätter.
SheetGradingCount': Anzahl
@ -915,10 +941,10 @@ NotificationTriggerExamRegistrationSoonInactive: Ich kann mich bald nicht mehr f
NotificationTriggerExamDeregistrationSoonInactive: Ich kann mich bald nicht mehr von einer Prüfung abmelden
NotificationTriggerExamResult: Ich kann ein neues Prüfungsergebnis einsehen
NotificationTriggerAllocationStaffRegister: Ich kann Kurse bei einer neuen Zentralanmeldung eintragen
NotificationTriggerAllocationAllocation: Ich kann Zentralanmeldung-Bewerbungen für einen meiner Kurse bewerten
NotificationTriggerAllocationAllocation: Ich kann Zentralanmeldungs-Bewerbungen für einen meiner Kurse bewerten
NotificationTriggerAllocationRegister: Ich kann mich bei einer neuen Zentralanmeldung bewerben
NotificationTriggerAllocationOutdatedRatings: Zentralanmeldung-Bewerbungen für einen meiner Kurse wurden verändert, nachdem sie bewertet wurden
NotificationTriggerAllocationUnratedApplications: Bewertungen zu Zentralanmeldung-Bewerbungen für einen meiner Kurse stehen aus
NotificationTriggerAllocationOutdatedRatings: Zentralanmeldungs-Bewerbungen für einen meiner Kurse wurden verändert, nachdem sie bewertet wurden
NotificationTriggerAllocationUnratedApplications: Bewertungen zu Zentralanmeldungs-Bewerbungen für einen meiner Kurse stehen aus
NotificationTriggerAllocationResults: Plätze wurden für eine meiner Zentralanmeldungen verteilt
NotificationTriggerExamOfficeExamResults: Ich kann neue Prüfungsergebnisse einsehen
NotificationTriggerExamOfficeExamResultsChanged: Prüfungsergebnisse wurden verändert
@ -936,7 +962,7 @@ NotificationTriggerKindEvaluation: Für Vorlesungsumfragen
NotificationTriggerKindAllocationStaff: Für Zentralanmeldungen (Dozenten)
NotificationTriggerKindAllocationParticipant: Für Zentralanmeldungen
CorrCreate: Abgaben erstellen
CorrCreate: Abgaben registrieren
UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"
InvalidPseudonym pseudonym@Text: Invalides Pseudonym "#{pseudonym}"
InvalidPseudonymSubmissionIgnored oPseudonyms@Text iPseudonym@Text: Abgabe mit Pseudonymen „#{oPseudonyms}“ wurde ignoriert, da „#{iPseudonym}“ nicht automatisiert zu einem validen Pseudonym korrigiert werden konnte.
@ -956,6 +982,10 @@ SheetCreateExisting: Folgende Pseudonyme haben bereits abgegeben:
CorrGrade: Korrekturen eintragen
UserAccountDeleted name@Text: Konto für #{name} wurde gelöscht!
UserSubmissionsDeleted n@Int: #{tshow n} Abgaben wurden unwiderruflich gelöscht.
UserGroupSubmissionsKept n@Int: #{tshow n} Gruppenabgaben verbleiben in der Datenbank, aber die Zuordnung zum Benutzer wurde gelöscht. Gruppenabgaben können dadurch zu Einzelabgaben werden, die dann mit dem letzten Benutzer gelöscht werden.
UserSubmissionGroupsDeleted count@Int64: #{tshow count} benannte Abgabengruppen wurden gelöscht, da sie ohne den Nutzer leer wären.
UserAccountDeleteWarning: Achtung, dies löscht den kompletten Benutzer unwiderruflich und mit allen assoziierten Daten aus der Datenbank. Prüfungsdaten müssen jedoch langfristig gespeichert bleiben!
HelpTitle : Hilfe
HelpAnswer: Antworten an
@ -1028,7 +1058,6 @@ EncodedSecretBoxCouldNotDecodeNonce: Konnte secretbox-nonce nicht dekodieren
EncodedSecretBoxCouldNotOpenSecretBox: Konnte libsodium-secretbox nicht öffnen (Verschlüsselte Daten sind nicht authentisch)
EncodedSecretBoxCouldNotDecodePlaintext aesonErr@String: Konnte Klartext nicht JSON-dekodieren: #{aesonErr}
ErrMsgHeading: Fehlermeldung entschlüsseln
ErrorCryptoIdMismatch: Verschlüsselte Id der Abgabe passte nicht zu anderen Daten
InvalidRoute: Konnte URL nicht interpretieren
@ -1065,6 +1094,7 @@ MenuProfileData: Persönliche Daten
MenuTermCreate: Neues Semester anlegen
MenuCourseNew: Neuen Kurs anlegen
MenuTermEdit: Semester editieren
MenuTermCurrent: Aktuelles Semester
MenuCorrection: Korrektur
MenuCorrections: Korrekturen
MenuCorrectionsOwn: Meine Korrekturen
@ -1093,8 +1123,8 @@ MenuCorrectionsUpload: Korrekturen hochladen
MenuCorrectionsDownload: Offene Abgaben herunterladen
MenuCorrectionsCreate: Abgaben registrieren
MenuCorrectionsGrade: Abgaben online korrigieren
MenuCorrectionsAssign: Zuteilung Korrekturen
MenuCorrectionsAssignSheet name@Text: Zuteilung Korrekturen von #{name}
MenuCorrectionsAssign: Zuteilung der Korrekturen
MenuCorrectionsAssignSheet name@Text: Zuteilung der Korrekturen von #{name}
MenuAuthPreds: Authorisierungseinstellungen
MenuTutorialDelete: Tutorium löschen
MenuTutorialEdit: Tutorium editieren
@ -1108,7 +1138,7 @@ MenuExamAddMembers: Prüfungsteilnehmer hinzufügen
MenuExamOfficeExams: Prüfungen
MenuExamOfficeFields: Fächer
MenuExamOfficeUsers: Benutzer
MenuLecturerInvite: Dozenten hinzufügen
MenuLecturerInvite: Funktionäre hinzufügen
MenuAllocationInfo: Hinweise zum Ablauf einer Zentralanmeldung
MenuCourseApplicationsFiles: Dateien aller Bewerbungen
MenuSchoolList: Institute
@ -1118,6 +1148,61 @@ MenuCourseNewsEdit: Kursnachricht bearbeiten
MenuCourseEventNew: Neuer Kurstermin
MenuCourseEventEdit: Kurstermin bearbeiten
BreadcrumbSubmissionFile: Datei
BreadcrumbSubmissionUserInvite: Einladung zur Abgabe
BreadcrumbCryptoIDDispatch: CryptoID-Weiterleitung
BreadcrumbCourseAppsFiles: Bewerbungsdateien
BreadcrumbCourseNotes: Kursnotizen
BreadcrumbHiWis: Korrektoren
BreadcrumbMaterial: Material
BreadcrumbSheet: Übungsblatt
BreadcrumbTutorial: Tutorium
BreadcrumbExam: Prüfung
BreadcrumbApplicant: Bewerber
BreadcrumbCourseRegister: Anmelden
BreadcrumbCourseRegisterTemplate: Bewerbungsvorlagen
BreadcrumbCourseFavourite: Favorisieren
BreadcrumbCourse: Kurs
BreadcrumbAllocationRegister: Teilnahme registrieren
BreadcrumbAllocation: Zentralanmeldung
BreadcrumbTerm: Semester
BreadcrumbSchool: Institut
BreadcrumbUser: Benutzer
BreadcrumbStatic: Statische Resource
BreadcrumbFavicon: Favicon
BreadcrumbRobots: robots.txt
BreadcrumbMetrics: Metriken
BreadcrumbLecturerInvite: Einladung zum Kursverwalter
BreadcrumbExamOfficeUserInvite: Einladung bzgl. Prüfungsleistungen
BreadcrumbFunctionaryInvite: Einladung zum Instituts-Funktionär
BreadcrumbUserDelete: Nutzer-Account löschen
BreadcrumbUserHijack: Nutzer-Sitzung übernehmen
BreadcrumbSystemMessage: Statusmeldung
BreadcrumbSubmission: Abgabe
BreadcrumbCourseNews: Kursnachricht
BreadcrumbCourseNewsDelete: Kursnachricht löschen
BreadcrumbCourseEventDelete: Kurstermin löschen
BreadcrumbProfile: Einstellungen
BreadcrumbAllocationInfo: Ablauf einer Zentralanmeldung
BreadcrumbCourseParticipantInvitation: Einladung zum Kursteilnehmer
BreadcrumbMaterialArchive: Archiv
BreadcrumbMaterialFile: Datei
BreadcrumbSheetArchive: Dateien
BreadcrumbSheetIsCorrector: Korrektor-Überprüfung
BreadcrumbSheetPseudonym: Pseudonym
BreadcrumbSheetCorrectorInvite: Einladung zum Korrektor
BreadcrumbSheetFile: Datei
BreadcrumbTutorialRegister: Anmelden
BreadcrumbTutorInvite: Einladung zum Tutor
BreadcrumbExamCorrectorInvite: Einladung zum Prüfungskorrektor
BreadcrumbExamParticipantInvite: Einladung zum Prüfungsteilnehmer
BreadcrumbExamRegister: Anmelden
BreadcrumbApplicationFiles: Bewerbungsdateien
BreadcrumbCourseNewsArchive: Archiv
BreadcrumbCourseNewsFile: Datei
TitleMetrics: Metriken
AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren.
AuthPredsActive: Aktive Authorisierungsprädikate
AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert
@ -1196,7 +1281,7 @@ RGTutorialParticipants: Tutorium-Teilnehmer
MultiSelectFieldTip: Mehrfach-Auswahl ist möglich (Umschalt bzw. Strg)
MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Addressen möglich
EmailInvitationWarning: Dem System ist kein Nutzer mit dieser Addresse bekannt. Es wird eine Einladung per E-Mail versandt.
EmailInvitationWarning: Diese Adresse konnte mit Ihren aktuellen Rechten keinem Uni2work-Benutzer zugeordnet werden (ggf. unter gewissen Einschränkungen). Es wird eine Einladung per E-Mail versandt.
LecturerInvitationAccepted lType@Text csh@CourseShorthand: Sie wurden als #{lType} für #{csh} eingetragen
LecturerInvitationDeclined csh@CourseShorthand: Sie haben die Einladung, Kursverwalter für #{csh} zu werden, abgelehnt
@ -1289,7 +1374,7 @@ TutorialTutorControlled: Tutoren dürfen Tutorium editieren
TutorialTutorControlledTip: Sollen Tutoren beliebige Aspekte dieses Tutoriums (Name, Registrierungs-Gruppe, Raum, Zeit, andere Tutoren, ...) beliebig editieren dürfen?
CourseExams: Prüfungen
CourseTutorials: Übungen
CourseTutorials: Tutorien
ParticipantsN n@Int: #{n} Teilnehmer
TutorialDeleteQuestion: Wollen Sie das unten aufgeführte Tutorium wirklich löschen?
@ -1412,7 +1497,7 @@ ExamBonusRoundNonPositive: Vielfaches, auf das gerundet werden soll, muss positi
ExamBonusRoundTip: Bonuspunkte werden kaufmännisch auf ein Vielfaches der angegeben Zahl gerundet.
ExamAutomaticOccurrenceAssignment: Automatische Termin- bzw. Raumzuteilung
ExamAutomaticOccurrenceAssignmentTip: Sollen Prüfungsteilnehmer zum Zeitpunkt der Bekanntgabe der Raum- bzw. Terminzuteilung automatisch auf die zur Verfügung stehenden Räume bzw. Termine verteilt werden? Manuelle Umverteilung bzw. vorheriges Festlegen von Zuteilungen einzelner Teilnehmer ist trotzdem möglich.
ExamAutomaticOccurrenceAssignmentTip: Sollen Prüfungsteilnehmer automatisch auf die zur Verfügung stehenden Räume bzw. Termine verteilt werden? Manuelle Umverteilung bzw. vorheriges Festlegen von Zuteilungen einzelner Teilnehmer ist trotzdem möglich.
ExamOccurrenceRule: Verfahren
ExamOccurrenceRuleParticipant: Termin- bzw. Raumzuteilungsverfahren
ExamRoomManual': Keine automatische Zuteilung
@ -1457,7 +1542,7 @@ ExamPartName: Titel
ExamPartNameTip: Wird den Studierenden angezeigt
ExamPartMaxPoints: Maximalpunktzahl
ExamPartWeight: Gewichtung
ExamPartWeightTip: Wird vor Anzeige oder Notenberechnung mit der erreichten Punktzahl und der Maximalpunktzahl multipliziert; Änderungen hier passen auch bestehende Korrekturergebnisse an
ExamPartWeightTip: Wird vor Anzeige oder automatischen Notenberechnung mit der erreichten Punktzahl und der Maximalpunktzahl multipliziert; Änderungen hier passen also auch bestehende Korrekturergebnisse an (derart geänderte Noten müssen erneut manuell übernommen werden)
ExamPartResultPoints: Erreichte Punkte
ExamNameTaken exam@ExamName: Es existiert bereits eine Prüfung mit Namen #{exam}
@ -1527,6 +1612,8 @@ ExamUserMarkedSynchronised n@Int: #{n} #{pluralDE n "Prüfungsleistung" "Prüfun
ExamOfficeExamUsersHeading: Prüfungsleistungen
CsvFile: CSV-Datei
CsvImport: CSV-Import
CsvExport: CSV-Export
CsvModifyExisting: Existierende Einträge angleichen
CsvAddNew: Neue Einträge einfügen
CsvDeleteMissing: Fehlende Einträge entfernen
@ -1681,6 +1768,7 @@ SchoolFunctionInvitationAccepted school@SchoolName renderedFunction@Text: #{rend
AllocationActive: Aktiv
AllocationName: Name
AllocationAvailableCourses: Kurse
AllocationApplication: Bewerbung
AllocationAppliedCourses: Bewerbungen
AllocationNumCoursesAvailableApplied available@Int applied@Int: Sie haben sich bisher für #{applied}/#{available} #{pluralDE applied "Kurs" "Kursen"} beworben
AllocationTitle termText@Text ssh'@SchoolShorthand allocation@AllocationName: #{termText} - #{ssh'}: #{allocation}
@ -1879,7 +1967,7 @@ AcceptApplicationsSecondaryRandom: Zufällig
AcceptApplicationsSecondaryTime: Nach Zeitpunkt der Bewerbung
CsvOptions: CSV-Optionen
CsvOptionsTip: Diese Einstellungen betreffen nur den CSV-Export; beim Import werden die verwendeten Einstellungen automatisch ermittelt. Als Zeichenkodierung wird beim Import stets Unicode erwartet.
CsvOptionsTip: Diese Einstellungen betreffen primär den CSV-Export; beim Import werden die meisten Einstellungen automatisch ermittelt. Als Zeichenkodierung wird beim Import die selbe Kodierung wie beim Export erwartet.
CsvFormatOptions: Dateiformat
CsvTimestamp: Zeitstempel
CsvTimestampTip: Soll an den Namen jeder exportierten CSV-Datei ein Zeitstempel vorne angehängt werden?
@ -1898,6 +1986,7 @@ CsvDelimiterNull: Null-Byte
CsvDelimiterTab: Tabulator
CsvDelimiterComma: Komma
CsvDelimiterColon: Doppelpunkt
CsvDelimiterSemicolon: Strichpunkt
CsvDelimiterBar: Senkrechter Strich
CsvDelimiterSpace: Leerzeichen
CsvDelimiterUnitSep: Teilgruppentrennzeichen
@ -1989,5 +2078,67 @@ ShowSex: Geschlechter anderer Nutzer anzeigen
ShowSexTip: Sollen in Kursteilnehmer-Tabellen u.Ä. die Geschlechter der Nutzer angezeigt werden?
StudySubTermsParentKey: Elter
StudyTermsDefaultDegree: Abschluss
StudyTermsDefaultFieldType: Typ
StudyTermsDefaultDegree: Default Abschluss
StudyTermsDefaultFieldType: Default Typ
MenuLanguage: Sprache
LanguageChanged: Sprache erfolgreich geändert
ProfileCorrector: Korrektor
ProfileCourses: Eigene Kurse
ProfileCourseParticipations: Kursanmeldungen
ProfileCourseExamResults: Prüfungsleistungen
ProfileTutorials: Eigene Tutorien
ProfileTutorialParticipations: Tutorien
ProfileSubmissionGroups: Abgabegruppen
ProfileSubmissions: Abgaben
ProfileRemark: Hinweis
ProfileGroupSubmissionDates: Bei Gruppenabgaben wird kein Datum angezeigt, wenn Sie die Gruppenabgabe nie selbst hochgeladen haben.
ProfileCorrectorRemark: Die oberhalb angezeigte Tabelle zeigt nur prinzipielle Einteilungen als Korrektor zu einem Übungsblatt. Auch ohne Einteilung können Korrekturen einzeln zugewiesen werden, welche hier dann nicht aufgeführt werden.
ProfileCorrections: Auflistung aller zugewiesenen Korrekturen
GroupSizeNotNatural: „Gruppengröße“ muss eine natürliche Zahl sein
AmbiguousEmail: E-Mail Adresse nicht eindeutig
CourseDescriptionPlaceholder: Bitte mindestens die Modulbeschreibung angeben
CourseHomepageExternalPlaceholder: Optionale externe URL
PointsPlaceholder: Punktezahl
RFC1766: RFC1766-Sprachcode
TermShort: Kürzel
TermCourseCount: Kurse
TermStart: Semesteranfang
TermEnd: Semesterende
TermStartMustMatchName: Jahreszahl im Namenskürzel stimmt nicht mit Semesterbeginn überein.
TermEndMustBeAfterStart: Semester darf nicht enden, bevor es beginnt.
TermLectureEndMustBeAfterStart: Vorlesungszeit muss vor ihrem Ende anfgangen.
TermStartMustBeBeforeLectureStart: Semester muss vor der Vorlesungszeit beginnen.
TermEndMustBeAfterLectureEnd: Vorlesungszeit muss vor dem Semester enden.
AdminPageEmpty: Diese Seite soll eine Übersichtsseite für Administratoren werden. Aktuell finden sich hier nur Links zu wichtigen Administrator-Funktionalitäten.
HaveCorrectorAccess sheetName@SheetName: Sie haben Korrektor-Zugang zu #{original sheetName}.
FavouritesPlaceholder: Anzahl Favoriten
FavouritesNotNatural: Anzahl der Favoriten muss eine natürliche Zahl sein!
FavouritesSemestersPlaceholder: Anzahl Semester
FavouritesSemestersNotNatural: Anzahl der Favoriten-Semester muss eine natürliche Zahl sein!
ProfileTitle: Benutzereinstellungen
GlossaryTitle: Begriffsverzeichnis
MenuGlossary: Begriffsverzeichnis
Applicant: Bewerber
CourseParticipant: Kursteilnehmer
Administrator: Administrator
CsvFormat: CSV-Format
ExerciseSheet: Übungsblatt
DefinitionCourseEvents: Kurstermine
DefinitionCourseNews: Kurs-Aktuelles
Invitations: Einladungen
SheetSubmission: Abgabe
CommCourse: Kursmitteilung
CommTutorial: Tutorium-Mitteilung
Clone: Klonen
Deficit: Defizit
MetricNoSamples: Keine Messwerte
MetricName: Name
MetricValue: Wert

2139
messages/uniworx/en-eu.msg Normal file
View File

File diff suppressed because it is too large Load Diff

6
models/files.model
View File

@ -6,3 +6,9 @@ File
content ByteString Maybe -- Nothing iff this is a directory
modified UTCTime
deriving Show Eq Generic
SessionFile
user UserId
reference SessionFileReference
file FileId
touched UTCTime

7
models/jobs.model
View File

@ -16,3 +16,10 @@ CronLastExec
time UTCTime -- When was the job executed
instance InstanceId -- Which uni2work-instance did the work
UniqueCronLastExec job
SentNotification
content Value
user UserId
time UTCTime
instance InstanceId

4
models/sheets.model
View File

@ -6,8 +6,8 @@ Sheet -- exercise sheet for a given course
grouping SheetGroup -- May participants submit in groups of certain sizes?
markingText Html Maybe -- Instructons for correctors, included in marking templates
visibleFrom UTCTime Maybe -- Invisible to enrolled participants before
activeFrom UTCTime -- Download of questions and submission is permitted afterwards
activeTo UTCTime -- Submission is only permitted before
activeFrom UTCTime Maybe -- Download of questions and submission is permitted afterwards
activeTo UTCTime Maybe -- Submission is only permitted before
hintFrom UTCTime Maybe -- Additional files are made available
solutionFrom UTCTime Maybe -- Solution is made available
submissionMode SubmissionMode -- Submission upload by students and/or through tutors?

13
models/users.model
View File

@ -28,7 +28,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create
dateFormat DateTimeFormat "default='%d.%m.%Y'" -- preferred Date-only display format for user; user-defined
timeFormat DateTimeFormat "default='%R'" -- preferred Time-only display format for user; user-defined
downloadFiles Bool default=false -- Should files be opened in browser or downloaded? (users often oblivious that their browser has a setting for this)
mailLanguages MailLanguages "default='[]'::jsonb" -- Preferred language for eMail; i18n not yet implemented; user-defined
languages Languages Maybe -- Preferred language; user-defined
notificationSettings NotificationSettings -- Bit-array for which events email notifications are requested by user; user-defined
warningDays NominalDiffTime default=1209600 -- timedistance to pending deadlines for homepage infos
csvOptions CsvOptions "default='{}'::jsonb"
@ -102,4 +102,13 @@ StudySubTermParentCandidate
StudyTermStandaloneCandidate
incidence TermCandidateIncidence
key Int
deriving Show Eq Ord
deriving Show Eq Ord
UserGroupMember
group UserGroupName
user UserId
primary Checkmark nullable
UniquePrimaryUserGroupMember group primary !force
UniqueUserGroupMember group user

2
package-lock.json generated
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "7.19.2",
"version": "7.25.1",
"lockfileVersion": 1,
"requires": true,
"dependencies": {

10
package.json
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "7.19.2",
"version": "7.25.1",
"description": "",
"keywords": [],
"author": "",
@ -42,10 +42,10 @@
"scripts": {
"postbump": "./sync-versions.hs && git add -- package.yaml"
},
"commitUrlFormat": "https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/{{hash}}",
"compareUrlFormat": "https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/{{previousTag}}...{{currentTag}}",
"issueUrlFormat": "https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/{{id}}",
"userUrlFormat": "https://gitlab.cip.ifi.lmu.de/{{user}}"
"commitUrlFormat": "https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/{{hash}}",
"compareUrlFormat": "https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/{{previousTag}}...{{currentTag}}",
"issueUrlFormat": "https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/{{id}}",
"userUrlFormat": "https://gitlab2.rz.ifi.lmu.de/{{user}}"
},
"browserslist": [
"defaults"

11
package.yaml
View File

@ -1,5 +1,5 @@
name: uniworx
version: 7.19.2
version: 7.25.1
dependencies:
- base >=4.9.1.0 && <5
@ -140,6 +140,10 @@ dependencies:
- retry
- generic-lens
- array
- cookie
- prometheus-client
- prometheus-metrics-ghc
- wai-middleware-prometheus
other-extensions:
- GeneralizedNewtypeDeriving
@ -233,10 +237,7 @@ executables:
uniworx:
main: main.hs
source-dirs: app
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
ghc-options: -threaded -rtsopts "-with-rtsopts=-N -T"
dependencies:
- uniworx
when:

6
routes
View File

@ -40,7 +40,8 @@
/auth AuthR Auth getAuth !free
/favicon.ico FaviconR GET !free
/robots.txt RobotsR GET !free
/robots.txt RobotsR GET !free
/metrics MetricsR GET
/ HomeR GET !free
/users UsersR GET POST -- no tags, i.e. admins only
@ -63,6 +64,7 @@
/info/lecturer InfoLecturerR GET !lecturer
/info/data DataProtR GET !free
/info/allocation InfoAllocationR GET !free
/info/glossary GlossaryR GET !free
/impressum ImpressumR GET !free
/version VersionR GET !free
@ -73,6 +75,7 @@
/user/authpreds AuthPredsR GET POST !free
/user/set-display-email SetDisplayEmailR GET POST !free
/user/csv-options CsvOptionsR GET POST !free
/user/lang LangR POST !free
/exam-office ExamOfficeR !exam-office:
/ EOExamsR GET
@ -141,7 +144,6 @@
/invite SInviteR GET POST !ownerANDtimeANDuser-submissions
!/#SubmissionFileType SubArchiveR GET !owner !corrector
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector
/correctors SCorrR GET POST
/iscorrector SIsCorrR GET !corrector -- Route is used to check for corrector access to this sheet
/pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions
/corrector-invite/ SCorrInviteR GET POST

120
src/Application.hs
View File

@ -22,6 +22,8 @@ import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr,
import Import hiding (cancel)
import Language.Haskell.TH.Syntax (qLocation)
import Network.Wai (Middleware)
import qualified Network.Wai as Wai
import qualified Network.HTTP.Types as HTTP
import Network.Wai.Handler.Warp (Settings, defaultSettings,
defaultShouldDisplayException,
runSettings, runSettingsSocket, setHost,
@ -48,6 +50,7 @@ import System.Directory
import Jobs
import qualified Data.Text.Encoding as Text
import Yesod.Auth.Util.PasswordStore
import qualified Data.ByteString.Lazy as LBS
@ -81,12 +84,20 @@ import Network.Socket (socketPort, Socket, PortNumber)
import qualified Network.Socket as Socket (close)
import Control.Concurrent.STM.Delay
import Control.Monad.STM (retry)
import Control.Monad.Trans.Cont (runContT, callCC)
import qualified Data.Set as Set
import Data.Semigroup (Max(..), Min(..))
import Data.Semigroup (Min(..))
import qualified Prometheus.Metric.GHC as Prometheus
import qualified Prometheus
import Data.Time.Clock.POSIX
import Handler.Utils.Routes (classifyHandler)
import Data.List (cycle)
-- Import all relevant handler modules here.
-- (HPack takes care to add new modules to our cabal file nowadays.)
@ -111,6 +122,7 @@ import Handler.Health
import Handler.Exam
import Handler.Allocation
import Handler.ExamOffice
import Handler.Metrics
-- This line actually creates our YesodDispatch instance. It is the second half
@ -124,6 +136,8 @@ mkYesodDispatch "UniWorX" resourcesUniWorX
-- migrations handled by Yesod.
makeFoundation :: (MonadResource m, MonadUnliftIO m) => AppSettings -> m UniWorX
makeFoundation appSettings'@AppSettings{..} = do
void $ Prometheus.register Prometheus.ghcMetrics
-- Some basic initializations: HTTP connection manager, logger, and static
-- subsite.
appHttpManager <- newManager
@ -290,7 +304,39 @@ makeApplication foundation = liftIO $ do
logWare <- makeLogWare foundation
-- Create the WAI application and apply middlewares
appPlain <- toWaiAppPlain foundation
return $ logWare $ defaultMiddlewaresNoLogging appPlain
return . prometheusMiddleware . logWare $ defaultMiddlewaresNoLogging appPlain
where
prometheusMiddleware :: Middleware
prometheusMiddleware app req respond' = do
start <- getPOSIXTime
app req $ \res -> do
end <- getPOSIXTime
let method = decodeUtf8 $ Wai.requestMethod req
status = tshow . HTTP.statusCode $ Wai.responseStatus res
route :: Maybe (Route UniWorX)
route = parseRoute ( Wai.pathInfo req
, over (mapped . _2) (fromMaybe "") . HTTP.queryToQueryText $ Wai.queryString req
)
handler' = pack . classifyHandler <$> route
labels :: Prometheus.Label3
labels = (fromMaybe "n/a" handler', method, status)
Prometheus.withLabel requestLatency labels . flip Prometheus.observe . realToFrac $ end - start
respond' res
{-# NOINLINE requestLatency #-}
requestLatency :: Prometheus.Vector Prometheus.Label3 Prometheus.Histogram
requestLatency = Prometheus.unsafeRegister
$ Prometheus.vector ("handler", "method", "status")
$ Prometheus.histogram info buckets
where info = Prometheus.Info "http_request_duration_seconds"
"HTTP request latency"
buckets = map fromRational . takeWhile (<= 500) . go 50e-6 $ cycle [2, 2, 2.5]
where
go n [] = [n]
go n (f:fs) = n : go (f * n) fs
makeLogWare :: MonadIO m => UniWorX -> m Middleware
makeLogWare app = do
@ -320,13 +366,22 @@ makeLogWare app = do
logWare <- either mkLogWare return lookupRes
logWare wai req fin
data ReadySince = MkReadySince
-- | Warp settings for the given foundation value.
warpSettings :: UniWorX -> Settings
warpSettings foundation = defaultSettings
& setBeforeMainLoop (runAppLoggingT foundation $ do
let notifyReady = do
$logInfoS "setup" "Ready"
void $ liftIO Systemd.notifyReady
void . liftIO $ do
void . Prometheus.register . readyMetric =<< getCurrentTime
Systemd.notifyReady
readyMetric ts = Prometheus.Metric $ return (MkReadySince, collectReadySince)
where
collectReadySince = return [Prometheus.SampleGroup info Prometheus.GaugeType [Prometheus.Sample "ready_time" [] sample]]
info = Prometheus.Info "ready_time" "POSIXTime this Uni2work-instance became ready"
sample = encodeUtf8 . tshow . (realToFrac :: POSIXTime -> Nano) $ utcTimeToPOSIXSeconds ts
if
| foundation ^. _appHealthCheckDelayNotify
-> void . forkIO $ do
@ -425,39 +480,46 @@ appMain = runResourceT $ do
case watchdogMicroSec of
Just wInterval
| maybe True (== myProcessID) watchdogProcess
-> let notifyWatchdog :: IO ()
-> let notifyWatchdog :: forall a. IO a
notifyWatchdog = runAppLoggingT foundation $ go Nothing
where
go pStatus = do
d <- liftIO . newDelay . floor $ wInterval % 2
go :: Maybe (Set (UTCTime, HealthReport)) -> LoggingT IO a
go pResults = do
let delay = floor $ wInterval % 2
d <- liftIO $ newDelay delay
status <- atomically $ asum
[ Nothing <$ waitDelay d
, Just <$> do
$logDebugS "Notify" $ "Waiting up to " <> tshow delay <> "µs..."
mResults <- atomically $ asum
[ pResults <$ waitDelay d
, do
results <- readTVar $ foundation ^. _appHealthReport
case fromNullable results of
Nothing -> retry
Just rs -> do
let status = ofoldMap1 (Max *** Min . healthReportStatus) rs
guard $ pStatus /= Just status
return status
guardOn (pResults /= Just results) $ Just results
]
case status of
Just (_, Min status') -> do
$logInfoS "NotifyStatus" $ toPathPiece status'
liftIO . void . Systemd.notifyStatus . unpack $ toPathPiece status'
Nothing -> return ()
$logDebugS "Notify" "Checking for status/watchdog..."
(*> go mResults) . void . runMaybeT $ do
results <- hoistMaybe mResults
case status of
Just (_, Min HealthSuccess) -> do
$logInfoS "NotifyWatchdog" "Notify"
liftIO $ void Systemd.notifyWatchdog
_other -> return ()
Min status <- hoistMaybe $ ofoldMap1 (Min . healthReportStatus . view _2) <$> fromNullable results
$logInfoS "NotifyStatus" $ toPathPiece status
liftIO . void . Systemd.notifyStatus . unpack $ toPathPiece status
go status
in void $ allocateLinkedAsync notifyWatchdog
_other -> return ()
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
in do
$logDebugS "Notify" "Spawning notify thread..."
void $ allocateLinkedAsync notifyWatchdog
_other -> $logWarnS "Notify" "Not sending notifications of status/poking watchdog"
let runWarp socket = runSettingsSocket (warpSettings foundation) socket app
case sockets of

5
src/Auth/Dummy.hs
View File

@ -13,6 +13,7 @@ import qualified Data.CaseInsensitive as CI
data DummyMessage = MsgDummyIdent
| MsgDummyIdentPlaceholder
| MsgDummyNoFormData
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
@ -24,7 +25,9 @@ dummyForm :: ( RenderMessage (HandlerSite m) FormMessage
, Button (HandlerSite m) ButtonSubmit
, MonadHandler m
) => AForm m (CI Text)
dummyForm = areq (ciField & addDatalist userList) (fslI MsgDummyIdent & noAutocomplete) Nothing
dummyForm = wFormToAForm $ do
mr <- getMessageRender
aFormToWForm $ areq (ciField & addDatalist userList) (fslpI MsgDummyIdent (mr MsgDummyIdentPlaceholder) & noAutocomplete & addName PostLoginDummy) Nothing
where
userList = fmap mkOptionList . runDB $ withReaderT projectBackend (map toOption <$> selectList [] [Asc UserIdent] :: ReaderT SqlBackend _ [Option UserIdent])
toOption (Entity _ User{..}) = Option userDisplayName userIdent (CI.original userIdent)

3
src/Auth/LDAP.hs
View File

@ -36,6 +36,7 @@ data CampusLogin = CampusLogin
data CampusMessage = MsgCampusIdentPlaceholder
| MsgCampusIdent
| MsgCampusPassword
| MsgCampusPasswordPlaceholder
| MsgCampusSubmit
| MsgCampusInvalidCredentials
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
@ -130,7 +131,7 @@ campusForm = do
MsgRenderer mr <- getMsgRenderer
ident <- wreq ciField (fslpI MsgCampusIdent (mr MsgCampusIdentPlaceholder) & addAttr "autofocus" "") Nothing
password <- wreq passwordField (fslI MsgCampusPassword) Nothing
password <- wreq passwordField (fslpI MsgCampusPassword (mr MsgCampusPasswordPlaceholder)) Nothing
return $ CampusLogin
<$> ident

10
src/Auth/PWHash.hs
View File

@ -22,7 +22,9 @@ data HashLogin = HashLogin
} deriving (Generic, Typeable)
data PWHashMessage = MsgPWHashIdent
| MsgPWHashIdentPlaceholder
| MsgPWHashPassword
| MsgPWHashPasswordPlaceholder
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
@ -30,9 +32,11 @@ hashForm :: ( RenderMessage (HandlerSite m) FormMessage
, RenderMessage (HandlerSite m) PWHashMessage
, MonadHandler m
) => AForm m HashLogin
hashForm = HashLogin
<$> areq ciField (fslpI MsgPWHashIdent "Identifikation") Nothing
<*> areq passwordField (fslpI MsgPWHashPassword "Passwort") Nothing
hashForm = wFormToAForm $ do
mr <- getMessageRender
aFormToWForm $ HashLogin
<$> areq ciField (fslpI MsgPWHashIdent (mr MsgPWHashIdentPlaceholder)) Nothing
<*> areq passwordField (fslpI MsgPWHashPassword (mr MsgPWHashPasswordPlaceholder)) Nothing
hashLogin :: forall site.

12
src/Cron.hs
View File

@ -155,7 +155,7 @@ nextCronMatch :: TZ -- ^ Timezone of the `Cron`-Entry
-> UTCTime -- ^ Current time, used only for `CronCalendar`
-> Cron
-> CronNextMatch UTCTime
nextCronMatch tz mPrev prec now c@Cron{..} = case notAfter of
nextCronMatch tz mPrev prec now c@Cron{..} = onlyOnceWithinPrec $ case notAfter of
MatchAsap -> MatchNone
MatchAt ts
| MatchAt ts' <- nextMatch
@ -165,6 +165,16 @@ nextCronMatch tz mPrev prec now c@Cron{..} = case notAfter of
| otherwise -> MatchNone
MatchNone -> nextMatch
where
onlyOnceWithinPrec sched = case mPrev of
Nothing -> sched
Just prevT -> case sched of
MatchAsap
| now >= addUTCTime prec prevT -> MatchAsap
| otherwise -> MatchAt $ addUTCTime prec prevT
MatchAt ts -> let ts' = max ts $ addUTCTime prec prevT
in if | ts' <= addUTCTime prec now -> MatchAsap
| otherwise -> MatchAt ts'
MatchNone -> MatchNone
notAfter
| Right c' <- cronNotAfter
, Just ref <- notAfterRef

20
src/Data/Universe/Instances/Reverse/WithIndex.hs Normal file
View File

@ -0,0 +1,20 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Universe.Instances.Reverse.WithIndex
(
) where
import ClassyPrelude
import Data.Universe
import Control.Lens.Indexed
import Data.Universe.Instances.Reverse ()
import qualified Data.Map as Map
instance Finite a => FoldableWithIndex a ((->) a) where
ifoldMap f g = fold [ f x (g x) | x <- universeF ]
instance (Ord a, Finite a) => TraversableWithIndex a ((->) a) where
itraverse f g = (Map.!) . Map.fromList <$> sequenceA [ (x, ) <$> f x (g x) | x <- universeF ]

4
src/Database/Esqueleto/Utils.hs
View File

@ -19,6 +19,7 @@ module Database.Esqueleto.Utils
, sha256
, maybe
, SqlProject(..)
, (->.)
, module Database.Esqueleto.Utils.TH
) where
@ -246,3 +247,6 @@ instance (PersistEntity val, PersistField typ) => SqlProject val typ (E.Entity v
instance (PersistEntity val, PersistField typ) => SqlProject val typ (Maybe (E.Entity val)) (Maybe typ) where
sqlProject = (E.?.)
unSqlProject _ _ = Just
(->.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value b)
(->.) expr t = E.unsafeSqlBinOp "->" expr $ E.val t

847
src/Foundation.hs
View File

File diff suppressed because it is too large Load Diff

313
src/Foundation/I18n.hs Normal file
View File

@ -0,0 +1,313 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Foundation.I18n
( UniWorXMessage(..)
, ShortTermIdentifier(..)
, MsgLanguage(..)
, ShortSex(..)
, SheetTypeHeader(..)
, ShortStudyDegree(..)
, ShortStudyTerms(..)
, StudyDegreeTerm(..)
, ShortStudyFieldType(..)
, StudyDegreeTermType(..)
, ErrorResponseTitle(..)
, UniWorXMessages(..)
, uniworxMessages
) where
import Foundation.Type
import Import.NoFoundation
import Auth.LDAP
import Auth.PWHash
import Auth.Dummy
import Data.CaseInsensitive (original, mk)
import qualified Data.Text as Text
import Utils.Form
import Text.Shakespeare.Text (st)
import GHC.Exts (IsList(..))
pluralDE :: (Eq a, Num a)
=> a -- ^ Count
-> Text -- ^ Singular
-> Text -- ^ Plural
-> Text
pluralDE num singularForm pluralForm
| num == 1 = singularForm
| otherwise = pluralForm
noneOneMoreDE :: (Eq a, Num a)
=> a -- ^ Count
-> Text -- ^ None
-> Text -- ^ Singular
-> Text -- ^ Plural
-> Text
noneOneMoreDE num noneText singularForm pluralForm
| num == 0 = noneText
| num == 1 = singularForm
| otherwise = pluralForm
-- noneMoreDE :: (Eq a, Num a)
-- => a -- ^ Count
-- -> Text -- ^ None
-- -> Text -- ^ Some
-- -> Text
-- noneMoreDE num noneText someText
-- | num == 0 = noneText
-- | otherwise = someText
pluralEN :: (Eq a, Num a)
=> a -- ^ Count
-> Text -- ^ Singular
-> Text -- ^ Plural
-> Text
pluralEN num singularForm pluralForm
| num == 1 = singularForm
| otherwise = pluralForm
noneOneMoreEN :: (Eq a, Num a)
=> a -- ^ Count
-> Text -- ^ None
-> Text -- ^ Singular
-> Text -- ^ Plural
-> Text
noneOneMoreEN num noneText singularForm pluralForm
| num == 0 = noneText
| num == 1 = singularForm
| otherwise = pluralForm
-- noneMoreEN :: (Eq a, Num a)
-- => a -- ^ Count
-- -> Text -- ^ None
-- -> Text -- ^ Some
-- -> Text
-- noneMoreEN num noneText someText
-- | num == 0 = noneText
-- | otherwise = someText
ordinalEN :: ToMessage a
=> a
-> Text
ordinalEN (toMessage -> numStr) = case lastChar of
Just '1' -> [st|#{numStr}st|]
Just '2' -> [st|#{numStr}nd|]
Just '3' -> [st|#{numStr}rd|]
_other -> [st|#{numStr}th|]
where
lastChar = last <$> fromNullable numStr
-- Convenience Type for Messages, since Yesod messages cannot deal with compound type identifiers
type IntMaybe = Maybe Int
-- | Convenience function for i18n messages definitions
maybeToMessage :: ToMessage m => Text -> Maybe m -> Text -> Text
maybeToMessage _ Nothing _ = mempty
maybeToMessage before (Just x) after = before <> toMessage x <> after
-- Messages creates type UniWorXMessage and RenderMessage UniWorX instance
mkMessage "UniWorX" "messages/uniworx" "de-de-formal"
mkMessageVariant "UniWorX" "Campus" "messages/campus" "de"
mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de"
mkMessageVariant "UniWorX" "PWHash" "messages/pw-hash" "de"
mkMessageVariant "UniWorX" "Button" "messages/button" "de"
mkMessageVariant "UniWorX" "Frontend" "messages/frontend" "de-de-formal"
instance RenderMessage UniWorX TermIdentifier where
renderMessage foundation ls TermIdentifier{..} = case season of
Summer -> renderMessage' $ MsgSummerTerm year
Winter -> renderMessage' $ MsgWinterTerm year
where renderMessage' = renderMessage foundation ls
newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier
deriving stock (Eq, Ord, Read, Show)
instance RenderMessage UniWorX ShortTermIdentifier where
renderMessage foundation ls (ShortTermIdentifier TermIdentifier{..}) = case season of
Summer -> renderMessage' $ MsgSummerTermShort year
Winter -> renderMessage' $ MsgWinterTermShort year
where renderMessage' = renderMessage foundation ls
instance RenderMessage UniWorX String where
renderMessage f ls str = renderMessage f ls $ Text.pack str
-- TODO: raw number representation; instead, display e.g. 1000 as 1.000 or 1,000 or ... (language-dependent!)
instance RenderMessage UniWorX Int where
renderMessage f ls = renderMessage f ls . tshow
instance RenderMessage UniWorX Int64 where
renderMessage f ls = renderMessage f ls . tshow
instance RenderMessage UniWorX Integer where
renderMessage f ls = renderMessage f ls . tshow
instance RenderMessage UniWorX Natural where
renderMessage f ls = renderMessage f ls . tshow
instance HasResolution a => RenderMessage UniWorX (Fixed a) where
renderMessage f ls = renderMessage f ls . showFixed True
instance RenderMessage UniWorX Load where
renderMessage foundation ls = renderMessage foundation ls . \case
Load { byTutorial = Nothing , byProportion = p } -> MsgCorByProportionOnly p
Load { byTutorial = Just True , byProportion = p } -> MsgCorByProportionIncludingTutorial p
Load { byTutorial = Just False, byProportion = p } -> MsgCorByProportionExcludingTutorial p
newtype MsgLanguage = MsgLanguage Lang
deriving stock (Eq, Ord, Show, Read)
instance RenderMessage UniWorX MsgLanguage where
renderMessage foundation ls (MsgLanguage lang@(map mk . Text.splitOn "-" -> lang'))
| ("de" : "DE" : _) <- lang' = mr MsgGermanGermany
| ("de" : _) <- lang' = mr MsgGerman
| ("en" : "EU" : _) <- lang' = mr MsgEnglishEurope
| ("en" : _) <- lang' = mr MsgEnglish
| otherwise = lang
where
mr = renderMessage foundation ls
embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>)
embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel
embedRenderMessage ''UniWorX ''StudyFieldType id
embedRenderMessage ''UniWorX ''SheetFileType id
embedRenderMessage ''UniWorX ''SubmissionFileType id
embedRenderMessage ''UniWorX ''CorrectorState id
embedRenderMessage ''UniWorX ''RatingException id
embedRenderMessage ''UniWorX ''SubmissionSinkException ("SubmissionSinkException" <>)
embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel
embedRenderMessage ''UniWorX ''EncodedSecretBoxException id
embedRenderMessage ''UniWorX ''LecturerType id
embedRenderMessage ''UniWorX ''SubmissionModeDescr
$ let verbMap [_, _, "None"] = "NoSubmissions"
verbMap [_, _, v] = v <> "Submissions"
verbMap _ = error "Invalid number of verbs"
in verbMap . splitCamel
embedRenderMessage ''UniWorX ''UploadModeDescr id
embedRenderMessage ''UniWorX ''SecretJSONFieldException id
embedRenderMessage ''UniWorX ''AFormMessage $ concat . drop 2 . splitCamel
embedRenderMessage ''UniWorX ''SchoolFunction id
embedRenderMessage ''UniWorX ''CsvPreset id
embedRenderMessage ''UniWorX ''Quoting ("Csv" <>)
embedRenderMessage ''UniWorX ''FavouriteReason id
embedRenderMessage ''UniWorX ''Sex id
embedRenderMessage ''UniWorX ''AuthenticationMode id
newtype ShortSex = ShortSex Sex
embedRenderMessageVariant ''UniWorX ''ShortSex ("Short" <>)
newtype SheetTypeHeader = SheetTypeHeader SheetType
embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
instance RenderMessage UniWorX SheetType where
renderMessage foundation ls sheetType = case sheetType of
NotGraded -> mr $ SheetTypeHeader NotGraded
other -> mr (grading other) <> ", " <> mr (SheetTypeHeader other)
where
mr :: RenderMessage UniWorX msg => msg -> Text
mr = renderMessage foundation ls
instance RenderMessage UniWorX StudyDegree where
renderMessage _found _ls StudyDegree{..} = fromMaybe (tshow studyDegreeKey) (studyDegreeName <|> studyDegreeShorthand)
newtype ShortStudyDegree = ShortStudyDegree StudyDegree
instance RenderMessage UniWorX ShortStudyDegree where
renderMessage _found _ls (ShortStudyDegree StudyDegree{..}) = fromMaybe (tshow studyDegreeKey) studyDegreeShorthand
instance RenderMessage UniWorX StudyTerms where
renderMessage _found _ls StudyTerms{..} = fromMaybe (tshow studyTermsKey) (studyTermsName <|> studyTermsShorthand)
newtype ShortStudyTerms = ShortStudyTerms StudyTerms
instance RenderMessage UniWorX ShortStudyTerms where
renderMessage _found _ls (ShortStudyTerms StudyTerms{..}) = fromMaybe (tshow studyTermsKey) studyTermsShorthand
data StudyDegreeTerm = StudyDegreeTerm StudyDegree StudyTerms
instance RenderMessage UniWorX StudyDegreeTerm where
renderMessage foundation ls (StudyDegreeTerm deg trm) = mr trm <> " (" <> mr (ShortStudyDegree deg) <> ")"
where
mr :: RenderMessage UniWorX msg => msg -> Text
mr = renderMessage foundation ls
newtype ShortStudyFieldType = ShortStudyFieldType StudyFieldType
embedRenderMessageVariant ''UniWorX ''ShortStudyFieldType ("Short" <>)
data StudyDegreeTermType = StudyDegreeTermType StudyDegree StudyTerms StudyFieldType
instance RenderMessage UniWorX StudyDegreeTermType where
renderMessage foundation ls (StudyDegreeTermType deg trm typ) = mr trm <> " (" <> mr (ShortStudyDegree deg) <> ", " <> mr (ShortStudyFieldType typ) <> ")"
where
mr :: RenderMessage UniWorX msg => msg -> Text
mr = renderMessage foundation ls
instance RenderMessage UniWorX ExamGrade where
renderMessage _ _ = pack . (showFixed False :: Deci -> String) . fromRational . review numberGrade
instance RenderMessage UniWorX ExamPassed where
renderMessage foundation ls = \case
ExamPassed True -> mr MsgExamPassed
ExamPassed False -> mr MsgExamNotPassed
where
mr :: RenderMessage UniWorX msg => msg -> Text
mr = renderMessage foundation ls
instance RenderMessage UniWorX a => RenderMessage UniWorX (ExamResult' a) where
renderMessage foundation ls = \case
ExamAttended{..} -> mr examResult
ExamNoShow -> mr MsgExamResultNoShow
ExamVoided -> mr MsgExamResultVoided
where
mr :: RenderMessage UniWorX msg => msg -> Text
mr = renderMessage foundation ls
instance RenderMessage UniWorX (Either ExamPassed ExamGrade) where
renderMessage foundation ls = either mr mr
where
mr :: RenderMessage UniWorX msg => msg -> Text
mr = renderMessage foundation ls
-- ToMessage instances for converting raw numbers to Text (no internationalization)
instance ToMessage Int where
toMessage = tshow
instance ToMessage Int64 where
toMessage = tshow
instance ToMessage Integer where
toMessage = tshow
instance ToMessage Natural where
toMessage = tshow
instance HasResolution a => ToMessage (Fixed a) where
toMessage = toMessage . showFixed True
-- Do not use toMessage on Rationals and round them automatically. Instead, use rationalToFixed3 (declared in src/Utils.hs) to convert a Rational to Fixed E3!
-- instance ToMessage Rational where
-- toMessage = toMessage . fromRational'
-- where fromRational' = fromRational :: Rational -> Fixed E3
newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse
embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>)
newtype UniWorXMessages = UniWorXMessages [SomeMessage UniWorX]
deriving stock (Generic, Typeable)
deriving newtype (Semigroup, Monoid)
instance IsList UniWorXMessages where
type Item UniWorXMessages = SomeMessage UniWorX
fromList = UniWorXMessages
toList (UniWorXMessages msgs) = msgs
instance RenderMessage UniWorX UniWorXMessages where
renderMessage foundation ls (UniWorXMessages msgs) =
Text.unwords $ map (renderMessage foundation ls) msgs
uniworxMessages :: [UniWorXMessage] -> UniWorXMessages
uniworxMessages = UniWorXMessages . map SomeMessage

10
src/Foundation/Routes.hs Normal file
View File

@ -0,0 +1,10 @@
module Foundation.Routes
( uniworxRoutes
) where
import ClassyPrelude.Yesod
import Yesod.Routes.TH.Types (ResourceTree)
uniworxRoutes :: [ResourceTree String]
uniworxRoutes = $(parseRoutesFile "routes")

58
src/Foundation/Type.hs Normal file
View File

@ -0,0 +1,58 @@
module Foundation.Type
( UniWorX(..)
, SMTPPool
, _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionKey, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport
) where
import Import.NoFoundation
import Database.Persist.Sql (ConnectionPool)
import qualified Web.ClientSession as ClientSession
import Jobs.Types
import Yesod.Core.Types (Logger)
import Data.Set (Set)
import qualified Crypto.Saltine.Core.SecretBox as SecretBox
import qualified Jose.Jwk as Jose
import qualified Database.Memcached.Binary.IO as Memcached
type SMTPPool = Pool SMTPConnection
-- | The foundation datatype for your application. This can be a good place to
-- keep settings and values requiring initialization before your application
-- starts running, such as database connections. Every handler will have
-- access to the data present here.
data UniWorX = UniWorX
{ appSettings' :: AppSettings
, appStatic :: EmbeddedStatic -- ^ Settings for static file serving.
, appConnPool :: ConnectionPool -- ^ Database connection pool.
, appSmtpPool :: Maybe SMTPPool
, appLdapPool :: Maybe LdapPool
, appWidgetMemcached :: Maybe Memcached.Connection -- ^ Actually a proper pool
, appHttpManager :: Manager
, appLogger :: (ReleaseKey, TVar Logger)
, appLogSettings :: TVar LogSettings
, appCryptoIDKey :: CryptoIDKey
, appClusterID :: ClusterId
, appInstanceID :: InstanceId
, appJobState :: TMVar JobState
, appSessionKey :: ClientSession.Key
, appSecretBoxKey :: SecretBox.Key
, appJSONWebKeySet :: Jose.JwkSet
, appHealthReport :: TVar (Set (UTCTime, HealthReport))
}
makeLenses_ ''UniWorX
instance HasInstanceID UniWorX InstanceId where
instanceID = _appInstanceID
instance HasJSONWebKeySet UniWorX Jose.JwkSet where
jsonWebKeySet = _appJSONWebKeySet
instance HasHttpManager UniWorX Manager where
httpManager = _appHttpManager
instance HasAppSettings UniWorX where
appSettings = _appSettings'

8
src/Handler/Admin.hs
View File

@ -4,6 +4,8 @@ module Handler.Admin
import Import
import Handler.Utils
import Handler.Admin.Test as Handler.Admin
import Handler.Admin.ErrorMessage as Handler.Admin
import Handler.Admin.StudyFeatures as Handler.Admin
@ -13,8 +15,4 @@ getAdminR :: Handler Html
getAdminR =
siteLayoutMsg MsgAdminHeading $ do
setTitleI MsgAdminHeading
[whamlet|
This shall become the Administrators' overview page.
Its current purpose is to provide links to some important admin functions
|]
i18n MsgAdminPageEmpty

6
src/Handler/Admin/Test.hs
View File

@ -38,7 +38,7 @@ emailTestForm :: AForm (HandlerFor UniWorX) (Email, MailContext)
emailTestForm = (,)
<$> areq emailField (fslI MsgMailTestFormEmail) Nothing
<*> ( MailContext
<$> (MailLanguages <$> areq (reorderField appLanguagesOpts) (fslI MsgMailTestFormLanguages) Nothing)
<$> (Languages <$> areq (reorderField appLanguagesOpts) (fslI MsgMailTestFormLanguages) Nothing)
<*> (toMailDateTimeFormat
<$> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) Nothing
<*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) Nothing
@ -54,7 +54,7 @@ emailTestForm = (,)
makeDemoForm :: Int -> Form (Int,Bool,Double)
makeDemoForm n = identifyForm ("adminTestForm" :: Text) $ \html -> do
(result, widget) <- flip (renderAForm FormStandard) html $ (,,)
<$> areq (minIntField n "Zahl") (fromString $ "Ganzzahl > " ++ show n) Nothing
<$> areq (minIntFieldI n ("Zahl" :: Text)) (fromString $ "Ganzzahl > " ++ show n) Nothing
<* aformSection MsgFormBehaviour
<*> areq checkBoxField "Muss nächste Zahl größer sein?" (Just True)
<*> areq doubleField "Fliesskommazahl" Nothing
@ -194,7 +194,7 @@ postAdminTestR = do
siteLayout locallyDefinedPageHeading $ do
-- defaultLayout $ do
setTitle "Uni2work Admin Testpage"
$(widgetFile "adminTest")
$(i18nWidgetFile "admin-test")
[whamlet|<h2>Formular Demonstration|]
wrapForm formWidget FormSettings

16
src/Handler/Allocation/Application.hs
View File

@ -52,7 +52,7 @@ data ApplicationForm = ApplicationForm
{ afPriority :: Maybe Natural
, afField :: Maybe StudyFeaturesId
, afText :: Maybe Text
, afFiles :: Maybe (ConduitT () File Handler ())
, afFiles :: Maybe FileUploads
, afRatingVeto :: Bool
, afRatingPoints :: Maybe ExamGrade
, afRatingComment :: Maybe Text
@ -291,8 +291,9 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
, courseApplicationRatingTime = guardOn rated now
}
let
sinkFile' file = do
fId <- insert file
sinkFile' (Right file) =
insert file >>= sinkFile' . Left
sinkFile' (Left fId) =
insert_ $ CourseApplicationFile appId fId
forM_ afFiles $ \afFiles' ->
runConduit $ transPipe liftHandler afFiles' .| C.mapM_ sinkFile'
@ -308,7 +309,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
| afmApplicantEdit afMode -> do
oldFiles <- Set.fromList . map (courseApplicationFileFile . entityVal) <$> selectList [CourseApplicationFileApplication ==. appId] []
changes <- flip execStateT oldFiles . forM_ afFiles $ \afFiles' ->
let sinkFile' file = do
let sinkFile' (Right file) = do
oldFiles' <- lift . E.select . E.from $ \(courseApplicationFile `E.InnerJoin` file') -> do
E.on $ courseApplicationFile E.^. CourseApplicationFileFile E.==. file' E.^. FileId
E.where_ $ file' E.^. FileTitle E.==. E.val (fileTitle file)
@ -326,7 +327,12 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
fId <- lift $ insert file
lift . insert_ $ CourseApplicationFile appId fId
modify $ Set.insert fId
in runConduit $ transPipe liftHandler afFiles' .| C.mapM_ sinkFile'
sinkFile' (Left fId)
| fId `Set.member` oldFiles = modify $ Set.delete fId
| otherwise = do
lift . insert_ $ CourseApplicationFile appId fId
modify $ Set.insert fId
in runConduit $ transPipe liftHandler afFiles' .| C.mapM_ sinkFile'
deleteCascadeWhere [ FileId <-. Set.toList (oldFiles `Set.intersection` changes) ]
return changes
| otherwise

5
src/Handler/Common.hs
View File

@ -1,5 +1,8 @@
-- | Common handler functions.
module Handler.Common where
module Handler.Common
( getFaviconR
, getRobotsR
) where
import Data.FileEmbed (embedFile)
import Import hiding (embedFile)

82
src/Handler/Corrections.hs
View File

@ -57,6 +57,8 @@ import qualified Control.Monad.State.Class as State
import Data.Foldable (foldrM)
import qualified Data.Conduit.List as C
type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
@ -215,6 +217,9 @@ colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ for
_other -> over (_1.mapped) (_2 .~) . over _2 fvInput <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints)
)
colMaxPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData)))
colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgSheetType) $ i18nCell . (\DBRow{ dbrOutput=(_, Entity _ Sheet{sheetType}, _, _, _, _) } -> sheetType)
colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData)))
colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ fmap (cellAttrs <>~ [("style","width:60%")]) $ formCell id
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId)
@ -274,6 +279,13 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
, ( "rating"
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints
)
, ( "sheet-type"
, SortColumns $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) ->
[ SomeExprValue ((sheet E.^. SheetType) E.->. "type" :: E.SqlExpr (E.Value Value))
, SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "max" :: E.SqlExpr (E.Value Value))
, SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "passing" :: E.SqlExpr (E.Value Value))
]
)
, ( "israted"
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> E.not_ . E.isNothing $ submission E.^. SubmissionRatingTime
)
@ -367,11 +379,22 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
E.where_ $ (\f -> f user $ Set.singleton needle) $
E.mkContainsFilter (E.^. UserMatrikelnummer)
)
-- , ( "pseudonym"
-- , FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(pseudonym) -> do
-- E.where_ $ querySheet table E.^. SheetId E.==. pseudonym E.^. SheetPseudonymSheet
-- E.where_ $ E.mkContainsFilter -- DB only stores Pseudonym == Word24. Conversion not possible in DB.
-- )
, ( "rating-visible"
, FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) criterion -> case getLast (criterion :: Last Bool) of
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
Just True -> E.isJust $ submission E.^. SubmissionRatingTime
Just False-> E.isNothing $ submission E.^. SubmissionRatingTime
)
, ( "rating"
, FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) pts -> if
| Set.null pts -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> E.maybe (E.val False :: E.SqlExpr (E.Value Bool)) (\p -> p `E.in_` E.valList (Set.toList pts)) (submission E.^. SubmissionRatingPoints)
)
, ( "comment"
, FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) comm -> case getLast (comm :: Last Text) of
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
Just needle -> E.maybe (E.val False :: E.SqlExpr (E.Value Bool)) (E.isInfixOf $ E.val needle) (submission E.^. SubmissionRatingComment)
)
]
, dbtFilterUI = fromMaybe mempty dbtFilterUI
, dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (\_ -> defaultDBSFilterLayout) dbtFilterUI }
@ -605,7 +628,7 @@ postCorrectionsR = do
, prismAForm (singletonFilter "term" ) mPrev $ aopt (lift `hoistField` selectField termOptions) (fslI MsgTerm)
, prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgCourseSchool)
, Map.singleton "sheet-search" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev)))
, prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgRatingTime)
, prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingTime)
]
courseOptions = runDB $ do
courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
@ -650,8 +673,8 @@ postCCorrectionsR tid ssh csh = do
-- "pseudonym" TODO DB only stores Word24
, Map.singleton "sheet-search" . maybeToList <$> aopt textField (fslI MsgSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev)))
, prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgCorrector)
, prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgHasCorrector)
, prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgRatingTime)
, prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgHasCorrector)
, prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingTime)
]
psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway
correctionsR whereClause colonnade filterUI psValidator $ Map.fromList
@ -681,8 +704,8 @@ postSSubsR tid ssh csh shn = do
[ prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgCourseMembers)
, prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgMatrikelNr)
, prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgCorrector)
, prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgHasCorrector)
, prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgRatingTime)
, prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgHasCorrector)
, prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingTime)
-- "pseudonym" TODO DB only stores Word24
]
psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway
@ -714,13 +737,14 @@ postCorrectionR tid ssh csh shn cid = do
results <- runDB $ correctionData tid ssh csh shn sub
MsgRenderer mr <- getMsgRenderer
case results of
[(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ subm@Submission{..}, corrector)] -> do
let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
pointsForm = case sheetType of
NotGraded -> pure Nothing
_otherwise -> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType)
(fslpI MsgRatingPoints "Punktezahl" & setTooltip sheetType)
(fslpI MsgRatingPoints (mr MsgPointsPlaceholder) & setTooltip sheetType)
(Just submissionRatingPoints)
((corrResult, corrForm'), corrEncoding) <- runFormPost . identifyForm FIDcorrection . renderAForm FormStandard $ (,,)
@ -769,14 +793,13 @@ postCorrectionR tid ssh csh shn cid = do
formResult uploadResult $ \fileUploads -> do
uid <- requireAuthId
res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| C.mapM (either get404 return) .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
case res of
Nothing -> return () -- ErrorMessages are already added by msgSubmissionErrors
(Just _) -> do
addMessageI Success MsgRatingFilesUpdated
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
mr <- getMessageRender
let sheetTypeDesc = mr sheetType
heading = MsgCorrectionHead tid ssh csh shn cid
headingWgt = [whamlet|
@ -818,7 +841,7 @@ postCorrectionsUploadR = do
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
FormSuccess files -> do
uid <- requireAuthId
mbSubs <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkMultiSubmission uid True
mbSubs <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) files .| C.mapM (either get404 return) .| extractRatingsMsg .| sinkMultiSubmission uid True
case mbSubs of
Nothing -> return ()
(Just subs)
@ -868,9 +891,10 @@ postCorrectionsCreateR = do
, optionInternalValue = sid
, optionExternalValue = toPathPiece (cID :: CryptoUUIDSheet)
}
MsgRenderer mr <- getMsgRenderer
((pseudonymRes, pseudonymWidget), pseudonymEncoding) <- runFormPost . renderAForm FormStandard $ (,)
<$> areq (selectField sheetOptions) (fslI MsgPseudonymSheet) Nothing
<*> (textToList <$> areq textareaField (fslpI MsgCorrectionPseudonyms "Pseudonyme" & setTooltip MsgCorrectionPseudonymsTip) Nothing)
<*> (textToList <$> areq textareaField (fslpI MsgCorrectionPseudonyms (mr MsgPseudonyms) & setTooltip MsgCorrectionPseudonymsTip) Nothing)
case pseudonymRes of
FormMissing -> return ()
@ -980,7 +1004,8 @@ postCorrectionsCreateR = do
, formEncoding = pseudonymEncoding
}
defaultLayout
siteLayoutMsg MsgCorrCreate $ do
setTitleI MsgCorrCreate
$(widgetFile "corrections-create")
where
partitionEithers' :: [[Either a b]] -> ([[b]], [a])
@ -1010,8 +1035,28 @@ postCorrectionsGradeR = do
, colRated
, colRatedField
, colPointsField
, colMaxPointsField
, colCommentField
] -- Continue here
filterUI = Just $ \mPrev -> mconcat
[ prismAForm (singletonFilter "course" ) mPrev $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgCourse)
, prismAForm (singletonFilter "term" ) mPrev $ aopt (lift `hoistField` selectField termOptions) (fslI MsgTerm)
, prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgCourseSchool)
, Map.singleton "sheet-search" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev)))
, prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingTime)
, prismAForm (singletonFilter "rating-visible" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingDone)
, prismAForm (singletonFilter "rating" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` pointsField) (fslI MsgColumnRatingPoints)
, Map.singleton "comment" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgRatingComment) (Just <$> listToMaybe =<< (Map.lookup "comment" =<< mPrev))
]
courseOptions = runDB $ do
courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
optionsPairs $ map (id &&& id) $ nub $ map (CI.original . courseShorthand . entityVal) courses
termOptions = runDB $ do
courses <- selectList [] [Asc CourseTerm] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
optionsPairs $ map (id &&& id) $ nub $ map (termToText . unTermKey . courseTerm . entityVal) courses
schoolOptions = runDB $ do
courses <- selectList [] [Asc CourseSchool] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses
psValidator = def
& defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData))
unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
@ -1020,7 +1065,7 @@ postCorrectionsGradeR = do
void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True
return i
(fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns mempty psValidator dbtProj' $ def
(fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI psValidator dbtProj' $ def
{ dbParamsFormAction = Just $ SomeRoute CorrectionsGradeR
}
@ -1045,7 +1090,8 @@ postCorrectionsGradeR = do
content = Right $(widgetFile "messages/correctionsUploaded")
unless (null subs') $ addMessageModal Success trigger content
defaultLayout $
siteLayoutMsg MsgCorrectionsGrade $ do
setTitleI MsgCorrectionsGrade
$(widgetFile "corrections-grade")

5
src/Handler/Course/Edit.hs
View File

@ -256,7 +256,6 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
optionalActionW' (bool mforcedJust mpopt mayChange) allocationForm' (fslI MsgCourseAllocationParticipate & setTooltip MsgCourseAllocationParticipateTip) (is _Just . cfAllocation <$> template)
-- TODO: internationalization
-- let autoUnzipInfo = [|Entpackt hochgeladene Zip-Dateien (*.zip) automatisch und fügt den Inhalt dem Stamm-Verzeichnis der Abgabe hinzu. TODO|]
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
@ -267,9 +266,9 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
& setTooltip MsgCourseShorthandUnique) (cfShort <$> template)
<*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template)
<*> areq termsField (fslI MsgCourseSemester) (cfTerm <$> template)
<*> aopt htmlField (fslpI MsgCourseDescription "Bitte mindestens die Modulbeschreibung angeben"
<*> aopt htmlField (fslpI MsgCourseDescription (mr MsgCourseDescriptionPlaceholder)
& setTooltip MsgCourseDescriptionTip) (cfDesc <$> template)
<*> aopt (urlField & cfStrip) (fslpI MsgCourseHomepageExternal "Optionale externe URL")
<*> aopt (urlField & cfStrip) (fslpI MsgCourseHomepageExternal (mr MsgCourseHomepageExternalPlaceholder))
(cfLink <$> template)
<*> apopt checkBoxField (fslI MsgMaterialFree) (cfMatFree <$> template)
<* aformSection MsgCourseFormSectionRegistration

2
src/Handler/Course/LecturerInvite.hs
View File

@ -66,7 +66,7 @@ lecturerInvitationConfig = InvitationConfig{..}
invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- liftHandler requireAuthId
itAuthority <- Right <$> liftHandler requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized
invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandler $ toJunction <$> case mlType of

2
src/Handler/Course/List.hs
View File

@ -176,7 +176,7 @@ makeCourseTable whereClause colChoices psValidator = do
, Just $ prismAForm (singletonFilter "lecturer") mPrev $ aopt textField (fslI MsgCourseLecturer)
, Just $ prismAForm (singletonFilter "search") mPrev $ aopt textField (fslI MsgCourseFilterSearch)
, Just $ prismAForm (singletonFilter "openregistration" . maybePrism _PathPiece) mPrev $ fmap (\x -> if isJust x && not (fromJust x) then Nothing else x) . aopt checkBoxField (fslI MsgCourseRegisterOpen)
, muid $> prismAForm (singletonFilter "registered" . maybePrism _PathPiece) mPrev (aopt boolField (fslI MsgCourseFilterRegistered))
, muid $> prismAForm (singletonFilter "registered" . maybePrism _PathPiece) mPrev (aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgCourseFilterRegistered))
]
, dbtStyle = def
{ dbsFilterLayout = defaultDBSFilterLayout

2
src/Handler/Course/ParticipantInvite.hs
View File

@ -83,7 +83,7 @@ participantInvitationConfig = InvitationConfig{..}
invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- liftHandler requireAuthId
itAuthority <- Right <$> liftHandler requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized
invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do

4
src/Handler/Course/Register.hs
View File

@ -42,7 +42,7 @@ instance Button UniWorX ButtonCourseRegister where
data CourseRegisterForm = CourseRegisterForm
{ crfStudyFeatures :: Maybe StudyFeaturesId
, crfApplicationText :: Maybe Text
, crfApplicationFiles :: Maybe (ConduitT () File Handler ())
, crfApplicationFiles :: Maybe FileUploads
}
courseRegisterForm :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Course -> m (AForm Handler CourseRegisterForm, ButtonCourseRegister)
@ -195,7 +195,7 @@ postCRegisterR tid ssh csh = do
whenIsJust appRes $
audit . TransactionCourseApplicationEdit cid uid
whenIsJust ((,) <$> appRes <*> crfApplicationFiles) $ \(appId, fSource) -> do
runConduit $ transPipe liftHandler fSource .| C.mapM_ (\f -> insert f >>= insert_ . CourseApplicationFile appId)
runConduit $ transPipe liftHandler fSource .| C.mapM_ (insert_ . CourseApplicationFile appId <=< either return insert)
return appRes
| otherwise
= return $ Just ()

4
src/Handler/CryptoIDDispatch.hs
View File

@ -66,7 +66,7 @@ instance (CryptoRoute ciphertext plaintext, Dispatch ciphertext ps) => Dispatch
getCryptoUUIDDispatchR :: UUID -> Handler ()
getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectWith found302)
getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectAccessWith movedPermanently301)
where
p :: Proxy '[ SubmissionId
, UserId
@ -74,7 +74,7 @@ getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectWith
p = Proxy
getCryptoFileNameDispatchR :: CI FilePath -> Handler ()
getCryptoFileNameDispatchR path = dispatchID p path >>= maybe notFound (redirectWith found302)
getCryptoFileNameDispatchR path = dispatchID p path >>= maybe notFound (redirectAccessWith movedPermanently301)
where
p :: Proxy '[ SubmissionId ]
p = Proxy

2
src/Handler/Exam/CorrectorInvite.hs
View File

@ -67,7 +67,7 @@ examCorrectorInvitationConfig = InvitationConfig{..}
invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- liftHandler requireAuthId
itAuthority <- Right <$> liftHandler requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized
invitationForm _ _ _ = pure (JunctionExamCorrector, ())

2
src/Handler/Exam/RegistrationInvite.hs
View File

@ -77,7 +77,7 @@ examRegistrationInvitationConfig = InvitationConfig{..}
invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|]
invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do
itAuthority <- liftHandler requireAuthId
itAuthority <- Right <$> liftHandler requireAuthId
let itExpiresAt = Just $ Just invDBExamRegistrationDeadline
itAddAuth
| not invDBExamRegistrationCourseRegister

2
src/Handler/ExamOffice/Exam.hs
View File

@ -369,7 +369,7 @@ postEGradesR tid ssh csh examn = do
, fltrStudyDegreeUI
, fltrStudyFeaturesSemesterUI
, fltrExamResultPointsUI examShowGrades
, \mPrev -> prismAForm (singletonFilter "is-synced" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgExamUserSynchronised)
, \mPrev -> prismAForm (singletonFilter "is-synced" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamUserSynchronised)
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = DBParamsForm

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

@ -67,7 +67,7 @@ examOfficeUserInvitationConfig = InvitationConfig{..}
return . SomeMessage $ MsgExamOfficeUserInviteHeading userDisplayName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamOfficeUserInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- liftHandler requireAuthId
itAuthority <- Right <$> liftHandler requireAuthId
let itExpiresAt = Nothing
itStartsAt = Nothing
itAddAuth = Nothing

10
src/Handler/Home.hs
View File

@ -32,7 +32,7 @@ homeUpcomingSheets uid = do
, E.SqlExpr (E.Value SchoolId)
, E.SqlExpr (E.Value CourseShorthand)
, E.SqlExpr (E.Value SheetName)
, E.SqlExpr (E.Value UTCTime)
, E.SqlExpr (E.Value (Maybe UTCTime))
, E.SqlExpr (E.Value (Maybe SubmissionId)))
tableData ((participant `E.InnerJoin` course `E.InnerJoin` sheet) `E.LeftOuterJoin` (submission `E.InnerJoin` subuser)) = do
E.on $ submission E.?. SubmissionId E.==. subuser E.?. SubmissionUserSubmission
@ -41,7 +41,7 @@ homeUpcomingSheets uid = do
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
E.&&. sheet E.^. SheetActiveTo E.>=. E.val cTime
E.&&. E.maybe E.true (E.>=. E.val cTime) (sheet E.^. SheetActiveTo)
return
( course E.^. CourseTerm
, course E.^. CourseSchool
@ -55,7 +55,7 @@ homeUpcomingSheets uid = do
, E.Value SchoolId
, E.Value CourseShorthand
, E.Value SheetName
, E.Value UTCTime
, E.Value (Maybe UTCTime)
, E.Value (Maybe SubmissionId)
))
(DBCell Handler ())
@ -70,8 +70,8 @@ homeUpcomingSheets uid = do
anchorCell (CourseR tid ssh csh CShowR) csh
, sortable (Just "sheet") (i18nCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) } ->
anchorCell (CSheetR tid ssh csh shn SShowR) shn
, sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } ->
cell $ formatTime SelFormatDateTime deadline >>= toWidget
, sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value mDeadline, _) } ->
maybe mempty (cell . formatTimeW SelFormatDateTime) mDeadline
, sortable (Just "done") (i18nCell MsgDone) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) } ->
case mbsid of
Nothing -> cell $ do

19
src/Handler/Info.hs
View File

@ -2,6 +2,10 @@ module Handler.Info where
import Import
import Handler.Utils
import Handler.Info.TH
import qualified Data.Map as Map
import qualified Data.CaseInsensitive as CI
import Development.GitRev
@ -67,3 +71,18 @@ getInfoLecturerR =
if currentTime > expiryTime
then mempty
else toWidget [whamlet| ^{iconTooltip tooltipNew (Just IconNew) False} |]
getGlossaryR :: Handler Html
getGlossaryR =
siteLayoutMsg' MsgGlossaryTitle $ do
setTitleI MsgGlossaryTitle
MsgRenderer mr <- getMsgRenderer
let
entries' = sortOn (CI.mk . view _2) $ do
(k, v) <- Map.toList entries
msg <- maybeToList $ Map.lookup k msgMap
return (k, mr msg, v)
$(widgetFile "glossary")
where
entries = $(i18nWidgetFiles "glossary")
msgMap = $(glossaryTerms "glossary")

23
src/Handler/Info/TH.hs Normal file
View File

@ -0,0 +1,23 @@
module Handler.Info.TH
( glossaryTerms
) where
import Import
import Handler.Utils.I18n
import Language.Haskell.TH
import qualified Data.Char as Char
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
glossaryTerms :: FilePath -> Q Exp
glossaryTerms basename = do
translationsAvailable <- i18nWidgetFilesAvailable' basename
let terms = Map.mapWithKey (\k _ -> "Msg" <> unPathPiece k) translationsAvailable
[e|Map.fromList $(listE . map (\(int, msg) -> tupE [litE . stringL $ repack int, conE $ mkName msg]) $ Map.toList terms)|]
where
unPathPiece :: Text -> String
unPathPiece = repack . mconcat . map (over _head Char.toUpper) . Text.splitOn "-"

45
src/Handler/Metrics.hs Normal file
View File

@ -0,0 +1,45 @@
module Handler.Metrics
( getMetricsR
) where
import Import hiding (Info)
import Prometheus
import qualified Network.Wai.Middleware.Prometheus as Prometheus
import qualified Data.Text as Text
import qualified Data.HashSet as HashSet
getMetricsR :: Handler TypedContent
getMetricsR = selectRep $ do
provideRep (sendWaiApplication Prometheus.metricsApp :: Handler Text)
provideRep metricsHtml
provideRep $ collectMetrics >>= returnJson
where
metricsHtml :: Handler Html
metricsHtml = do
samples <- collectMetrics
metricsToken <- runMaybeT . hoist runDB $ do
uid <- MaybeT maybeAuthId
guardM . lift . existsBy $ UniqueUserGroupMember UserGroupMetrics uid
encodeToken =<< bearerToken (Left $ toJSON UserGroupMetrics) (Just $ HashSet.singleton MetricsR) Nothing (Just Nothing) Nothing
defaultLayout $ do
setTitleI MsgTitleMetrics
$(widgetFile "metrics")
metricBasename base sName
| Just suffix <- Text.stripPrefix base sName
= if | Just suffix' <- Text.stripPrefix "_" suffix
-> suffix'
| otherwise
-> suffix
| otherwise
= sName
getLabels = nub . concatMap (\(Sample _ lPairs _) -> lPairs ^.. folded . _1)
singleSample base [Sample sName lPairs sValue]
| sName == base = Just (lPairs, sValue)
singleSample _ _ = Nothing

36
src/Handler/Profile.hs
View File

@ -5,6 +5,7 @@ module Handler.Profile
, getUserNotificationR, postUserNotificationR
, getSetDisplayEmailR, postSetDisplayEmailR
, getCsvOptionsR, postCsvOptionsR
, postLangR
) where
import Import
@ -22,6 +23,8 @@ import qualified Data.Set as Set
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
-- import Database.Esqueleto ((^.))
import qualified Data.Text as Text
import Data.List (inits)
import qualified Data.CaseInsensitive as CI
@ -76,15 +79,16 @@ instance RenderMessage UniWorX NotificationTriggerKind where
makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
makeSettingForm template html = do
MsgRenderer mr <- getMsgRenderer
(result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
<$ aformSection MsgFormPersonalAppearance
<*> areq (textField & cfStrip) (fslI MsgUserDisplayName & setTooltip MsgUserDisplayNameRulesBelow) (stgDisplayName <$> template)
<*> areq (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUserDisplayEmailTip) (stgDisplayEmail <$> template)
<* aformSection MsgFormCosmetics
<*> areq (natFieldI $ MsgNatField "Favoriten")
(fslpI MsgFavourites "Anzahl Favoriten" & setTooltip MsgFavouritesTip) (stgMaxFavourites <$> template)
<*> areq (natFieldI $ MsgNatField "Favoriten-Semester")
(fslpI MsgFavouriteSemesters "Anzahl Semester") (stgMaxFavouriteTerms <$> template)
<*> areq (natFieldI MsgFavouritesNotNatural)
(fslpI MsgFavourites (mr MsgFavouritesPlaceholder) & setTooltip MsgFavouritesTip) (stgMaxFavourites <$> template)
<*> areq (natFieldI MsgFavouritesSemestersNotNatural)
(fslpI MsgFavouriteSemesters (mr MsgFavouritesSemestersPlaceholder)) (stgMaxFavouriteTerms <$> template)
<*> areq (selectField . return $ mkOptionList themeList)
(fslI MsgTheme) { fsId = Just "theme-select" } (stgTheme <$> template)
<*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template)
@ -315,7 +319,7 @@ postProfileR = do
tResetTime <- traverse (formatTime SelFormatDateTime) userTokensIssuedAfter
siteLayout [whamlet|_{MsgProfileFor} ^{nameWidget userDisplayName userSurname}|] $ do
setTitle . toHtml $ "Profil " <> userIdent
setTitleI MsgProfileTitle
let settingsForm =
wrapForm formWidget FormSettings
{ formMethod = POST
@ -366,10 +370,11 @@ makeProfileData (Entity uid User{..}) = do
submissionTable <- mkSubmissionTable uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen
submissionGroupTable <- mkSubmissionGroupTable uid -- Tabelle mit allen Abgabegruppen
correctionsTable <- mkCorrectionsTable uid -- Tabelle mit allen Korrektor-Aufgaben
let examTable = [whamlet|Prüfungen werden hier momentan leider noch nicht unterstützt.|]
let ownTutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
let tutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
let examTable = [whamlet|_{MsgPersonalInfoExamAchievementsWip}|]
let ownTutorialTable = [whamlet|_{MsgPersonalInfoOwnTutorialsWip}|]
let tutorialTable = [whamlet|_{MsgPersonalInfoTutorialsWip}|]
lastLogin <- traverse (formatTime SelFormatDateTime) userLastAuthentication
let profileRemarks = $(i18nWidgetFile "profile-remarks")
return $(widgetFile "profileData")
@ -837,3 +842,18 @@ postCsvOptionsR = do
, formEncoding = optionsEnctype
, formAttrs = [ asyncSubmitAttr | isModal ]
}
postLangR :: Handler ()
postLangR = do
((langRes, _), _) <- runFormPost $ identifyForm FIDLanguage langForm
formResult langRes $ \(lang, route) -> do
lang' <- runDB . updateUserLanguage $ Just lang
app <- getYesod
let mr | Just lang'' <- lang' = renderMessage app . map (Text.intercalate "-") . reverse . inits $ Text.splitOn "-" lang''
| otherwise = renderMessage app []
addMessage Success . toHtml $ mr MsgLanguageChanged
redirect route
invalidArgs ["Language form required"]

331
src/Handler/Sheet.hs
View File

@ -55,6 +55,8 @@ import Text.Hamlet (ihamlet)
import System.FilePath (addExtension)
import Data.Time.Clock.System (systemEpochDay)
{-
* Implement Handlers
@ -62,22 +64,38 @@ import System.FilePath (addExtension)
* Implement Access in Foundation
-}
type Loads = Map (Either UserEmail UserId) (InvitationData SheetCorrector)
data SheetForm = SheetForm
{ sfName :: SheetName
, sfDescription :: Maybe Html
, sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe (ConduitT () (Either FileId File) Handler ())
, sfVisibleFrom :: Maybe UTCTime
, sfActiveFrom :: UTCTime
, sfActiveTo :: UTCTime
, sfActiveFrom :: Maybe UTCTime
, sfActiveTo :: Maybe UTCTime
, sfHintFrom :: Maybe UTCTime
, sfSolutionFrom :: Maybe UTCTime
, sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe (ConduitT () (Either FileId File) Handler ())
, sfType :: SheetType
, sfGrouping :: SheetGroup
, sfSubmissionMode :: SubmissionMode
, sfDescription :: Maybe Html
, sfAutoDistribute :: Bool
, sfMarkingText :: Maybe Html
, sfCorrectors :: Loads
-- Keine SheetId im Formular!
}
data ButtonGeneratePseudonym = BtnGenerate
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonGeneratePseudonym
instance Finite ButtonGeneratePseudonym
nullaryPathPiece ''ButtonGeneratePseudonym (camelToPathPiece' 1)
instance Button UniWorX ButtonGeneratePseudonym where
btnLabel BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|]
btnClasses BtnGenerate = [BCIsButton, BCDefault]
getFtIdMap :: Key Sheet -> DB (SheetFileType -> Set FileId)
getFtIdMap sId = do
allfIds <- E.select . E.from $ \(sheetFile `E.InnerJoin` file) -> do
@ -91,40 +109,41 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
oldFileIds <- (return.) <$> case msId of
Nothing -> return $ partitionFileType mempty
(Just sId) -> liftHandler $ runDB $ getFtIdMap sId
mr <- getMsgRenderer
mr'@(MsgRenderer mr) <- getMsgRenderer
ctime <- ceilingQuarterHour <$> liftIO getCurrentTime
(result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
<$> areq (textField & cfStrip & cfCI) (fslI MsgSheetName) (sfName <$> template)
<* aformSection MsgSheetFormTimes
<*> aopt utcTimeField (fslI MsgSheetVisibleFrom
& setTooltip MsgSheetVisibleFromTip)
((sfVisibleFrom <$> template) <|> pure (Just ctime))
<*> areq utcTimeField (fslI MsgSheetActiveFrom
& setTooltip MsgSheetActiveFromTip)
(sfActiveFrom <$> template)
<*> areq utcTimeField (fslI MsgSheetActiveTo) (sfActiveTo <$> template)
<*> aopt utcTimeField (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren"
& setTooltip MsgSheetHintFromTip) (sfHintFrom <$> template)
<*> aopt utcTimeField (fslpI MsgSheetSolutionFrom "Datum, sonst nur für Korrektoren"
& setTooltip MsgSheetSolutionFromTip) (sfSolutionFrom <$> template)
<*> aopt htmlField (fslpI MsgSheetDescription "Html") (sfDescription <$> template)
<* aformSection MsgSheetFormFiles
<*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
<*> aopt (multiFileField $ oldFileIds SheetHint) (fslI MsgSheetHint) (sfHintF <$> template)
<*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
<*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarkingFiles
& setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template)
<* aformSection MsgSheetFormTimes
<*> aopt utcTimeField (fslI MsgSheetVisibleFrom
& setTooltip MsgSheetVisibleFromTip)
((sfVisibleFrom <$> template) <|> pure (Just ctime))
<*> aopt utcTimeField (fslI MsgSheetActiveFrom
& setTooltip MsgSheetActiveFromTip)
(sfActiveFrom <$> template)
<*> aopt utcTimeField (fslI MsgSheetActiveTo & setTooltip MsgSheetActiveToTip) (sfActiveTo <$> template)
<*> aopt utcTimeField (fslpI MsgSheetHintFrom (mr MsgSheetHintFromPlaceholder)
& setTooltip MsgSheetHintFromTip) (sfHintFrom <$> template)
<*> aopt utcTimeField (fslpI MsgSheetSolutionFrom (mr MsgSheetSolutionFromPlaceholder)
& setTooltip MsgSheetSolutionFromTip) (sfSolutionFrom <$> template)
<* aformSection MsgSheetFormType
<*> sheetTypeAFormReq (fslI MsgSheetType
& setTooltip (uniworxMessages [MsgSheetTypeInfoBonus, MsgSheetTypeInfoInformational, MsgSheetTypeInfoNotGraded]))
(sfType <$> template)
<*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template)
<*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction))
<*> aopt htmlField (fslpI MsgSheetDescription "Html")
(sfDescription <$> template)
<*> apopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template)
<*> aopt htmlField (fslpI MsgSheetMarking "Html") (sfMarkingText <$> template)
<*> correctorForm (fromMaybe mempty $ sfCorrectors <$> template)
return $ case result of
FormSuccess sheetResult
| errorMsgs <- validateSheet mr sheetResult
| errorMsgs <- validateSheet mr' sheetResult
, not $ null errorMsgs ->
(FormFailure errorMsgs, widget)
_ -> (result, widget)
@ -132,10 +151,10 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
validateSheet :: MsgRenderer -> SheetForm -> [Text]
validateSheet (MsgRenderer {..}) (SheetForm{..}) =
[ msg | (False, msg) <-
[ ( sfVisibleFrom <= Just sfActiveFrom , render MsgSheetErrVisibility)
, ( sfActiveFrom <= sfActiveTo , render MsgSheetErrDeadlineEarly)
, ( NTop sfHintFrom >= NTop (Just sfActiveFrom) , render MsgSheetErrHintEarly)
, ( NTop sfSolutionFrom >= NTop (Just sfActiveTo) , render MsgSheetErrSolutionEarly)
[ ( NTop sfVisibleFrom <= NTop sfActiveFrom , render MsgSheetErrVisibility)
, ( NTop sfActiveFrom <= NTop sfActiveTo , render MsgSheetErrDeadlineEarly)
, ( NTop sfHintFrom >= NTop sfActiveFrom , render MsgSheetErrHintEarly)
, ( NTop sfSolutionFrom >= NTop sfActiveTo , render MsgSheetErrSolutionEarly)
] ]
@ -216,9 +235,9 @@ getSheetListR tid ssh csh = do
else spacerCell
] id & cellAttrs <>~ [("class","list--inline list--space-separated")]
, sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> dateTimeCell sheetActiveFrom
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> maybe mempty dateTimeCell sheetActiveFrom
, sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> dateTimeCell sheetActiveTo
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> maybe mempty dateTimeCell sheetActiveTo
, sortable Nothing (i18nCell MsgSheetType)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> i18nCell sheetType
, sortable Nothing (i18nCell MsgSubmission)
@ -231,26 +250,34 @@ getSheetListR tid ssh csh = do
return $ CSubmissionR tid ssh csh sheetName cid' SubShowR
in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{cid2}|])
, sortable (Just "rating") (i18nCell MsgRating)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub,_)} ->
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub,_)} ->
let stats = sheetTypeSum sheetType in -- for statistics over all shown rows
case mbSub of
Nothing -> cellTell mempty $ stats Nothing
(Just (Entity sid sub@Submission{..})) ->
let mkCid = encrypt sid
mkRoute = do
cid' <- mkCid
let
mkRoute :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (Route UniWorX)
mkRoute = liftHandler $ do
cid' <- encrypt sid
return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR
mTuple mA mB = (,) <$> mA <*> mB -- Hamlet does not support enough haskell-syntax for this
acell = anchorCellM mkRoute $(widgetFile "widgets/rating/rating")
in cellTell acell $ stats submissionRatingPoints
tellStats = do
r <- mkRoute
showRating <- hasReadAccessTo r
tell . stats $ bool Nothing submissionRatingPoints showRating
in acell & cellContents %~ (<* tellStats)
, sortable Nothing -- (Just "percent")
(i18nCell MsgRatingPercent)
$ \DBRow{dbrOutput=(Entity _ Sheet{sheetType=sType}, _, mbSub,_)} -> case mbSub of
(Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) ->
$ \DBRow{dbrOutput=(Entity _ Sheet{sheetType=sType, sheetName}, _, mbSub,_)} -> case mbSub of
(Just (Entity sid Submission{submissionRatingPoints=Just sPoints})) ->
case preview (_grading . _maxPoints) sType of
Just maxPoints
| maxPoints /= 0 -> textCell $ textPercent sPoints maxPoints
| maxPoints /= 0 -> cell $ do
cID <- encrypt sid
showRating <- hasReadAccessTo $ CSubmissionR tid ssh csh sheetName cID CorrectionR
bool (return ()) (toWidget . toMessage $ textPercent sPoints maxPoints) showRating
_other -> mempty
_other -> mempty
]
@ -319,17 +346,6 @@ getSheetListR tid ssh csh = do
defaultLayout $ do
$(widgetFile "sheetList")
data ButtonGeneratePseudonym = BtnGenerate
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonGeneratePseudonym
instance Finite ButtonGeneratePseudonym
nullaryPathPiece ''ButtonGeneratePseudonym (camelToPathPiece' 1)
instance Button UniWorX ButtonGeneratePseudonym where
btnLabel BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|]
btnClasses BtnGenerate = [BCIsButton, BCDefault]
-- Show single sheet
getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSShowR tid ssh csh shn = do
@ -422,8 +438,9 @@ getSShowR tid ssh csh shn = do
setTitleI $ prependCourseTitle tid ssh csh $ SomeMessage shn
let zipLink = CSheetR tid ssh csh shn SArchiveR
visibleFrom = visibleUTCTime SelFormatDateTime <$> sheetVisibleFrom sheet
sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet
sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet
hasSubmission = classifySubmissionMode (sheetSubmissionMode sheet) /= SubmissionModeNone
sheetFrom <- traverse (formatTime SelFormatDateTime) $ sheetActiveFrom sheet
sheetTo <- traverse (formatTime SelFormatDateTime) $ sheetActiveTo sheet
hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet
solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
markingText <- runMaybeT $ assertM_ (Authorized ==) (evalAccessCorrector tid ssh csh) >> hoistMaybe (sheetMarkingText sheet)
@ -480,7 +497,8 @@ getSheetNewR tid ssh csh = do
(FormSuccess (Just shn)) -> E.where_ $ sheet E.^. SheetName E.==. E.val shn
-- (FormFailure msgs) -> -- not in MonadHandler anymore -- forM_ msgs (addMessage Error . toHtml)
_other -> return ()
lastSheets <- runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
(lastSheets, loads) <- runDB $ do
lSheets <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
@ -493,27 +511,35 @@ getSheetNewR tid ssh csh = do
-- E.orderBy [E.desc lastSheetEdit, E.desc (sheet E.^. SheetActiveFrom)]
E.orderBy [E.desc (sheet E.^. SheetActiveFrom)]
E.limit 1
return sheet
let firstEdit = E.sub_select . E.from $ \sheetEdit -> do
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
return . E.min_ $ sheetEdit E.^. SheetEditTime
return (sheet, firstEdit)
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
loads <- defaultLoads cid
return (lSheets, loads)
now <- liftIO getCurrentTime
let template = case lastSheets of
((Entity {entityVal=Sheet{..}}):_) ->
let addTime = addWeeks $ max 1 $ weeksToAdd sheetActiveTo now
((Entity {entityVal=Sheet{..}}, E.Value fEdit):_) ->
let addTime = addWeeks $ max 1 $ weeksToAdd (fromMaybe (UTCTime systemEpochDay 0) $ sheetActiveTo <|> fEdit) now
in Just $ SheetForm
{ sfName = stepTextCounterCI sheetName
, sfDescription = sheetDescription
, sfType = sheetType
, sfGrouping = sheetGrouping
, sfVisibleFrom = addTime <$> sheetVisibleFrom
, sfActiveFrom = addTime sheetActiveFrom
, sfActiveTo = addTime sheetActiveTo
{ sfName = stepTextCounterCI sheetName
, sfDescription = sheetDescription
, sfType = sheetType
, sfGrouping = sheetGrouping
, sfVisibleFrom = addTime <$> sheetVisibleFrom
, sfActiveFrom = addTime <$> sheetActiveFrom
, sfActiveTo = addTime <$> sheetActiveTo
, sfSubmissionMode = sheetSubmissionMode
, sfSheetF = Nothing
, sfHintFrom = addTime <$> sheetHintFrom
, sfHintF = Nothing
, sfSolutionFrom = addTime <$> sheetSolutionFrom
, sfSolutionF = Nothing
, sfMarkingF = Nothing
, sfMarkingText = sheetMarkingText
, sfSheetF = Nothing
, sfHintFrom = addTime <$> sheetHintFrom
, sfHintF = Nothing
, sfSolutionFrom = addTime <$> sheetSolutionFrom
, sfSolutionF = Nothing
, sfMarkingF = Nothing
, sfMarkingText = sheetMarkingText
, sfAutoDistribute = sheetAutoDistribute
, sfCorrectors = loads
}
_other -> Nothing
let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing
@ -526,44 +552,49 @@ postSheetNewR = getSheetNewR
getSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSEditR tid ssh csh shn = do
(Entity sid Sheet{..}, sheetFileIds) <- runDB $ do
ent <- fetchSheet tid ssh csh shn
(Entity sid Sheet{..}, sheetFileIds, currentLoads) <- runDB $ do
ent@(Entity sid _) <- fetchSheet tid ssh csh shn
fti <- getFtIdMap $ entityKey ent
return (ent, fti)
cLoads <- Map.union
<$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (InvDBDataSheetCorrector sheetCorrectorLoad sheetCorrectorState, InvTokenDataSheetCorrector)) (selectList [ SheetCorrectorSheet ==. sid ] [])
<*> fmap (fmap (, InvTokenDataSheetCorrector) . Map.mapKeysMonotonic Left) (sourceInvitationsF sid)
return (ent, fti, cLoads)
let template = Just $ SheetForm
{ sfName = sheetName
, sfDescription = sheetDescription
, sfType = sheetType
, sfGrouping = sheetGrouping
, sfVisibleFrom = sheetVisibleFrom
, sfActiveFrom = sheetActiveFrom
, sfActiveTo = sheetActiveTo
{ sfName = sheetName
, sfDescription = sheetDescription
, sfType = sheetType
, sfGrouping = sheetGrouping
, sfVisibleFrom = sheetVisibleFrom
, sfActiveFrom = sheetActiveFrom
, sfActiveTo = sheetActiveTo
, sfSubmissionMode = sheetSubmissionMode
, sfSheetF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise
, sfHintFrom = sheetHintFrom
, sfHintF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetHint
, sfSolutionFrom = sheetSolutionFrom
, sfSolutionF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetSolution
, sfMarkingF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetMarking
, sfMarkingText = sheetMarkingText
, sfSheetF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise
, sfHintFrom = sheetHintFrom
, sfHintF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetHint
, sfSolutionFrom = sheetSolutionFrom
, sfSolutionF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetSolution
, sfMarkingF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetMarking
, sfMarkingText = sheetMarkingText
, sfAutoDistribute = sheetAutoDistribute
, sfCorrectors = currentLoads
}
let action = uniqueReplace sid -- More specific error message for edit old sheet could go here by using myReplaceUnique instead
handleSheetEdit tid ssh csh (Just sid) template action
postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
postSEditR = getSEditR
handleSheetEdit :: TermId -> SchoolId -> CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
handleSheetEdit :: TermId -> SchoolId -> CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodJobDB UniWorX (Maybe SheetId)) -> Handler Html
handleSheetEdit tid ssh csh msId template dbAction = do
let mbshn = sfName <$> template
aid <- requireAuthId
cid <- runDB $ getKeyBy404 $ TermSchoolCourseShort tid ssh csh
((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm msId template
case res of
(FormSuccess SheetForm{..}) -> do
saveOkay <- runDB $ do
saveOkay <- runDBJobs $ do
actTime <- liftIO getCurrentTime
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
oldAutoDistribute <- fmap sheetAutoDistribute . join <$> traverse get msId
let newSheet = Sheet
{ sheetCourse = cid
, sheetName = sfName
@ -577,7 +608,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
, sheetHintFrom = sfHintFrom
, sheetSolutionFrom = sfSolutionFrom
, sheetSubmissionMode = sfSubmissionMode
, sheetAutoDistribute = fromMaybe False oldAutoDistribute
, sheetAutoDistribute = sfAutoDistribute
}
mbsid <- dbAction newSheet
case mbsid of
@ -590,22 +621,36 @@ handleSheetEdit tid ssh csh msId template dbAction = do
insert_ $ SheetEdit aid actTime sid
addMessageI Success $ MsgSheetEditOk tid ssh csh sfName
-- Sanity checks generating warnings only, but not errors!
warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <-
hoist lift . warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <-
[ (sfVisibleFrom, MsgSheetVisibleFrom)
, (Just sfActiveFrom, MsgSheetActiveFrom)
, (Just sfActiveTo, MsgSheetActiveTo)
, (sfActiveFrom, MsgSheetActiveFrom)
, (sfActiveTo, MsgSheetActiveTo)
, (sfHintFrom, MsgSheetSolutionFromTip)
, (sfSolutionFrom, MsgSheetSolutionFrom)
] ]
let
sheetCorrectors :: Set (Either (Invitation' SheetCorrector) SheetCorrector)
sheetCorrectors = Set.fromList . map f $ Map.toList sfCorrectors
where
f (Left email, invData) = Left (email, sid, invData)
f (Right uid, (InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector)) = Right $ SheetCorrector uid sid load cState
(invites, adds) = partitionEithers $ Set.toList sheetCorrectors
deleteWhere [ SheetCorrectorSheet ==. sid ]
insertMany_ adds
deleteWhere [InvitationFor ==. invRef @SheetCorrector sid, InvitationEmail /<-. toListOf (folded . _1) invites]
sinkInvitationsF correctorInvitationConfig invites
return True
when saveOkay $ redirect $ case msId of
Just _ -> CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
Nothing -> CSheetR tid ssh csh sfName SCorrR
when saveOkay $
redirect $ CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
(FormFailure msgs) -> forM_ msgs $ (addMessage Error) . toHtml
_ -> runDB $ warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <-
[(sfVisibleFrom =<< template, MsgSheetVisibleFrom)
,(sfActiveFrom <$> template, MsgSheetActiveFrom)
,(sfActiveTo <$> template, MsgSheetActiveTo)
,(sfActiveFrom =<< template, MsgSheetActiveFrom)
,(sfActiveTo =<< template, MsgSheetActiveTo)
,(sfHintFrom =<< template, MsgSheetSolutionFromTip)
,(sfSolutionFrom =<< template, MsgSheetSolutionFrom)
] ]
@ -641,14 +686,14 @@ insertSheetFile sid ftype finfo = do
fid <- insert file
void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
insertSheetFile' :: SheetId -> SheetFileType -> ConduitT () (Either FileId File) Handler () -> YesodDB UniWorX ()
insertSheetFile' :: SheetId -> SheetFileType -> ConduitT () (Either FileId File) Handler () -> YesodJobDB UniWorX ()
insertSheetFile' sid ftype fs = do
oldFileIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid
E.&&. sheetFile E.^. SheetFileType E.==. E.val ftype
return (file E.^. FileId)
keep <- execWriterT . runConduit $ transPipe (lift . lift) fs .| C.mapM_ finsert
keep <- execWriterT . runConduit $ transPipe liftHandler fs .| C.mapM_ finsert
mapM_ deleteCascade $ (oldFileIds \\ keep :: Set FileId)
where
finsert (Left fileId) = tell $ singleton fileId
@ -657,22 +702,12 @@ insertSheetFile' sid ftype fs = do
void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
data CorrectorForm = CorrectorForm
{ cfUserId :: UserId
, cfUserName :: Text
, cfResult :: FormResult (CorrectorState, Load)
, cfViewByTut, cfViewProp, cfViewDel, cfViewState :: FieldView UniWorX
}
type Loads = Map (Either UserEmail UserId) (CorrectorState, Load)
defaultLoads :: SheetId -> DB Loads
defaultLoads :: CourseId -> DB Loads
-- ^ Generate `Loads` in such a way that minimal editing is required
--
-- For every user, that ever was a corrector for this course, return their last `Load`.
-- "Last `Load`" is taken to mean their `Load` on the `Sheet` with the most recent creation time (first edit).
defaultLoads shid = do
cId <- sheetCourse <$> getJust shid
defaultLoads cId = do
fmap toMap . E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> E.distinctOnOrderBy [E.asc (sheetCorrector E.^. SheetCorrectorUser)] $ do
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
@ -687,37 +722,20 @@ defaultLoads shid = do
return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad, sheetCorrector E.^. SheetCorrectorState)
where
toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads
toMap = foldMap $ \(E.Value uid, E.Value cLoad, E.Value cState) -> Map.singleton (Right uid) (cState, cLoad)
toMap = foldMap $ \(E.Value uid, E.Value cLoad, E.Value cState) -> Map.singleton (Right uid) (InvDBDataSheetCorrector cLoad cState, InvTokenDataSheetCorrector)
correctorForm :: SheetId -> AForm Handler (Set (Either (Invitation' SheetCorrector) SheetCorrector))
correctorForm shid = wFormToAForm $ do
correctorForm :: Loads -> AForm Handler Loads
correctorForm loads' = wFormToAForm $ do
currentRoute <- fromMaybe (error "correctorForm called from 404-handler") <$> liftHandler getCurrentRoute
userId <- liftHandler requireAuthId
MsgRenderer mr <- getMsgRenderer
let
currentLoads :: DB Loads
currentLoads = Map.union
<$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (sheetCorrectorState, sheetCorrectorLoad)) (selectList [ SheetCorrectorSheet ==. shid ] [])
<*> fmap (fmap ((,) <$> invDBSheetCorrectorState <*> invDBSheetCorrectorLoad) . Map.mapKeysMonotonic Left) (sourceInvitationsF shid)
(defaultLoads', currentLoads') <- liftHandler . runDB $ (,) <$> defaultLoads shid <*> currentLoads
isWrite <- liftHandler $ isWriteRequest currentRoute
let
applyDefaultLoads = Map.null currentLoads' && not isWrite
loads :: Map (Either UserEmail UserId) (CorrectorState, Load)
loads
| applyDefaultLoads = defaultLoads'
| otherwise = currentLoads'
loads = loads' <&> \(InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector) -> (cState, load)
countTutRes <- wreq checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads
-- when (not (Map.null loads) && applyDefaultLoads) $ -- Alert Message
-- addMessageI Warning MsgCorrectorsDefaulted
when (not (Map.null loads) && applyDefaultLoads) $ -- Alert Notification
wformMessage =<< messageIconI Warning IconNoCorrectors MsgCorrectorsDefaulted
countTutRes <- wpopt checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads
let
@ -804,51 +822,16 @@ correctorForm shid = wFormToAForm $ do
miIdent :: Text
miIdent = "correctors"
postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Set (Either (Invitation' SheetCorrector) SheetCorrector)
postProcess = Set.fromList . map postProcess' . Map.elems
where
sheetCorrectorSheet = shid
postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> Either (Invitation' SheetCorrector) SheetCorrector
postProcess' (Right sheetCorrectorUser, (sheetCorrectorState, sheetCorrectorLoad)) = Right SheetCorrector{..}
postProcess' (Left email, (cState, load)) = Left (email, shid, (InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector))
postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Loads
postProcess = Map.fromList . map postProcess' . Map.elems
where
postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> (Either UserEmail UserId, (InvitationDBData SheetCorrector, InvitationTokenData SheetCorrector))
postProcess' = over _2 $ \(cState, load) -> (InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector)
filledData :: Maybe (Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)))
filledData = Just . Map.fromList . zip [0..] $ Map.toList loads -- TODO orderBy Name?!
fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors & setTooltip MsgMassInputTip) True filledData
getSCorrR, postSCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
postSCorrR = getSCorrR
getSCorrR tid ssh csh shn = do
Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh csh shn
((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $
(,) <$> areq checkBoxField (fslI MsgAutoAssignCorrs) (Just sheetAutoDistribute)
<*> correctorForm shid
case res of
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
FormSuccess (autoDistribute, sheetCorrectors) -> runDBJobs $ do
update shid [ SheetAutoDistribute =. autoDistribute ]
let (invites, adds) = partitionEithers $ Set.toList sheetCorrectors
deleteWhere [ SheetCorrectorSheet ==. shid ]
insertMany_ adds
deleteWhere [InvitationFor ==. invRef @SheetCorrector shid, InvitationEmail /<-. toListOf (folded . _1) invites]
sinkInvitationsF correctorInvitationConfig invites
addMessageI Success MsgCorrectorsUpdated
FormMissing -> return ()
defaultLayout $ do
setTitleI $ MsgSheetCorrectorsTitle tid ssh csh shn
wrapForm formWidget def
{ formAction = Just . SomeRoute $ CSheetR tid ssh csh shn SCorrR
, formEncoding = formEnctype
}
fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors & setTooltip MsgMassInputTip) False filledData
instance IsInvitableJunction SheetCorrector where
@ -905,7 +888,7 @@ correctorInvitationConfig = InvitationConfig{..}
invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- liftHandler requireAuthId
itAuthority <- Right <$> liftHandler requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized
invitationForm _ (InvDBDataSheetCorrector cLoad cState, _) _ = pure $ (JunctionSheetCorrector cLoad cState, ())
@ -923,5 +906,5 @@ postSCorrInviteR = invitationR correctorInvitationConfig
getSIsCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
-- NOTE: The route SIsCorrR is only used to verfify corrector access rights to given sheet!
getSIsCorrR _ _ _ shn = do
defaultLayout $ [whamlet|You have corrector access to #{shn}.|]
defaultLayout . i18n $ MsgHaveCorrectorAccess shn

10
src/Handler/Submission.hs
View File

@ -107,7 +107,7 @@ submissionUserInvitationConfig = InvitationConfig{..}
invitationTokenConfig (Entity _ Submission{..}) _ = do
Sheet{..} <- getJust submissionSheet
Course{..} <- getJust sheetCourse
itAuthority <- liftHandler requireAuthId
itAuthority <- Right <$> liftHandler requireAuthId
itAddAuth <- either throwM (return . Just) $ routeAuthTags (CSheetR courseTerm courseSchool courseShorthand sheetName SubmissionNewR)
let itExpiresAt = Nothing
itStartsAt = Nothing
@ -125,7 +125,7 @@ submissionUserInvitationConfig = InvitationConfig{..}
return . SomeRoute $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SubShowR
makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe (ConduitT () File Handler ()), Set (Either UserEmail UserId))
makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe FileUploads, Set (Either UserEmail UserId))
makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,)
<$> fileUploadForm (not isLecturer && is _Nothing msmid) (fslI . bool MsgSubmissionFile MsgSubmissionArchive) uploadMode
<*> wFormToAForm submittorsForm
@ -265,6 +265,8 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
postProcess :: Map ListPosition (Either UserEmail UserId, ()) -> Set (Either UserEmail UserId)
postProcess = setOf $ folded . _1
when (maxSize > Just 1) $
wformMessage =<< messageI Info MsgCosubmittorTip
fmap postProcess <$> massInputW MassInput{..} submittorSettings' True (Just . Map.fromList . zip [0..] . map (, ()) $ Set.toList prefillUsers)
@ -428,7 +430,7 @@ submissionHelper tid ssh csh shn mcid = do
(Nothing, Just smid) -- no new files, existing submission partners updated
-> return smid
(Just files, _) -> -- new files
runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False
runConduit $ transPipe (lift . lift) files .| Conduit.mapM (either get404 return) .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False
(Nothing, Nothing) -- new submission, no file upload requested
-> do
sid <- insert Submission
@ -484,7 +486,7 @@ submissionHelper tid ssh csh shn mcid = do
| otherwise -> case change of
Left subEmail -> deleteInvitation @SubmissionUser smid subEmail
Right subUid -> do
deleteWhere [SubmissionUserUser ==. subUid]
deleteBy $ UniqueSubmissionUser subUid smid
audit $ TransactionSubmissionUserDelete smid subUid
addMessageI Success $ if | Nothing <- msmid -> MsgSubmissionCreated

26
src/Handler/SystemMessage.hs
View File

@ -23,6 +23,7 @@ postMessageR cID = do
Nothing -> (systemMessageSummary, systemMessageContent)
Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
MsgRenderer mr <- getMsgRenderer
let
mkForm = do
((modifyRes, modifyView), modifyEnctype) <- runFormPost . identifyForm FIDSystemMessageModify . renderAForm FormStandard
@ -31,9 +32,9 @@ postMessageR cID = do
<*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just systemMessageTo)
<*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just systemMessageAuthenticatedOnly)
<*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) (Just systemMessageSeverity)
<*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just systemMessageDefaultLanguage)
<*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageContent)
<*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageSummary)
<*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageDefaultLanguage)
<*> areq htmlField' (fslpI MsgSystemMessageContent "Html") (Just systemMessageContent)
<*> aopt htmlField' (fslpI MsgSystemMessageSummary "Html") (Just systemMessageSummary)
ts <- runDB $ selectList [ SystemMessageTranslationMessage ==. smId ] [Asc SystemMessageTranslationLanguage]
let ts' = Map.fromList $ (systemMessageTranslationLanguage . entityVal &&& id) <$> ts
@ -45,9 +46,9 @@ postMessageR cID = do
<$> fmap (Entity tId)
( SystemMessageTranslation
<$> pure systemMessageTranslationMessage
<*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just systemMessageTranslationLanguage)
<*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageTranslationContent)
<*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageTranslationSummary)
<*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageTranslationLanguage)
<*> areq htmlField' (fslpI MsgSystemMessageContent "Html") (Just systemMessageTranslationContent)
<*> aopt htmlField' (fslpI MsgSystemMessageSummary "Html") (Just systemMessageTranslationSummary)
)
<*> combinedButtonFieldF ""
@ -56,9 +57,9 @@ postMessageR cID = do
((addTransRes, addTransView), addTransEnctype) <- runFormPost . identifyForm FIDSystemMessageAddTranslation . renderAForm FormStandard
$ SystemMessageTranslation
<$> pure smId
<*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") Nothing
<*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") Nothing
<*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") Nothing
<*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) Nothing
<*> areq htmlField' (fslpI MsgSystemMessageContent "Html") Nothing
<*> aopt htmlField' (fslpI MsgSystemMessageSummary "Html") Nothing
formResult modifyRes $ modifySystemMessage smId
@ -252,14 +253,15 @@ postMessageListR = do
FormSuccess (_, _selection) -- prop> null _selection
-> addMessageI Error MsgSystemMessageEmptySelection
MsgRenderer mr <- getMsgRenderer
((addRes, addView), addEncoding) <- runFormPost . identifyForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage
<$> aopt utcTimeField (fslI MsgSystemMessageFrom) Nothing
<*> aopt utcTimeField (fslI MsgSystemMessageTo) Nothing
<*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) Nothing
<*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) Nothing
<*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just $ NonEmpty.head appLanguages)
<*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") Nothing
<*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") Nothing
<*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just $ NonEmpty.head appLanguages)
<*> areq htmlField' (fslpI MsgSystemMessageContent "Html") Nothing
<*> aopt htmlField' (fslpI MsgSystemMessageSummary "Html") Nothing
case addRes of
FormMissing -> return ()

76
src/Handler/Term.hs
View File

@ -7,6 +7,8 @@ import qualified Data.Map as Map
import qualified Database.Esqueleto as E
import qualified Data.Set as Set
import qualified Control.Monad.State.Class as State
-- | Default start day of term for season,
@ -18,32 +20,15 @@ defaultDay True Summer = fromGregorian 2020 4 1
defaultDay False Summer = fromGregorian 2020 9 30
validateTerm :: Term -> [Text]
validateTerm Term{..} =
[ msg | (False, msg) <-
[ --startOk
( termStart `withinTerm` termName
, "Jahreszahl im Namenskürzel stimmt nicht mit Semesterbeginn überein."
)
, -- endOk
( termStart < termEnd
, "Semester darf nicht enden, bevor es begann."
)
, -- startOk
( termLectureStart < termLectureEnd
, "Vorlesungszeit muss vor ihrem Ende anfgangen."
)
, -- lecStartOk
( termStart <= termLectureStart
, "Semester muss vor der Vorlesungszeit beginnen."
)
, -- lecEndOk
( termEnd >= termLectureEnd
, "Vorlesungszeit muss vor dem Semester enden."
)
] ]
validateTerm :: (MonadHandler m, HandlerSite m ~ UniWorX)
=> FormValidator Term m ()
validateTerm = do
Term{..} <- State.get
guardValidation MsgTermStartMustMatchName $ termStart `withinTerm` termName
guardValidation MsgTermEndMustBeAfterStart $ termStart < termEnd
guardValidation MsgTermLectureEndMustBeAfterStart $ termLectureStart < termLectureEnd
guardValidation MsgTermStartMustBeBeforeLectureStart $ termStart <= termLectureStart
guardValidation MsgTermEndMustBeAfterLectureEnd $ termEnd >= termLectureEnd
getTermShowR :: Handler TypedContent
@ -66,22 +51,22 @@ getTermShowR = do
provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData)
provideRep $ do
let colonnadeTerms = widgetColonnade $ mconcat
[ sortable (Just "term-id") "Kürzel" $ \(Entity tid _, _) -> anchorCell
[ sortable (Just "term-id") (i18nCell MsgTermShort) $ \(Entity tid _, _) -> anchorCell
(TermCourseListR tid)
[whamlet|#{toPathPiece tid}|]
, sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_) ->
cell $ formatTime SelFormatDate termLectureStart >>= toWidget
, sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) ->
, sortable (Just "lecture-end") (i18nCell MsgTermLectureEnd) $ \(Entity _ Term{..},_) ->
cell $ formatTime SelFormatDate termLectureEnd >>= toWidget
, sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) ->
, sortable Nothing (i18nCell MsgTermActive) $ \(Entity _ Term{..},_) ->
tickmarkCell termActive
, sortable Nothing "Kurse" $ \(_, E.Value numCourses) ->
, sortable Nothing (i18nCell MsgTermCourseCount) $ \(_, E.Value numCourses) ->
cell [whamlet|_{MsgNumCourses numCourses}|]
, sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) ->
, sortable (Just "start") (i18nCell MsgTermStart) $ \(Entity _ Term{..},_) ->
cell $ formatTime SelFormatDate termStart >>= toWidget
, sortable (Just "end") "Semesterende" $ \(Entity _ Term{..},_) ->
, sortable (Just "end") (i18nCell MsgTermEnd) $ \(Entity _ Term{..},_) ->
cell $ formatTime SelFormatDate termEnd >>= toWidget
, sortable Nothing "Feiertage im Semester" $ \(Entity _ Term{..},_) ->
, sortable Nothing (i18nCell MsgTermHolidays) $ \(Entity _ Term{..},_) ->
cell $ do
termHolidays' <- mapM (formatTime SelFormatDate) termHolidays
[whamlet|
@ -248,7 +233,7 @@ termToTemplate (Just Term{..}) = TermFormTemplate
}
newTermForm :: TermFormTemplate -> Form Term
newTermForm template html = do
newTermForm template = validateForm validateTerm $ \html -> do
mr <- getMessageRender
let
tidForm
@ -264,7 +249,7 @@ newTermForm template html = do
(fslI MsgTermHolidays & setTooltip MsgMassInputTip)
True
(tftHolidays template)
(result, widget) <- flip (renderAForm FormStandard) html $ Term
flip (renderAForm FormStandard) html $ Term
<$> tidForm
<*> areq dayField (fslI MsgTermStartDay & setTooltip MsgTermStartDayTooltip) (tftStart template)
<*> areq dayField (fslI MsgTermEndDay & setTooltip MsgTermEndDayTooltip) (tftEnd template)
@ -272,24 +257,3 @@ newTermForm template html = do
<*> areq dayField (fslI MsgTermLectureStart) (tftLectureStart template)
<*> areq dayField (fslI MsgTermLectureEnd & setTooltip MsgTermLectureEndTooltip) (tftLectureEnd template)
<*> areq checkBoxField (fslI MsgTermActive) (tftActive template)
return $ case result of
FormSuccess termResult
| errorMsgs <- validateTerm termResult
, not $ null errorMsgs ->
(FormFailure errorMsgs,
[whamlet|
<div class="alert alert-danger">
<div class="alert__content">
<h4> Fehler:
<ul>
$forall errmsg <- errorMsgs
<li> #{errmsg}
^{widget}
|]
)
_ -> (result, widget)
{-
where
set :: Text -> FieldSettings site
set = bfs
-}

2
src/Handler/Tutorial/TutorInvite.hs
View File

@ -64,7 +64,7 @@ tutorInvitationConfig = InvitationConfig{..}
invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- liftHandler requireAuthId
itAuthority <- Right <$> liftHandler requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized
invitationForm _ _ _ = pure (JunctionTutor, ())

4
src/Handler/Users.hs
View File

@ -390,7 +390,7 @@ postAdminUserR uuid = do
}
userDataWidget <- runDB $ makeProfileData $ Entity uid user
siteLayout heading $ do
let deleteWidget = $(widgetFile "widgets/data-delete/data-delete")
let deleteWidget = $(i18nWidgetFile "data-delete")
$(widgetFile "adminUser")
@ -572,7 +572,7 @@ functionInvitationConfig = InvitationConfig{..}
MsgRenderer mr <- getMsgRenderer
return [ihamlet|_{SomeMessage $ MsgSchoolFunctionInviteExplanation (mr $ SomeMessage invTokenUserFunctionFunction)}|]
invitationTokenConfig _ (InvDBDataUserFunction{..}, _) = do
itAuthority <- liftHandler requireAuthId
itAuthority <- Right <$> liftHandler requireAuthId
let itExpiresAt = Just $ Just invDBUserFunctionDeadline
itAddAuth = Nothing
itStartsAt = Nothing

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

@ -76,7 +76,7 @@ postAdminUserAddR = do
, userWarningDays = userDefaultWarningDays
, userShowSex = userDefaultShowSex
, userNotificationSettings = def
, userMailLanguages = def
, userLanguages = Nothing
, userCsvOptions = def
, userTokensIssuedAfter = Nothing
, userCreated = now

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

@ -90,7 +90,7 @@ formatTimeW :: (HasLocalTime t) => SelDateTimeFormat -> t -> Widget
formatTimeW s t = toWidget =<< formatTime s t
formatTimeMail :: (MonadMail m, HasLocalTime t) => SelDateTimeFormat -> t -> m Text
formatTimeMail sel t = fmap fromString $ Time.formatTime <$> (getTimeLocale' . mailLanguages <$> askMailLanguages) <*> (unDateTimeFormat <$> askMailDateTimeFormat sel) <*> pure (toLocalTime t)
formatTimeMail sel t = fmap fromString $ Time.formatTime <$> (getTimeLocale' . view _Wrapped <$> askMailLanguages) <*> (unDateTimeFormat <$> askMailDateTimeFormat sel) <*> pure (toLocalTime t)
getTimeLocale :: MonadHandler m => m TimeLocale
getTimeLocale = getTimeLocale' <$> languages

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

@ -70,7 +70,7 @@ examBonus (Entity eId Exam{..}) = runConduit $
[ E.when_
( E.not_ . E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence )
E.then_
( E.just (sheet E.^. SheetActiveTo) E.<=. examOccurrence E.?. ExamOccurrenceStart
( E.maybe E.true ((E.<=. examOccurrence E.?. ExamOccurrenceStart) . E.just) (sheet E.^. SheetActiveTo)
E.&&. sheet E.^. SheetVisibleFrom E.<=. examOccurrence E.?. ExamOccurrenceStart
)
]

85
src/Handler/Utils/Form.hs
View File

@ -220,8 +220,17 @@ multiAction :: forall action a.
-> FieldSettings UniWorX
-> Maybe action
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
multiAction acts fs@FieldSettings{..} defAction csrf = do
(actionRes, actionView) <- mreq (selectField . optionsF $ Map.keysSet acts) fs defAction
multiAction = multiAction' mpopt
multiAction' :: forall action a.
( RenderMessage UniWorX action, PathPiece action, Ord action )
=> (Field Handler action -> FieldSettings UniWorX -> Maybe action -> MForm Handler (FormResult action, FieldView UniWorX))
-> Map action (AForm Handler a)
-> FieldSettings UniWorX
-> Maybe action
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
multiAction' minp acts fs@FieldSettings{..} defAction csrf = do
(actionRes, actionView) <- minp (selectField . optionsF $ Map.keysSet acts) fs defAction
results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
let actionResults = view _1 <$> results
@ -284,21 +293,12 @@ htmlField' = htmlField
natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
natFieldI msg = convertField fromInteger toInteger $ checkBool (>= 0) msg $ intMinField 0
natField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
natField d = convertField fromInteger toInteger $ checkBool (>= 0) (T.append d " muss eine natürliche Zahl sein.") $ intMinField 0
natIntField ::(Monad m, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m Integer
natIntField = natField
posIntField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
posIntField d = convertField fromInteger toInteger $ checkBool (> 0) (T.append d " muss eine positive Zahl sein.") $ intMinField 1
posIntFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
posIntFieldI msg = convertField fromInteger toInteger $ checkBool (> 0) msg $ intMinField 0
-- | Field to request integral number > 'm'
minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Text -> Field m i
minIntField m d = checkBool (> m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) $ intMinField m
minIntFieldI :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage, RenderMessage (HandlerSite m) msg) => i -> msg -> Field m i
minIntFieldI m msg = checkBool (> m) msg $ intMinField m
pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points
pointsField = pointsFieldMinMax (Just 0) Nothing
@ -652,13 +652,17 @@ pseudonymWordField = checkMMap doCheck id $ ciField & addDatalist (return $ mkOp
| otherwise
= return . Left $ MsgUnknownPseudonymWord (CI.original w)
specificFileField :: UploadSpecificFile -> Field Handler (ConduitT () File Handler ())
type FileUploads = ConduitT () (Either FileId File) Handler ()
specificFileField :: UploadSpecificFile -> Field Handler FileUploads
specificFileField UploadSpecificFile{..} = Field{..}
where
fieldEnctype = Multipart
fieldParse _ files
| [f] <- files
= return . Right . Just $ yieldM (acceptFile f) .| modifyFileTitle (const $ unpack specificFileName)
= return . Right . Just $ yieldM (acceptFile f) .| modifyFileTitle (const $ unpack specificFileName) .| C.map Right
| null files = return $ Right Nothing
| otherwise = return . Left $ SomeMessage MsgOnlyUploadOneFile
fieldView fieldId fieldName attrs _ req = $(widgetFile "widgets/specificFileField")
@ -670,14 +674,14 @@ specificFileField UploadSpecificFile{..} = Field{..}
zipFileField :: Bool -- ^ Unpack zips?
-> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions
-> Field Handler (ConduitT () File Handler ())
-> Field Handler FileUploads
zipFileField doUnpack permittedExtensions = Field{..}
where
fieldEnctype = Multipart
fieldParse _ files
| [f@FileInfo{..}] <- files
, maybe True (anyOf (re _nullable . folded . unpacked) ((flip isExtensionOf `on` CI.foldCase) $ unpack fileName)) permittedExtensions || doUnpack
= return . Right . Just $ bool (yieldM . acceptFile) sourceFiles doUnpack f
= return . Right . Just $ bool (yieldM . fmap Right . acceptFile) ((.| C.map Right) . sourceFiles) doUnpack f
| null files = return $ Right Nothing
| otherwise = return . Left $ SomeMessage MsgOnlyUploadOneFile
fieldView fieldId fieldName attrs _ req = $(widgetFile "widgets/zipFileField")
@ -689,7 +693,7 @@ zipFileField doUnpack permittedExtensions = Field{..}
fileUploadForm :: Bool -- ^ Required?
-> (Bool -> FieldSettings UniWorX) -- ^ given @unpackZips@ generate `FieldSettings` in the case of `UploadAny`
-> UploadMode -> AForm Handler (Maybe (ConduitT () File Handler ()))
-> UploadMode -> AForm Handler (Maybe FileUploads)
fileUploadForm isReq mkFs = \case
NoUpload
-> pure Nothing
@ -698,21 +702,21 @@ fileUploadForm isReq mkFs = \case
UploadSpecific{..}
-> mergeFileSources <$> sequenceA (map specificFileForm . Set.toList $ toNullable specificFiles)
where
specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe (ConduitT () File Handler ()))
specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe FileUploads)
specificFileForm spec@UploadSpecificFile{..}
= bool (\f fs d -> aopt f fs $ fmap Just d) (\f fs d -> Just <$> areq f fs d) specificFileRequired (specificFileField spec) (fsl specificFileLabel) Nothing
mergeFileSources :: [Maybe (ConduitT () File Handler ())] -> Maybe (ConduitT () File Handler ())
mergeFileSources :: [Maybe FileUploads] -> Maybe FileUploads
mergeFileSources (catMaybes -> sources) = case sources of
[] -> Nothing
fs -> Just $ sequence_ fs
multiFileField' :: ConduitT () (Either FileId File) Handler () -- ^ Permitted files in same format as produced by `multiFileField`
-> Field Handler (ConduitT () (Either FileId File) Handler ())
multiFileField' :: FileUploads -- ^ Permitted files in same format as produced by `multiFileField`
-> Field Handler FileUploads
multiFileField' permittedFiles = multiFileField . runConduit $ permittedFiles .| C.mapMaybe (preview _Left) .| C.foldMap Set.singleton
multiFileField :: Handler (Set FileId) -- ^ Set of files that may be submitted by id-reference
-> Field Handler (ConduitT () (Either FileId File) Handler ())
-> Field Handler FileUploads
multiFileField permittedFiles' = Field{..}
where
fieldEnctype = Multipart
@ -755,7 +759,7 @@ multiFileField permittedFiles' = Field{..}
$(widgetFile "widgets/multiFileField")
unpackZips :: Text
unpackZips = "unpack-zip"
takeLefts :: Monad m => ConduitM (Either b a) b m ()
takeLefts :: Monad m => ConduitT (Either b a) b m ()
takeLefts = awaitForever $ \case
Right _ -> return ()
Left r -> yield r
@ -831,7 +835,7 @@ sheetGroupAFormReq fs template = multiActionA selOptions fs (classify' <$> templ
where
selOptions = Map.fromList
[ ( Arbitrary', Arbitrary
<$> apreq (natField "Gruppengröße") (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template)
<$> apreq (natFieldI MsgGroupSizeNotNatural) (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template)
)
, ( RegisteredGroups', pure RegisteredGroups )
, ( NoGroups', pure NoGroups )
@ -861,6 +865,10 @@ dayTimeField fs mutc = do
| otherwise = (Nothing,Nothing)
-}
fieldTimeFormat :: String
-- fieldTimeFormat = "%e.%m.%y %k:%M"
fieldTimeFormat = "%Y-%m-%dT%H:%M:%S"
localTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m LocalTime
localTimeField = Field
{ fieldParse = parseHelperGen readTime
@ -873,11 +881,7 @@ localTimeField = Field
, fieldEnctype = UrlEncoded
}
where
fieldTimeFormat :: String
--fieldTimeFormat = "%e.%m.%y %k:%M"
fieldTimeFormat = "%Y-%m-%dT%H:%M:%S"
-- `defaultTimeLocale` is okay here, since `fieldTimeFormat` does not contain any
-- `defaultTimeLocale` is okay here, since `fieldTimeFormat` does not contain any words
readTime :: Text -> Either UniWorXMessage LocalTime
readTime t =
case parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
@ -925,8 +929,8 @@ jsonField hide = Field{..}
boolField :: ( MonadHandler m
, HandlerSite m ~ UniWorX
)
=> Field m Bool
boolField = Field
=> Maybe (SomeMessage UniWorX) -> Field m Bool
boolField mkNone = Field
{ fieldParse = \e _ -> return $ boolParser e
, fieldView = \theId name attrs val isReq -> $(widgetFile "widgets/fields/bool")
, fieldEnctype = UrlEncoded
@ -1150,7 +1154,7 @@ multiUserField onlySuggested suggestions = Field{..}
case dbRes of
[] -> return $ Left email
[E.Value uid] -> return $ Right uid
_other -> throwE $ SomeMessage ("Ambiguous e-mail addr" :: Text)
_other -> throwE $ SomeMessage MsgAmbiguousEmail
examResultField :: forall m res.
( MonadHandler m
@ -1244,13 +1248,14 @@ csvFormatOptionsForm fs mPrev = hoistAForm liftHandler . multiActionA csvActs fs
MsgRenderer mr <- getMsgRenderer
let
opts =
[ (MsgCsvDelimiterNull, '\0')
, (MsgCsvDelimiterTab, '\t')
, (MsgCsvDelimiterComma, ',')
, (MsgCsvDelimiterColon, chr 58)
, (MsgCsvDelimiterBar, '|')
, (MsgCsvDelimiterSpace, ' ')
, (MsgCsvDelimiterUnitSep, chr 31)
[ (MsgCsvDelimiterNull, '\0')
, (MsgCsvDelimiterTab, '\t')
, (MsgCsvDelimiterComma, ',')
, (MsgCsvDelimiterColon, chr 58)
, (MsgCsvDelimiterSemicolon, chr 59)
, (MsgCsvDelimiterBar, '|')
, (MsgCsvDelimiterSpace, ' ')
, (MsgCsvDelimiterUnitSep, chr 31)
]
olReadExternal t = do
i <- readMay t

39
src/Handler/Utils/I18n.hs
View File

@ -1,14 +1,22 @@
module Handler.Utils.I18n
where
( i18nWidgetFile
, i18nWidgetFilesAvailable, i18nWidgetFilesAvailable', i18nWidgetFiles
) where
import Import
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (qRunIO)
import qualified Language.Haskell.TH.Syntax as TH
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Text as Text
import System.Directory (listDirectory)
import System.FilePath.Posix (takeBaseName)
@ -40,4 +48,31 @@ i18nWidgetFile basename = do
[ funD ws $ [ clause [litP $ stringL l] (normalB . widgetFile $ "i18n" </> basename </> l) []
| l <- unpack <$> NonEmpty.toList availableTranslations' -- One function definition for every available language
] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match
] [e|selectLanguage availableTranslations' >>= $(varE ws)|]
] [e|selectLanguage availableTranslations' >>= $(varE ws)|]
i18nWidgetFilesAvailable' :: FilePath -> Q (Map Text (NonEmpty Text))
i18nWidgetFilesAvailable' basename = do
let i18nDirectory = "templates" </> "i18n" </> basename
availableFiles <- qRunIO $ listDirectory i18nDirectory
let fileKinds' = fmap (pack . dropExtension . takeBaseName &&& toTranslation . pack . takeBaseName) availableFiles
fileKinds :: Map Text [Text]
fileKinds = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . Set.toList <$> Map.fromListWith Set.union [ (kind, Set.singleton l) | (kind, Just l) <- fileKinds' ]
toTranslation fName = listToMaybe . sortOn length . mapMaybe (flip Text.stripPrefix fName . (<>".")) $ map fst fileKinds'
iforM fileKinds $ \kind -> maybe (fail $ "‘" <> i18nDirectory <> "’ has no translations for ‘" <> unpack kind <> "’") return . NonEmpty.nonEmpty
i18nWidgetFilesAvailable :: FilePath -> Q Exp
i18nWidgetFilesAvailable = TH.lift <=< i18nWidgetFilesAvailable'
i18nWidgetFiles :: FilePath -> Q Exp
i18nWidgetFiles basename = do
availableTranslations' <- i18nWidgetFilesAvailable' basename
-- Dispatch to correct language (depending on user settings via `selectLanguage`) at run time
ws <- newName "ws" -- Name for dispatch function
letE
[ funD ws $ [ clause [litP $ stringL kind, litP $ stringL l] (normalB [e|$(widgetFile $ "i18n" </> basename </> kind <.> l) :: Widget|]) []
| (unpack -> kind, ls) <- Map.toList availableTranslations'
, l <- unpack <$> NonEmpty.toList ls
] ++ [ clause [wildP, wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match
] [e|imap (\kind ls -> selectLanguage ls >>= $(varE ws) kind) availableTranslations'|]

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

@ -144,7 +144,7 @@ data InvitationConfig junction = forall formCtx. InvitationConfig
-- | Additional configuration needed for an invocation of `bearerToken`
data InvitationTokenConfig = InvitationTokenConfig
{ itAuthority :: UserId
{ itAuthority :: Either Value UserId
, itAddAuth :: Maybe AuthDNF
, itExpiresAt :: Maybe (Maybe UTCTime)
, itStartsAt :: Maybe UTCTime

4
src/Handler/Utils/Mail.hs
View File

@ -47,14 +47,14 @@ userMailT :: ( MonadHandler m
) => UserId -> MailT m a -> m a
userMailT uid mAct = do
user@User
{ userMailLanguages
{ userLanguages
, userDateTimeFormat
, userDateFormat
, userTimeFormat
} <- liftHandler . runDB $ getJust uid
let
ctx = MailContext
{ mcLanguages = userMailLanguages
{ mcLanguages = fromMaybe def userLanguages
, mcDateTimeFormat = \case
SelFormatDateTime -> userDateTimeFormat
SelFormatDate -> userDateFormat

6
src/Handler/Utils/Rating.hs
View File

@ -47,8 +47,8 @@ instance Pretty x => Pretty (CI x) where
instance Pretty SheetGrading where
pretty Points{..} = pretty ( show maxPoints <> " Punkte" :: String)
pretty PassPoints{..} = pretty ( show maxPoints <> " Punkte, bestanden ab " <> show passingPoints <> " Punkte" :: String )
pretty Points{..} = pretty ( "Maximal " <> show maxPoints <> " Punkt(e)" :: String)
pretty PassPoints{..} = pretty ( "Maximal " <> show maxPoints <> " Punkt(e), bestanden ab " <> show passingPoints <> " Punkt(en)" :: String )
pretty PassBinary = pretty ( "Bestanden (1) / Nicht bestanden (0)" :: String )
@ -113,7 +113,7 @@ formatRating cID Rating{ ratingValues = Rating'{..}, ..} = let
[ Just $ "Veranstaltung:" <+> pretty ratingCourseName
, Just $ "Blatt:" <+> pretty ratingSheetName
, ("Korrektor:" <+>) . pretty <$> ratingCorrectorName
, ("Bewertung:" <+>) . pretty <$> (ratingSheetType ^? _grading)
, ("Bewertungsschema:" <+>) . pretty <$> (ratingSheetType ^? _grading)
]
, "Abgabe-Id:" <+> pretty (Text.unpack $ toPathPiece cID)
, "============================================="

11
src/Handler/Utils/Routes.hs Normal file
View File

@ -0,0 +1,11 @@
module Handler.Utils.Routes
( classifyHandler
) where
import Import
import Utils.TH.Routes
classifyHandler :: Route UniWorX -> String
classifyHandler = $(classifyHandler' uniworxRoutes)

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

@ -10,7 +10,7 @@ import qualified Database.Esqueleto.Internal.Sql as E
-- | Map sheet file types to their visibily dates of a given sheet, for convenience
sheetFileTypeDates :: Sheet -> SheetFileType -> Maybe UTCTime
sheetFileTypeDates Sheet{..} = \case
SheetExercise -> Just sheetActiveFrom
SheetExercise -> sheetActiveFrom
SheetHint -> sheetHintFrom
SheetSolution -> sheetSolutionFrom
SheetMarking -> Nothing

4
src/Handler/Utils/Submission.hs
View File

@ -50,6 +50,8 @@ import Text.Hamlet (ihamletFile)
import qualified Control.Monad.Catch as E (Handler(..))
import qualified Data.CaseInsensitive as CI
data AssignSubmissionException = NoCorrectors
| NoCorrectorsByProportion
| SubmissionsNotFound (NonNull (Set SubmissionId))
@ -428,7 +430,7 @@ sinkSubmission userId mExists isUpdate = do
, Just (map unpack . Set.toList . toNullable -> exts) <- extensionRestriction
= Conduit.mapM $ \x -> if
| Left File{..} <- x
, none (`isExtensionOf` fileTitle) exts
, none ((flip isExtensionOf `on` CI.foldCase) fileTitle) exts
, isn't _Nothing fileContent -- File record is not a directory, we don't care about those
-> throwM $ InvalidFileTitleExtension fileTitle
| otherwise

6
src/Handler/Utils/Table/Columns.hs
View File

@ -203,7 +203,7 @@ fltrAllocationActive cTime queryAllocation = singletonMap "active" . FilterColum
E.&&. E.maybe E.true (\t -> E.val cTime E.<=. t) (allocation E.^. AllocationRegisterTo)
fltrAllocationActiveUI :: DBFilterUI
fltrAllocationActiveUI mPrev = prismAForm (singletonFilter "active" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgAllocationActive)
fltrAllocationActiveUI mPrev = prismAForm (singletonFilter "active" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgAllocationActive)
-----------
@ -355,7 +355,7 @@ fltrApplicationVeto :: OpticFilterColumn t Bool
fltrApplicationVeto queryVeto = singletonMap "veto" . FilterColumn . mkExactFilter $ view queryVeto
fltrApplicationVetoUI :: DBFilterUI
fltrApplicationVetoUI mPrev = prismAForm (singletonFilter "veto" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgCourseApplicationVeto)
fltrApplicationVetoUI mPrev = prismAForm (singletonFilter "veto" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgCourseApplicationVeto)
colApplicationRatingComment :: OpticColonnade (Maybe Text)
colApplicationRatingComment resultComment = Colonnade.singleton (fromSortable header) body
@ -407,7 +407,7 @@ fltrApplicationFiles :: OpticFilterColumn t Bool
fltrApplicationFiles queryFiles = singletonMap "has-files" . FilterColumn . mkExactFilter $ view queryFiles
fltrApplicationFilesUI :: DBFilterUI
fltrApplicationFilesUI mPrev = prismAForm (singletonFilter "has-files" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgCourseApplicationFiles)
fltrApplicationFilesUI mPrev = prismAForm (singletonFilter "has-files" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgCourseApplicationFiles)
---------------
-- Files

4
src/Import/NoModel.hs
View File

@ -142,6 +142,7 @@ import Text.Blaze.Instances as Import ()
import Jose.Jwt.Instances as Import ()
import Web.PathPieces.Instances as Import ()
import Data.Universe.Instances.Reverse.MonoTraversable ()
import Data.Universe.Instances.Reverse.WithIndex ()
import Database.Persist.Class.Instances as Import ()
import Database.Persist.Types.Instances as Import ()
import Data.UUID.Instances as Import ()
@ -152,6 +153,9 @@ import Crypto.Hash.Instances as Import ()
import Colonnade.Instances as Import ()
import Data.Bool.Instances as Import ()
import Data.Encoding.Instances as Import ()
import Prometheus.Instances as Import ()
import Crypto.Hash as Import (Digest, SHA3_256)
import Control.Lens as Import
hiding ( (<.>)

62
src/Jobs.hs
View File

@ -71,6 +71,7 @@ import Jobs.Handler.TransactionLog
import Jobs.Handler.SynchroniseLdap
import Jobs.Handler.PruneInvitations
import Jobs.Handler.ChangeUserDisplayEmail
import Jobs.Handler.PruneFiles
import Jobs.HealthReport
@ -250,23 +251,26 @@ execCrontab :: RWST JobContext () (HashMap JobCtl (Max UTCTime)) (HandlerFor Uni
-- ^ Keeping a `HashMap` of the latest execution times of `JobCtl`s we have
-- seen, wait for the time of the next job and fire it
execCrontab = do
mapRWST (liftHandler . runDB . setSerializable) $ do
let
mergeLastExec (Entity _leId CronLastExec{..})
| Just job <- Aeson.parseMaybe parseJSON cronLastExecJob
= State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max cronLastExecTime)
| otherwise = return ()
let
mergeState :: MonadResource m => RWST _ () _ (ReaderT SqlBackend m) ()
mergeState = do
let
mergeLastExec (Entity _leId CronLastExec{..})
| Just job <- Aeson.parseMaybe parseJSON cronLastExecJob
= State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max cronLastExecTime)
| otherwise = return ()
mergeQueued (Entity _qjId QueuedJob{..})
| Just job <- Aeson.parseMaybe parseJSON queuedJobContent
= State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max queuedJobCreationTime)
| otherwise = return ()
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ mergeLastExec
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ mergeQueued
mergeQueued (Entity _qjId QueuedJob{..})
| Just job <- Aeson.parseMaybe parseJSON queuedJobContent
= State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max queuedJobCreationTime)
| otherwise = return ()
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ mergeLastExec
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ mergeQueued
mapRWST (liftHandler . runDB . setSerializable) $ mergeState
refT <- liftIO getCurrentTime
settings <- getsYesod appSettings'
(currentCrontab, (jobCtl, nextMatch)) <- mapRWST (liftIO . atomically) $ do
(currentCrontab, (jobCtl, nextMatch), currentState) <- mapRWST (liftIO . atomically) $ do
crontab <- liftBase . readTVar =<< asks jobCrontab
State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
@ -274,7 +278,7 @@ execCrontab = do
case earliestJob settings prevExec crontab refT of
Nothing -> liftBase retry
Just (_, MatchNone) -> liftBase retry
Just x -> return (crontab, x)
Just x -> return (crontab, x, prevExec)
do
lastTimes <- State.get
@ -283,18 +287,24 @@ execCrontab = do
let doJob = mapRWST (liftHandler . runDBJobs . setSerializable) $ do
newCrontab <- lift . hoist lift $ determineCrontab'
if
| ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
-> do
now <- liftIO $ getCurrentTime
foundation <- getYesod
State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl
case jobCtl of
JobCtlQueue job -> lift $ queueDBJobCron job
other -> runReaderT ?? foundation $ writeJobCtl other
| otherwise
-> mapRWST (liftIO . atomically) $
liftBase . void . flip swapTVar newCrontab =<< asks jobCrontab
when (newCrontab /= currentCrontab) $
mapRWST (liftIO . atomically) $
liftBase . void . flip swapTVar newCrontab =<< asks jobCrontab
mergeState
newState <- State.get
let upToDate = and
[ ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
, ((==) `on` HashMap.lookup jobCtl) newState currentState
]
when upToDate $ do
now <- liftIO $ getCurrentTime
foundation <- getYesod
State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl
case jobCtl of
JobCtlQueue job -> lift $ queueDBJobCron job
other -> runReaderT ?? foundation $ writeJobCtl other
case nextMatch of
MatchAsap -> doJob

81
src/Jobs/Crontab.hs
View File

@ -49,6 +49,15 @@ determineCrontab = execWriterT $ do
, cronRateLimit = appJobCronInterval
, cronNotAfter = Right CronNotScheduled
}
whenIsJust appPruneUnreferencedFiles $ \pInterval ->
tell $ HashMap.singleton
(JobCtlQueue JobPruneUnreferencedFiles)
Cron
{ cronInitial = CronAsap
, cronRepeat = CronRepeatScheduled CronAsap
, cronRateLimit = pInterval
, cronNotAfter = Right CronNotScheduled
}
oldestInvitationMUTC <- lift $ preview (_head . _entityVal . _invitationExpiresAt . _Just) <$> selectList [InvitationExpiresAt !=. Nothing] [Asc InvitationExpiresAt, LimitTo 1]
whenIsJust oldestInvitationMUTC $ \oldestInvUTC -> tell $ HashMap.singleton
@ -60,6 +69,16 @@ determineCrontab = execWriterT $ do
, 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
}
tell . flip foldMap universeF $ \kind ->
case appHealthCheckInterval kind of
Just int -> HashMap.singleton
@ -144,39 +163,41 @@ determineCrontab = execWriterT $ do
let
sheetJobs (Entity nSheet Sheet{..}) = do
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationSheetActive{..})
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveFrom
, cronRepeat = CronRepeatNever
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
}
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationSheetSoonInactive{..})
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . max sheetActiveFrom $ addUTCTime (-nominalDay) sheetActiveTo
, cronRepeat = CronRepeatOnChange -- Allow repetition of the notification (if something changes), but wait at least an hour
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
}
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationSheetInactive{..})
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Left appNotificationExpiration
}
when sheetAutoDistribute $
for_ sheetActiveFrom $ \aFrom ->
tell $ HashMap.singleton
(JobCtlQueue $ JobDistributeCorrections nSheet)
(JobCtlQueue $ JobQueueNotification NotificationSheetActive{..})
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
, cronRepeat = CronRepeatNever
, cronRateLimit = 3600 -- Irrelevant due to `cronRepeat`
, cronNotAfter = Left nominalDay
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ aFrom
, cronRepeat = CronRepeatNever
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Right $ maybe CronNotScheduled (CronTimestamp . utcToLocalTimeTZ appTZ) sheetActiveTo
}
for_ sheetActiveTo $ \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

2
src/Jobs/Handler/ChangeUserDisplayEmail.hs
View File

@ -12,7 +12,7 @@ import Text.Hamlet
dispatchJobChangeUserDisplayEmail :: UserId -> UserEmail -> Handler ()
dispatchJobChangeUserDisplayEmail jUser jDisplayEmail = do
token <- tokenRestrict SetDisplayEmailR jDisplayEmail <$> bearerToken jUser (Just $ HashSet.singleton SetDisplayEmailR) Nothing Nothing Nothing
token <- tokenRestrict SetDisplayEmailR jDisplayEmail <$> bearerToken (Right jUser) (Just $ HashSet.singleton SetDisplayEmailR) Nothing Nothing Nothing
jwt <- encodeToken token
let
setDisplayEmailUrl :: SomeRoute UniWorX

38
src/Jobs/Handler/PruneFiles.hs Normal file
View File

@ -0,0 +1,38 @@
module Jobs.Handler.PruneFiles
( dispatchJobPruneSessionFiles
, dispatchJobPruneUnreferencedFiles
) where
import Import hiding (matching)
import Database.Persist.Sql (deleteWhereCount)
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
dispatchJobPruneSessionFiles :: Handler ()
dispatchJobPruneSessionFiles = do
now <- liftIO getCurrentTime
expires <- getsYesod $ view _appSessionFilesExpire
n <- runDB $ deleteWhereCount [ SessionFileTouched <. addUTCTime (- expires) now ]
$logInfoS "PruneSessionFiles" [st|Deleted #{n} expired session files|]
dispatchJobPruneUnreferencedFiles :: Handler ()
dispatchJobPruneUnreferencedFiles = do
n <- runDB . E.deleteCount . E.from $ \file ->
E.where_ . E.not_ . E.any E.exists $ references file
$logInfoS "PruneUnreferencedFiles" [st|Deleted #{n} unreferenced files|]
where
references :: E.SqlExpr (Entity File) -> [E.SqlQuery ()]
references ((E.^. FileId) -> fId) =
[ E.from $ \matching -> E.where_ $ matching E.^. AllocationMatchingLog E.==. fId
, E.from $ \appInstr -> E.where_ $ appInstr E.^. CourseAppInstructionFileFile E.==. fId
, E.from $ \appFile -> E.where_ $ appFile E.^. CourseApplicationFileFile E.==. fId
, E.from $ \matFile -> E.where_ $ matFile E.^. MaterialFileFile E.==. fId
, E.from $ \newsFile -> E.where_ $ newsFile E.^. CourseNewsFileFile E.==. fId
, E.from $ \sessFile -> E.where_ $ sessFile E.^. SessionFileFile E.==. fId
, E.from $ \sheetFile -> E.where_ $ sheetFile E.^. SheetFileFile E.==. fId
, E.from $ \subFile -> E.where_ $ subFile E.^. SubmissionFileFile E.==. fId
]

8
src/Jobs/Handler/SendNotification.hs
View File

@ -22,4 +22,10 @@ import Jobs.Handler.SendNotification.CourseRegistered
dispatchJobSendNotification :: UserId -> Notification -> Handler ()
dispatchJobSendNotification jRecipient jNotification = $(dispatchTH ''Notification) jNotification jRecipient
dispatchJobSendNotification jRecipient jNotification = do
$(dispatchTH ''Notification) jNotification jRecipient
instanceID' <- getsYesod $ view instanceID
now <- liftIO getCurrentTime
runDB . insert_ $ SentNotification (toJSON jNotification) jRecipient now instanceID'

2
src/Jobs/Handler/SendNotification/Utils.hs
View File

@ -16,7 +16,7 @@ ihamletSomeMessage f trans = f $ trans . SomeMessage
mkEditNotifications :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n UniWorXMessage (Route UniWorX))
mkEditNotifications uid = liftHandler $ do
cID <- encrypt uid
jwt <- encodeToken =<< bearerToken uid (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
jwt <- encodeToken =<< bearerToken (Right uid) (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
let
editNotificationsUrl :: SomeRoute UniWorX
editNotificationsUrl = SomeRoute (UserNotificationR cID, [(toPathPiece GetBearer, toPathPiece jwt)])

2
src/Jobs/Handler/SendPasswordReset.hs
View File

@ -29,7 +29,7 @@ dispatchJobSendPasswordReset jRecipient = userMailT jRecipient $ do
LTUUnique utc' _ -> utc'
_other -> UTCTime (addDays 2 $ utctDay now) 0
resetToken' <- bearerToken jRecipient (Just . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing
resetToken' <- bearerToken (Right jRecipient) (Just . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing
let resetToken = resetToken'
& tokenRestrict (UserPasswordR cID) (decodeUtf8 . Base64.encode . BA.convert $ computeUserAuthenticationDigest userAuthentication)
encodedToken <- encodeToken resetToken

2
src/Jobs/Types.hs
View File

@ -67,6 +67,8 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
| JobChangeUserDisplayEmail { jUser :: UserId
, jDisplayEmail :: UserEmail
}
| JobPruneSessionFiles
| JobPruneUnreferencedFiles
deriving (Eq, Ord, Show, Read, Generic, Typeable)
data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
| NotificationSheetActive { nSheet :: SheetId }

46
src/Mail.hs
View File

@ -10,7 +10,7 @@ module Mail
, MailT, defMailT
, MailSmtpData(..)
, _MailSmtpDataSet
, MailContext(..), MailLanguages(..)
, MailContext(..)
, MonadMail(..)
, getMailMessageRender, getMailMsgRenderer
-- * YesodMail
@ -38,7 +38,7 @@ module Mail
import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender, derivePersistFieldJSON)
import Model.Types.TH.JSON
import Model.Types.Languages
import Network.Mail.Mime hiding (addPart, addAttachment)
import qualified Network.Mail.Mime as Mime (addPart)
@ -89,7 +89,7 @@ import qualified Data.Binary as Binary
import "network-bsd" Network.BSD (getHostName)
import Data.Time.Zones (TZ, utcTZ, utcToLocalTimeTZ, timeZoneForUTCTime)
import Data.Time.LocalTime (ZonedTime(..))
import Data.Time.LocalTime (ZonedTime(..), TimeZone(..))
import Data.Time.Format (rfc822DateFormat)
import Network.HaskellNet.SMTP (SMTPConnection)
@ -109,8 +109,6 @@ import Data.Universe.Instances.Reverse ()
import Data.Universe.Instances.Reverse.JSON ()
import Data.Universe.Instances.Reverse.Hashable ()
import GHC.Exts (IsList)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Data.CaseInsensitive (CI)
@ -160,19 +158,8 @@ _MailSmtpDataSet = to $ \MailSmtpData{..} -> none id
]
newtype MailLanguages = MailLanguages { mailLanguages :: [Lang] }
deriving (Eq, Ord, Show, Read, Generic, Typeable)
deriving newtype (FromJSON, ToJSON, IsList)
instance Default MailLanguages where
def = MailLanguages []
instance Hashable MailLanguages
instance NFData MailLanguages
data MailContext = MailContext
{ mcLanguages :: MailLanguages
{ mcLanguages :: Languages
, mcDateTimeFormat :: SelDateTimeFormat -> DateTimeFormat
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
@ -191,7 +178,7 @@ instance Default MailContext where
makeLenses_ ''MailContext
class (MonadHandler m, MonadState Mail m) => MonadMail m where
askMailLanguages :: m MailLanguages
askMailLanguages :: m Languages
askMailDateTimeFormat :: SelDateTimeFormat -> m DateTimeFormat
tellMailSmtpData :: MailSmtpData -> m ()
@ -214,7 +201,7 @@ getMailMessageRender :: ( MonadMail m
, HandlerSite m ~ site
, RenderMessage site msg
) => m (msg -> Text)
getMailMessageRender = renderMessage <$> getYesod <*> (mailLanguages <$> askMailLanguages)
getMailMessageRender = renderMessage <$> getYesod <*> (view _Wrapped <$> askMailLanguages)
getMailMsgRenderer :: forall site m.
( MonadMail m
@ -515,8 +502,24 @@ setDateCurrent = setDate =<< liftIO getCurrentTime
setDate :: (MonadHandler m, YesodMail (HandlerSite m)) => UTCTime -> MailT m ()
setDate time = do
tz <- mailDateTZ
let timeStr = formatTime defaultTimeLocale rfc822DateFormat $ ZonedTime (utcToLocalTimeTZ tz time) (timeZoneForUTCTime tz time)
let timeStr = formatTime defaultTimeLocale rfc822DateFormat $ ZonedTime (utcToLocalTimeTZ tz time) (rfc822zone $ timeZoneForUTCTime tz time)
replaceMailHeader "Date" . Just $ pack timeStr
where
rfc822zone tz'
| tz' `elem` rfc822zones = tz'
| otherwise = tz' { timeZoneName = "" }
rfc822zones =
[ TimeZone 0 False "UT"
, TimeZone 0 False "GMT"
, TimeZone (-5 * 60) False "EST"
, TimeZone (-4 * 60) True "EDT"
, TimeZone (-6 * 60) False "CST"
, TimeZone (-5 * 60) True "CDT"
, TimeZone (-7 * 60) False "MST"
, TimeZone (-6 * 60) True "MDT"
, TimeZone (-8 * 60) False "PST"
, TimeZone (-7 * 60) True "PDT"
]
setMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m), MonadThrow m) => MailT m ()
@ -543,6 +546,3 @@ setMailSmtpData = do
in tell $ mempty { smtpEnvelopeFrom = Last $ Just verp }
| otherwise
-> tell $ mempty { smtpEnvelopeFrom = Last $ Just from }
derivePersistFieldJSON ''MailLanguages

8
src/Model/Migration.hs
View File

@ -577,6 +577,14 @@ customMigrations = Map.fromListWith (>>)
ALTER TABLE "allocation" DROP COLUMN "matching_log";
|]
)
, ( AppliedMigrationKey [migrationVersion|26.0.0|] [version|27.0.0|]
, whenM (tableExists "user") $
[executeQQ|
ALTER TABLE "user" ADD COLUMN "languages" jsonb;
UPDATE "user" SET "languages" = "mail_languages" where "mail_languages" <> '[]';
ALTER TABLE "user" DROP COLUMN "mail_languages";
|]
)
]

10
src/Model/Tokens.hs
View File

@ -46,7 +46,7 @@ import Data.Binary (Binary)
data BearerToken site = BearerToken
{ tokenIdentifier :: TokenId
-- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
, tokenAuthority :: AuthId site
, tokenAuthority :: Either Value (AuthId site)
-- ^ Tokens only grant rights the `tokenAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `tokenAuthority`)
, tokenRoutes :: Maybe (HashSet (Route site))
-- ^ Tokens can optionally be restricted to only be usable on a subset of routes
@ -97,7 +97,7 @@ tokenToJSON :: forall m.
--
-- Monadic context is needed because `AuthId`s are encrypted during encoding
tokenToJSON BearerToken{..} = do
cID <- encrypt tokenAuthority :: m (CryptoUUID (AuthId (HandlerSite m)))
cID <- either (return . Left) (fmap Right . encrypt) tokenAuthority :: m (Either Value (CryptoUUID (AuthId (HandlerSite m))))
let stdPayload = Jose.JwtClaims
{ jwtIss = Just $ toPathPiece tokenIssuedBy
, jwtSub = Nothing
@ -108,7 +108,7 @@ tokenToJSON BearerToken{..} = do
, jwtJti = Just $ toPathPiece tokenIdentifier
}
return . JSON.object $
catMaybes [ Just $ "authority" .= cID
catMaybes [ Just $ "authority" .= either id toJSON cID
, ("routes" .=) <$> tokenRoutes
, ("add-auth" .=) <$> tokenAddAuth
, ("restrictions" .=) <$> assertM' (not . HashMap.null) tokenRestrictions
@ -128,8 +128,8 @@ tokenParseJSON :: forall site.
--
-- It's usually easier to use `Utils.Tokens.tokenParseJSON'`
tokenParseJSON v@(Object o) = do
tokenAuthority' <- lift (o .: "authority") :: ReaderT CryptoIDKey Parser (CryptoUUID (AuthId site))
tokenAuthority <- decrypt tokenAuthority'
tokenAuthority' <- lift $ (Right <$> o .: "authority") <|> (Left <$> o .: "authority") :: ReaderT CryptoIDKey Parser (Either Value (CryptoUUID (AuthId site)))
tokenAuthority <- either (return . Left) (fmap Right . decrypt) tokenAuthority'
tokenRoutes <- lift $ o .:? "routes"
tokenAddAuth <- lift $ o .:? "add-auth"

1
src/Model/Types.hs
View File

@ -14,3 +14,4 @@ import Model.Types.Submission as Types
import Model.Types.Misc as Types
import Model.Types.School as Types
import Model.Types.Allocation as Types
import Model.Types.Languages as Types

2
src/Model/Types/Common.hs
View File

@ -52,3 +52,5 @@ type InstanceId = UUID
type ClusterId = UUID
type TokenId = UUID
type TermCandidateIncidence = UUID
type SessionFileReference = Digest SHA3_256

25
src/Model/Types/Languages.hs Normal file
View File

@ -0,0 +1,25 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-}
module Model.Types.Languages
( Languages(..)
) where
import ClassyPrelude.Yesod hiding (derivePersistFieldJSON)
import GHC.Exts (IsList)
import Model.Types.TH.JSON
import Control.Lens.TH (makeWrapped)
newtype Languages = Languages [Lang]
deriving (Eq, Ord, Show, Read, Generic, Typeable)
deriving newtype (FromJSON, ToJSON, IsList)
instance Default Languages where
def = Languages []
instance Hashable Languages
instance NFData Languages
derivePersistFieldJSON ''Languages
makeWrapped ''Languages

23
src/Model/Types/Security.hs
View File

@ -21,6 +21,11 @@ import qualified Data.Aeson.Types as Aeson
import qualified Data.Binary as Binary
import qualified Data.CaseInsensitive as CI
import Model.Types.TH.PathPiece
import Database.Persist.Sql
data AuthenticationMode = AuthLDAP
| AuthPWHash { authPWHash :: Text }
@ -152,3 +157,21 @@ instance (Ord a, Binary a) => Binary (PredDNF a) where
type AuthLiteral = PredLiteral AuthTag
type AuthDNF = PredDNF AuthTag
data UserGroupName
= UserGroupMetrics
| UserGroupCustom { userGroupCustomName :: CI Text }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance PathPiece UserGroupName where
toPathPiece UserGroupMetrics = "metrics"
toPathPiece (UserGroupCustom t) = CI.original t
fromPathPiece t = Just $ if
| "metrics" `ciEq` t -> UserGroupMetrics
| otherwise -> UserGroupCustom $ CI.mk t
where
ciEq = (==) `on` CI.mk
pathPieceJSON ''UserGroupName
derivePersistFieldPathPiece' (sqlType (Proxy @(CI Text))) ''UserGroupName

15
src/Model/Types/TH/PathPiece.hs
View File

@ -1,5 +1,6 @@
module Model.Types.TH.PathPiece
( derivePersistFieldPathPiece
, derivePersistFieldPathPiece'
) where
import ClassyPrelude.Yesod
@ -13,7 +14,10 @@ import Language.Haskell.TH.Datatype
derivePersistFieldPathPiece :: Name -> DecsQ
derivePersistFieldPathPiece tName = do
derivePersistFieldPathPiece = derivePersistFieldPathPiece' SqlString
derivePersistFieldPathPiece' :: SqlType -> Name -> DecsQ
derivePersistFieldPathPiece' sType tName = do
DatatypeInfo{..} <- reifyDatatype tName
vars <- forM datatypeVars (const $ newName "a")
let t = foldl (\t' n' -> t' `appT` varT n') (conT tName) vars
@ -32,15 +36,18 @@ derivePersistFieldPathPiece tName = do
[ do
bs <- newName "bs"
clause [[p|PersistByteString $(varP bs)|]] (normalB [e|maybe (Left "Could not decode PathPiece from PersistByteString") Right $ fromPathPiece =<< either (const Nothing) Just (Text.decodeUtf8' $(varE bs))|]) []
, do
bs <- newName "bs"
clause [[p|PersistDbSpecific $(varP bs)|]] (normalB [e|maybe (Left "Could not decode PathPiece from PersistDbSpecific") Right $ fromPathPiece =<< either (const Nothing) Just (Text.decodeUtf8' $(varE bs))|]) []
, do
text <- newName "text"
clause [[p|PersistText $(varP text)|]] (normalB [e|maybe (Left "Could not decode PathPiece from PersistTetx") Right $ fromPathPiece $(varE text)|]) []
, clause [wildP] (normalB [e|Left "PathPiece values must be converted from PersistText or PersistByteString"|]) []
clause [[p|PersistText $(varP text)|]] (normalB [e|maybe (Left "Could not decode PathPiece from PersistText") Right $ fromPathPiece $(varE text)|]) []
, clause [wildP] (normalB [e|Left "PathPiece values must be converted from PersistText, PersistByteString, or PersistDbSpecific"|]) []
]
]
, instanceD sqlCxt ([t|PersistFieldSql|] `appT` t)
[ funD 'sqlType
[ clause [wildP] (normalB [e|SqlString|]) []
[ clause [wildP] (normalB [e|sType|]) []
]
]
]

29
src/Prometheus/Instances.hs Normal file
View File

@ -0,0 +1,29 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Prometheus.Instances
() where
import ClassyPrelude
import Prometheus
import Data.Aeson
import qualified Data.Map.Strict as Map
instance ToJSON SampleType where
toJSON = String . tshow
instance ToJSON SampleGroup where
toJSON (SampleGroup Info{..} sgType samples) = object
[ "name" .= metricName
, "help" .= metricHelp
, "type" .= sgType
, "metrics" .= samples
]
instance ToJSON Sample where
toJSON (Sample sName sLabels sValue) = object
[ "name" .= sName
, "labels" .= Map.fromList sLabels
, "value" .= decodeUtf8 sValue
]

6
src/Settings.hs
View File

@ -126,6 +126,9 @@ data AppSettings = AppSettings
, appSynchroniseLdapUsersWithin :: Maybe NominalDiffTime
, appSynchroniseLdapUsersInterval :: NominalDiffTime
, appSessionFilesExpire :: NominalDiffTime
, appPruneUnreferencedFiles :: Maybe NominalDiffTime
, appInitialLogSettings :: LogSettings
, appTransactionLogIPRetentionTime :: NominalDiffTime
@ -417,6 +420,9 @@ instance FromJSON AppSettings where
appSynchroniseLdapUsersWithin <- o .:? "synchronise-ldap-users-within"
appSynchroniseLdapUsersInterval <- o .: "synchronise-ldap-users-interval"
appSessionFilesExpire <- o .: "session-files-expire"
appPruneUnreferencedFiles <- o .:? "prune-unreferenced-files"
appMaximumContentLength <- o .: "maximum-content-length"
appReloadTemplates <- o .:? "reload-templates" .!= defaultDev

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