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

Merge branch 'master' into course-teaser-ui

Browse Source
This commit is contained in:
Gregor Kleen 2019-08-30 10:50:24 +02:00
commit cc0f79ec31
187 changed files with 7216 additions and 3384 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.babelrc
View File

@ -4,6 +4,7 @@
], ],
"plugins": [ "plugins": [
["@babel/plugin-proposal-decorators", { "legacy": true }], ["@babel/plugin-proposal-decorators", { "legacy": true }],
["@babel/plugin-proposal-class-properties", { "loose": true }] ["@babel/plugin-proposal-class-properties", { "loose": true }],
["@babel/transform-runtime"]
] ]
} }

5
.vscode/tasks.json vendored
View File

@ -69,6 +69,11 @@
"type": "npm", "type": "npm",
"script": "lint", "script": "lint",
"problemMatcher": [] "problemMatcher": []
},
{
"type": "npm",
"script": "release",
"problemMatcher": []
} }
] ]
} }

104
CHANGELOG.md
View File

@ -2,6 +2,110 @@
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
## [5.5.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.4.0...v5.5.0) (2019-08-27)
### Bug Fixes
* **changelog:** add date ([52a88f8](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/52a88f8))
* **course-applications-csv:** record rating time ([c2c6974](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/c2c6974))
### Features
* optional ribbon ([c2e13cf](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/c2e13cf))
## [5.4.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.3.0...v5.4.0) (2019-08-27)
### Bug Fixes
* **course-edit:** only show allocation error message when relevant ([00a6ca8](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/00a6ca8))
### Features
* **allocations:** serve archive of all application files by course ([5e393c5](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/5e393c5))
* allow editing of course applications outside of allocation ([e816a30](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/e816a30))
* **course-applications:** csv transport ([cf0ec1a](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/cf0ec1a))
## [5.3.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.2.3...v5.3.0) (2019-08-22)
### Bug Fixes
* **allocations:** fix behaviour of "active" dbTable-filter ([b694a09](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/b694a09))
* **course list:** show complete registration span ([754d6ca](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/754d6ca)), closes [#446](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/446)
* **home:** fix hlint and other minor bugs ([839251e](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/839251e))
### Features
* **allocations:** add info page for allocations ([689b85a](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/689b85a))
* **allocations:** show table of all allocations ([d621e61](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d621e61))
* **allocations:** show table of course applications ([f5da3be](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/f5da3be))
* **home:** allow users to define exam warning time ([d23e222](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d23e222)), closes [#445](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/445)
* **home:** clean up homepage ([a6e2f64](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a6e2f64))
### [5.2.3](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.2.2...v5.2.3) (2019-08-22)
### Bug Fixes
* **csv exam import:** ignore unchanged noshow and voided ([a346524](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a346524))
### [5.2.2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.2.1...v5.2.2) (2019-08-22)
### [5.2.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.2.0...v5.2.1) (2019-08-21)
### Bug Fixes
* **csv upload exams:** allow ambiguous harmless study fields ([7d2937c](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/7d2937c))
## [5.2.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.1.0...v5.2.0) (2019-08-21)
### Bug Fixes
* **csv import:** csv import preview help text adjusted ([b7321df](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/b7321df))
* **csv import:** fix spelling and expand help text ([2c57a77](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/2c57a77))
* **exam import:** inactive registered features may be selected ([3c4172c](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/3c4172c))
* **routes:** change ex to sheet ([9d9ead9](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/9d9ead9))
* **sheet list:** do not show icons for inaccessible items ([0bb9a0f](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/0bb9a0f)), closes [#421](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/421)
### Features
* **csv import:** add explanation text ([6d0a4c1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/6d0a4c1))
## [5.1.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.0.2...v5.1.0) (2019-08-19)
### Features
* **allocations:** add application form(s) ([ef625cd](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/ef625cd))
* **allocations:** add registration form ([c5b18fc](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/c5b18fc))
* **allocations:** implement application interface ([4dcc82a](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/4dcc82a))
* **allocations:** link allocations from home ([c759364](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/c759364))
* **allocations:** set up routes ([c2df01c](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/c2df01c))
### [5.0.2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.0.1...v5.0.2) (2019-08-13) ### [5.0.2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.0.1...v5.0.2) (2019-08-13)

5
config/settings.yml
View File

@ -41,6 +41,9 @@ health-check-delay-notify: "_env:HEALTHCHECK_DELAY_NOTIFY:true"
health-check-http: "_env:HEALTHCHECK_HTTP:true" # Can we assume, that we can reach ourselves under APPROOT via HTTP (reverse proxies or firewalls might prevent this)? health-check-http: "_env:HEALTHCHECK_HTTP:true" # Can we assume, that we can reach ourselves under APPROOT via HTTP (reverse proxies or firewalls might prevent this)?
health-check-active-job-executors-timeout: "_env:HEALTHCHECK_ACTIVE_JOB_EXECUTORS_TIMEOUT:5" health-check-active-job-executors-timeout: "_env:HEALTHCHECK_ACTIVE_JOB_EXECUTORS_TIMEOUT:5"
synchronise-ldap-users-within: "_env:SYNCHRONISE_LDAP_WITHIN:604800"
synchronise-ldap-users-interval: "_env:SYNCHRONISE_LDAP_INTERVAL:3600"
log-settings: log-settings:
detailed: "_env:DETAILED_LOGGING:false" detailed: "_env:DETAILED_LOGGING:false"
all: "_env:LOG_ALL:false" all: "_env:LOG_ALL:false"
@ -119,5 +122,7 @@ user-defaults:
date-format: "%d.%m.%Y" date-format: "%d.%m.%Y"
time-format: "%R" time-format: "%R"
download-files: false download-files: false
warning-days: 1209600
instance-id: "_env:INSTANCE_ID:instance" instance-id: "_env:INSTANCE_ID:instance"
ribbon: "_env:RIBBON:"

466
frontend/polyfills/fetch.js
View File

@ -1,466 +0,0 @@
(function(self) {
'use strict';
if (self.fetch) {
return
}
var support = {
searchParams: 'URLSearchParams' in self,
iterable: 'Symbol' in self && 'iterator' in Symbol,
blob: 'FileReader' in self && 'Blob' in self && (function() {
try {
new Blob()
return true
} catch(e) {
return false
}
})(),
formData: 'FormData' in self,
arrayBuffer: 'ArrayBuffer' in self
}
if (support.arrayBuffer) {
var viewClasses = [
'[object Int8Array]',
'[object Uint8Array]',
'[object Uint8ClampedArray]',
'[object Int16Array]',
'[object Uint16Array]',
'[object Int32Array]',
'[object Uint32Array]',
'[object Float32Array]',
'[object Float64Array]'
]
var isDataView = function(obj) {
return obj && DataView.prototype.isPrototypeOf(obj)
}
var isArrayBufferView = ArrayBuffer.isView || function(obj) {
return obj && viewClasses.indexOf(Object.prototype.toString.call(obj)) > -1
}
}
function normalizeName(name) {
if (typeof name !== 'string') {
name = String(name)
}
if (/[^a-z0-9\-#$%&'*+.\^_`|~]/i.test(name)) {
throw new TypeError('Invalid character in header field name')
}
return name.toLowerCase()
}
function normalizeValue(value) {
if (typeof value !== 'string') {
value = String(value)
}
return value
}
// Build a destructive iterator for the value list
function iteratorFor(items) {
var iterator = {
next: function() {
var value = items.shift()
return {done: value === undefined, value: value}
}
}
if (support.iterable) {
iterator[Symbol.iterator] = function() {
return iterator
}
}
return iterator
}
function Headers(headers) {
this.map = {}
if (headers instanceof Headers) {
headers.forEach(function(value, name) {
this.append(name, value)
}, this)
} else if (Array.isArray(headers)) {
headers.forEach(function(header) {
this.append(header[0], header[1])
}, this)
} else if (headers) {
Object.getOwnPropertyNames(headers).forEach(function(name) {
this.append(name, headers[name])
}, this)
}
}
Headers.prototype.append = function(name, value) {
name = normalizeName(name)
value = normalizeValue(value)
var oldValue = this.map[name]
this.map[name] = oldValue ? oldValue+','+value : value
}
Headers.prototype['delete'] = function(name) {
delete this.map[normalizeName(name)]
}
Headers.prototype.get = function(name) {
name = normalizeName(name)
return this.has(name) ? this.map[name] : null
}
Headers.prototype.has = function(name) {
return this.map.hasOwnProperty(normalizeName(name))
}
Headers.prototype.set = function(name, value) {
this.map[normalizeName(name)] = normalizeValue(value)
}
Headers.prototype.forEach = function(callback, thisArg) {
for (var name in this.map) {
if (this.map.hasOwnProperty(name)) {
callback.call(thisArg, this.map[name], name, this)
}
}
}
Headers.prototype.keys = function() {
var items = []
this.forEach(function(value, name) { items.push(name) })
return iteratorFor(items)
}
Headers.prototype.values = function() {
var items = []
this.forEach(function(value) { items.push(value) })
return iteratorFor(items)
}
Headers.prototype.entries = function() {
var items = []
this.forEach(function(value, name) { items.push([name, value]) })
return iteratorFor(items)
}
if (support.iterable) {
Headers.prototype[Symbol.iterator] = Headers.prototype.entries
}
function consumed(body) {
if (body.bodyUsed) {
return Promise.reject(new TypeError('Already read'))
}
body.bodyUsed = true
}
function fileReaderReady(reader) {
return new Promise(function(resolve, reject) {
reader.onload = function() {
resolve(reader.result)
}
reader.onerror = function() {
reject(reader.error)
}
})
}
function readBlobAsArrayBuffer(blob) {
var reader = new FileReader()
var promise = fileReaderReady(reader)
reader.readAsArrayBuffer(blob)
return promise
}
function readBlobAsText(blob) {
var reader = new FileReader()
var promise = fileReaderReady(reader)
reader.readAsText(blob)
return promise
}
function readArrayBufferAsText(buf) {
var view = new Uint8Array(buf)
var chars = new Array(view.length)
for (var i = 0; i < view.length; i++) {
chars[i] = String.fromCharCode(view[i])
}
return chars.join('')
}
function bufferClone(buf) {
if (buf.slice) {
return buf.slice(0)
} else {
var view = new Uint8Array(buf.byteLength)
view.set(new Uint8Array(buf))
return view.buffer
}
}
function Body() {
this.bodyUsed = false
this._initBody = function(body) {
this._bodyInit = body
if (!body) {
this._bodyText = ''
} else if (typeof body === 'string') {
this._bodyText = body
} else if (support.blob && Blob.prototype.isPrototypeOf(body)) {
this._bodyBlob = body
} else if (support.formData && FormData.prototype.isPrototypeOf(body)) {
this._bodyFormData = body
} else if (support.searchParams && URLSearchParams.prototype.isPrototypeOf(body)) {
this._bodyText = body.toString()
} else if (support.arrayBuffer && support.blob && isDataView(body)) {
this._bodyArrayBuffer = bufferClone(body.buffer)
// IE 10-11 can't handle a DataView body.
this._bodyInit = new Blob([this._bodyArrayBuffer])
} else if (support.arrayBuffer && (ArrayBuffer.prototype.isPrototypeOf(body) || isArrayBufferView(body))) {
this._bodyArrayBuffer = bufferClone(body)
} else {
throw new Error('unsupported BodyInit type')
}
if (!this.headers.get('content-type')) {
if (typeof body === 'string') {
this.headers.set('content-type', 'text/plain;charset=UTF-8')
} else if (this._bodyBlob && this._bodyBlob.type) {
this.headers.set('content-type', this._bodyBlob.type)
} else if (support.searchParams && URLSearchParams.prototype.isPrototypeOf(body)) {
this.headers.set('content-type', 'application/x-www-form-urlencoded;charset=UTF-8')
}
}
}
if (support.blob) {
this.blob = function() {
var rejected = consumed(this)
if (rejected) {
return rejected
}
if (this._bodyBlob) {
return Promise.resolve(this._bodyBlob)
} else if (this._bodyArrayBuffer) {
return Promise.resolve(new Blob([this._bodyArrayBuffer]))
} else if (this._bodyFormData) {
throw new Error('could not read FormData body as blob')
} else {
return Promise.resolve(new Blob([this._bodyText]))
}
}
this.arrayBuffer = function() {
if (this._bodyArrayBuffer) {
return consumed(this) || Promise.resolve(this._bodyArrayBuffer)
} else {
return this.blob().then(readBlobAsArrayBuffer)
}
}
}
this.text = function() {
var rejected = consumed(this)
if (rejected) {
return rejected
}
if (this._bodyBlob) {
return readBlobAsText(this._bodyBlob)
} else if (this._bodyArrayBuffer) {
return Promise.resolve(readArrayBufferAsText(this._bodyArrayBuffer))
} else if (this._bodyFormData) {
throw new Error('could not read FormData body as text')
} else {
return Promise.resolve(this._bodyText)
}
}
if (support.formData) {
this.formData = function() {
return this.text().then(decode)
}
}
this.json = function() {
return this.text().then(JSON.parse)
}
return this
}
// HTTP methods whose capitalization should be normalized
var methods = ['DELETE', 'GET', 'HEAD', 'OPTIONS', 'POST', 'PUT']
function normalizeMethod(method) {
var upcased = method.toUpperCase()
return (methods.indexOf(upcased) > -1) ? upcased : method
}
function Request(input, options) {
options = options || {}
var body = options.body
if (input instanceof Request) {
if (input.bodyUsed) {
throw new TypeError('Already read')
}
this.url = input.url
this.credentials = input.credentials
if (!options.headers) {
this.headers = new Headers(input.headers)
}
this.method = input.method
this.mode = input.mode
if (!body && input._bodyInit != null) {
body = input._bodyInit
input.bodyUsed = true
}
} else {
this.url = String(input)
}
this.credentials = options.credentials || this.credentials || 'omit'
if (options.headers || !this.headers) {
this.headers = new Headers(options.headers)
}
this.method = normalizeMethod(options.method || this.method || 'GET')
this.mode = options.mode || this.mode || null
this.referrer = null
if ((this.method === 'GET' || this.method === 'HEAD') && body) {
throw new TypeError('Body not allowed for GET or HEAD requests')
}
this._initBody(body)
}
Request.prototype.clone = function() {
return new Request(this, { body: this._bodyInit })
}
function decode(body) {
var form = new FormData()
body.trim().split('&').forEach(function(bytes) {
if (bytes) {
var split = bytes.split('=')
var name = split.shift().replace(/\+/g, ' ')
var value = split.join('=').replace(/\+/g, ' ')
form.append(decodeURIComponent(name), decodeURIComponent(value))
}
})
return form
}
function parseHeaders(rawHeaders) {
var headers = new Headers()
// Replace instances of \r\n and \n followed by at least one space or horizontal tab with a space
// https://tools.ietf.org/html/rfc7230#section-3.2
var preProcessedHeaders = rawHeaders.replace(/\r?\n[\t ]+/g, ' ')
preProcessedHeaders.split(/\r?\n/).forEach(function(line) {
var parts = line.split(':')
var key = parts.shift().trim()
if (key) {
var value = parts.join(':').trim()
headers.append(key, value)
}
})
return headers
}
Body.call(Request.prototype)
function Response(bodyInit, options) {
if (!options) {
options = {}
}
this.type = 'default'
this.status = options.status === undefined ? 200 : options.status
this.ok = this.status >= 200 && this.status < 300
this.statusText = 'statusText' in options ? options.statusText : 'OK'
this.headers = new Headers(options.headers)
this.url = options.url || ''
this._initBody(bodyInit)
}
Body.call(Response.prototype)
Response.prototype.clone = function() {
return new Response(this._bodyInit, {
status: this.status,
statusText: this.statusText,
headers: new Headers(this.headers),
url: this.url
})
}
Response.error = function() {
var response = new Response(null, {status: 0, statusText: ''})
response.type = 'error'
return response
}
var redirectStatuses = [301, 302, 303, 307, 308]
Response.redirect = function(url, status) {
if (redirectStatuses.indexOf(status) === -1) {
throw new RangeError('Invalid status code')
}
return new Response(null, {status: status, headers: {location: url}})
}
self.Headers = Headers
self.Request = Request
self.Response = Response
self.fetch = function(input, init) {
return new Promise(function(resolve, reject) {
var request = new Request(input, init)
var xhr = new XMLHttpRequest()
xhr.onload = function() {
var options = {
status: xhr.status,
statusText: xhr.statusText,
headers: parseHeaders(xhr.getAllResponseHeaders() || '')
}
options.url = 'responseURL' in xhr ? xhr.responseURL : options.headers.get('X-Request-URL')
var body = 'response' in xhr ? xhr.response : xhr.responseText
resolve(new Response(body, options))
}
xhr.onerror = function() {
reject(new TypeError('Network request failed'))
}
xhr.ontimeout = function() {
reject(new TypeError('Network request failed'))
}
xhr.open(request.method, request.url, true)
if (request.credentials === 'include') {
xhr.withCredentials = true
} else if (request.credentials === 'omit') {
xhr.withCredentials = false
}
if ('responseType' in xhr && support.blob) {
xhr.responseType = 'blob'
}
request.headers.forEach(function(value, name) {
xhr.setRequestHeader(name, value)
})
xhr.send(typeof request._bodyInit === 'undefined' ? null : request._bodyInit)
})
}
self.fetch.polyfill = true
})(typeof self !== 'undefined' ? self : this);

2
frontend/polyfills/main.js
View File

@ -1,2 +0,0 @@
import './fetch';
import './url-search-params';

348
frontend/polyfills/url-search-params.js
View File

@ -1,348 +0,0 @@
(function(global) {
/**
* Polyfill URLSearchParams
*
* Inspired from : https://github.com/WebReflection/url-search-params/blob/master/src/url-search-params.js
*/
var checkIfIteratorIsSupported = function() {
try {
return !!Symbol.iterator;
} catch(error) {
return false;
}
};
var iteratorSupported = checkIfIteratorIsSupported();
var createIterator = function(items) {
var iterator = {
next: function() {
var value = items.shift();
return { done: value === void 0, value: value };
}
};
if(iteratorSupported) {
iterator[Symbol.iterator] = function() {
return iterator;
};
}
return iterator;
};
/**
* Search param name and values should be encoded according to https://url.spec.whatwg.org/#urlencoded-serializing
* encodeURIComponent() produces the same result except encoding spaces as `%20` instead of `+`.
*/
var serializeParam = function(value) {
return encodeURIComponent(value).replace(/%20/g, '+');
};
var deserializeParam = function(value) {
return decodeURIComponent(value).replace(/\+/g, ' ');
};
var polyfillURLSearchParams= function() {
var URLSearchParams = function(searchString) {
Object.defineProperty(this, '_entries', { value: {} });
if(typeof searchString === 'string') {
if(searchString !== '') {
searchString = searchString.replace(/^\?/, '');
var attributes = searchString.split('&');
var attribute;
for(var i = 0; i < attributes.length; i++) {
attribute = attributes[i].split('=');
this.append(
deserializeParam(attribute[0]),
(attribute.length > 1) ? deserializeParam(attribute[1]) : ''
);
}
}
} else if(searchString instanceof URLSearchParams) {
var _this = this;
searchString.forEach(function(value, name) {
_this.append(value, name);
});
}
};
var proto = URLSearchParams.prototype;
proto.append = function(name, value) {
if(name in this._entries) {
this._entries[name].push(value.toString());
} else {
this._entries[name] = [value.toString()];
}
};
proto.delete = function(name) {
delete this._entries[name];
};
proto.get = function(name) {
return (name in this._entries) ? this._entries[name][0] : null;
};
proto.getAll = function(name) {
return (name in this._entries) ? this._entries[name].slice(0) : [];
};
proto.has = function(name) {
return (name in this._entries);
};
proto.set = function(name, value) {
this._entries[name] = [value.toString()];
};
proto.forEach = function(callback, thisArg) {
var entries;
for(var name in this._entries) {
if(this._entries.hasOwnProperty(name)) {
entries = this._entries[name];
for(var i = 0; i < entries.length; i++) {
callback.call(thisArg, entries[i], name, this);
}
}
}
};
proto.keys = function() {
var items = [];
this.forEach(function(value, name) { items.push(name); });
return createIterator(items);
};
proto.values = function() {
var items = [];
this.forEach(function(value) { items.push(value); });
return createIterator(items);
};
proto.entries = function() {
var items = [];
this.forEach(function(value, name) { items.push([name, value]); });
return createIterator(items);
};
if(iteratorSupported) {
proto[Symbol.iterator] = proto.entries;
}
proto.toString = function() {
var searchString = '';
this.forEach(function(value, name) {
if(searchString.length > 0) searchString+= '&';
searchString += serializeParam(name) + '=' + serializeParam(value);
});
return searchString;
};
global.URLSearchParams = URLSearchParams;
};
if(!('URLSearchParams' in global) || (new URLSearchParams('?a=1').toString() !== 'a=1')) {
polyfillURLSearchParams();
}
// HTMLAnchorElement
})(
(typeof global !== 'undefined') ? global
: ((typeof window !== 'undefined') ? window
: ((typeof self !== 'undefined') ? self : this))
);
(function(global) {
/**
* Polyfill URL
*
* Inspired from : https://github.com/arv/DOM-URL-Polyfill/blob/master/src/url.js
*/
var checkIfURLIsSupported = function() {
try {
var u = new URL('b', 'http://a');
u.pathname = 'c%20d';
return (u.href === 'http://a/c%20d') && u.searchParams;
} catch(e) {
return false;
}
};
var polyfillURL = function() {
var _URL = global.URL;
var URL = function(url, base) {
if(typeof url !== 'string') url = String(url);
var doc = document.implementation.createHTMLDocument('');
window.doc = doc;
if(base) {
var baseElement = doc.createElement('base');
baseElement.href = base;
doc.head.appendChild(baseElement);
}
var anchorElement = doc.createElement('a');
anchorElement.href = url;
doc.body.appendChild(anchorElement);
anchorElement.href = anchorElement.href; // force href to refresh
if(anchorElement.protocol === ':' || !/:/.test(anchorElement.href)) {
throw new TypeError('Invalid URL');
}
Object.defineProperty(this, '_anchorElement', {
value: anchorElement
});
};
var proto = URL.prototype;
var linkURLWithAnchorAttribute = function(attributeName) {
Object.defineProperty(proto, attributeName, {
get: function() {
return this._anchorElement[attributeName];
},
set: function(value) {
this._anchorElement[attributeName] = value;
},
enumerable: true
});
};
['hash', 'host', 'hostname', 'port', 'protocol', 'search']
.forEach(function(attributeName) {
linkURLWithAnchorAttribute(attributeName);
});
Object.defineProperties(proto, {
'toString': {
get: function() {
var _this = this;
return function() {
return _this.href;
};
}
},
'href' : {
get: function() {
return this._anchorElement.href.replace(/\?$/,'');
},
set: function(value) {
this._anchorElement.href = value;
},
enumerable: true
},
'pathname' : {
get: function() {
return this._anchorElement.pathname.replace(/(^\/?)/,'/');
},
set: function(value) {
this._anchorElement.pathname = value;
},
enumerable: true
},
'origin': {
get: function() {
// get expected port from protocol
var expectedPort = {'http:': 80, 'https:': 443, 'ftp:': 21}[this._anchorElement.protocol];
// add port to origin if, expected port is different than actual port
// and it is not empty f.e http://foo:8080
// 8080 != 80 && 8080 != ''
var addPortToOrigin = this._anchorElement.port != expectedPort &&
this._anchorElement.port !== ''
return this._anchorElement.protocol +
'//' +
this._anchorElement.hostname +
(addPortToOrigin ? (':' + this._anchorElement.port) : '');
},
enumerable: true
},
'password': { // TODO
get: function() {
return '';
},
set: function(value) {
},
enumerable: true
},
'username': { // TODO
get: function() {
return '';
},
set: function(value) {
},
enumerable: true
},
'searchParams': {
get: function() {
var searchParams = new URLSearchParams(this.search);
var _this = this;
['append', 'delete', 'set'].forEach(function(methodName) {
var method = searchParams[methodName];
searchParams[methodName] = function() {
method.apply(searchParams, arguments);
_this.search = searchParams.toString();
};
});
return searchParams;
},
enumerable: true
}
});
URL.createObjectURL = function(blob) {
return _URL.createObjectURL.apply(_URL, arguments);
};
URL.revokeObjectURL = function(url) {
return _URL.revokeObjectURL.apply(_URL, arguments);
};
global.URL = URL;
};
if(!checkIfURLIsSupported()) {
polyfillURL();
}
if((global.location !== void 0) && !('origin' in global.location)) {
var getOrigin = function() {
return global.location.protocol + '//' + global.location.hostname + (global.location.port ? (':' + global.location.port) : '');
};
try {
Object.defineProperty(global.location, 'origin', {
get: getOrigin,
enumerable: true
});
} catch(e) {
setInterval(function() {
global.location.origin = getOrigin();
}, 100);
}
}
})(
(typeof global !== 'undefined') ? global
: ((typeof window !== 'undefined') ? window
: ((typeof self !== 'undefined') ? self : this))
);

3
frontend/src/app.js
View File

@ -4,6 +4,9 @@ import { I18n } from './services/i18n/i18n';
import { UtilRegistry } from './services/util-registry/util-registry'; import { UtilRegistry } from './services/util-registry/util-registry';
import { isValidUtility } from './core/utility'; import { isValidUtility } from './core/utility';
// load window.fetch polyfill
import 'whatwg-fetch';
export class App { export class App {
httpClient = new HttpClient(); httpClient = new HttpClient();
htmlHelpers = new HtmlHelpers(); htmlHelpers = new HtmlHelpers();

2
frontend/src/services/html-helpers/html-helpers.js
View File

@ -24,7 +24,7 @@ export class HtmlHelpers {
} }
_prefixIds(element, idPrefix) { _prefixIds(element, idPrefix) {
const idAttrs = ['id', 'for', 'data-conditional-input', 'data-modal-trigger']; const idAttrs = ['id', 'for', 'list', 'data-conditional-input', 'data-modal-trigger'];
idAttrs.forEach((attr) => { idAttrs.forEach((attr) => {
Array.from(element.querySelectorAll('[' + attr + ']')).forEach((input) => { Array.from(element.querySelectorAll('[' + attr + ']')).forEach((input) => {

2
frontend/src/services/util-registry/util-registry.js
View File

@ -1,4 +1,4 @@
const DEBUG_MODE = /localhost/.test(window.location.href) && 0; const DEBUG_MODE = /localhost/.test(window.location.href) ? 2 : 0;
export class UtilRegistry { export class UtilRegistry {

5
frontend/src/utils/async-form/async-form.js
View File

@ -1,4 +1,5 @@
import { Utility } from '../../core/utility'; import { Utility } from '../../core/utility';
import { Datepicker } from '../form/datepicker';
import './async-form.scss'; import './async-form.scss';
const ASYNC_FORM_INITIALIZED_CLASS = 'check-all--initialized'; const ASYNC_FORM_INITIALIZED_CLASS = 'check-all--initialized';
@ -70,7 +71,9 @@ export class AsyncForm {
const url = this._element.getAttribute('action'); const url = this._element.getAttribute('action');
const headers = { }; const headers = { };
const body = new FormData(this._element);
// create new FormData and format any date values
const body = Datepicker.unformatAll(this._element, new FormData(this._element));
const isModal = this._element.closest(MODAL_SELECTOR); const isModal = this._element.closest(MODAL_SELECTOR);
if (isModal) { if (isModal) {

9
frontend/src/utils/async-table/async-table.js
View File

@ -1,4 +1,5 @@
import { Utility } from '../../core/utility'; import { Utility } from '../../core/utility';
import { Datepicker } from '../form/datepicker';
import { HttpClient } from '../../services/http-client/http-client'; import { HttpClient } from '../../services/http-client/http-client';
import * as debounce from 'lodash.debounce'; import * as debounce from 'lodash.debounce';
import './async-table-filter.scss'; import './async-table-filter.scss';
@ -238,6 +239,10 @@ export class AsyncTable {
_serializeTableFilterToURL(tableFilterForm) { _serializeTableFilterToURL(tableFilterForm) {
const url = new URL(getLocalStorageParameter('currentTableUrl') || window.location.href); const url = new URL(getLocalStorageParameter('currentTableUrl') || window.location.href);
// format any date values before submission
Datepicker.destroyAllFormInputDates(tableFilterForm);
const formData = new FormData(tableFilterForm); const formData = new FormData(tableFilterForm);
for (var k of url.searchParams.keys()) { for (var k of url.searchParams.keys()) {
@ -298,7 +303,9 @@ export class AsyncTable {
_changePagesizeHandler = () => { _changePagesizeHandler = () => {
const url = new URL(getLocalStorageParameter('currentTableUrl') || window.location.href); const url = new URL(getLocalStorageParameter('currentTableUrl') || window.location.href);
const formData = new FormData(this._pagesizeForm);
// create new FormData and format any date values
const formData = Datepicker.unformatAll(this._pagesizeForm, new FormData(this._pagesizeForm));
for (var k of url.searchParams.keys()) { for (var k of url.searchParams.keys()) {
url.searchParams.delete(k); url.searchParams.delete(k);

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

@ -1,30 +1,90 @@
import flatpickr from 'flatpickr'; import datetime from 'tail.datetime';
import { Utility } from '../../core/utility'; import { Utility } from '../../core/utility';
import moment from 'moment';
const KEYCODE_ESCAPE = 27;
// INTERNAL (Uni2work specific) formats for formatting dates and/or times
const FORM_DATE_FORMAT = {
'date': moment.HTML5_FMT.DATE,
'time': moment.HTML5_FMT.TIME_SECONDS,
'datetime-local': moment.HTML5_FMT.DATETIME_LOCAL_SECONDS,
};
// FANCY (tail.datetime specific) formats for displaying dates and/or times
const FORM_DATE_FORMAT_DATE_DT = 'dd.mm.YYYY';
const FORM_DATE_FORMAT_TIME_DT = 'HH:ii:ss';
// FANCY (moment specific) formats for displaying dates and/or times
const FORM_DATE_FORMAT_DATE_MOMENT = 'DD.MM.YYYY';
const FORM_DATE_FORMAT_TIME_MOMENT = 'HH:mm:ss';
const FORM_DATE_FORMAT_MOMENT = {
'date': FORM_DATE_FORMAT_DATE_MOMENT,
'time': FORM_DATE_FORMAT_TIME_MOMENT,
'datetime-local': `${FORM_DATE_FORMAT_DATE_MOMENT} ${FORM_DATE_FORMAT_TIME_MOMENT}`,
};
/**
* Takes a string representation of a date and a format string and parses the given date to a Date object.
* If the date string is not valid (i.e. cannot be parsed with the given format string), returns undefined.
* @param {*} dateStr string representation of a date
* @param {*} dateFormat format string of the date
*/
function parseDateWithFormat(dateStr, dateFormat) {
const parsedMomentDate = moment(dateStr, dateFormat);
if (parsedMomentDate.isValid()) return parsedMomentDate.toDate();
}
/**
* Takes a string representation of a date, an input ('previous') format and a desired output format and returns a reformatted date string.
* If the date string is not valid (i.e. cannot be parsed with the given input format string), returns the original date string;
* @param {*} dateStr string representation of a date (needs to be in format formatIn)
* @param {*} formatIn input format string
* @param {*} formatOut format string of the desired output date string
*/
function reformatDateString(dateStr, formatIn, formatOut) {
const parsedMomentDate = moment(dateStr, formatIn);
return parsedMomentDate.isValid() ? parsedMomentDate.format(formatOut) : dateStr;
}
const DATEPICKER_UTIL_SELECTOR = 'input[type="date"], input[type="time"], input[type="datetime-local"]'; const DATEPICKER_UTIL_SELECTOR = 'input[type="date"], input[type="time"], input[type="datetime-local"]';
const DATEPICKER_INITIALIZED_CLASS = 'datepicker--initialized'; const DATEPICKER_INITIALIZED_CLASS = 'datepicker--initialized';
const DATEPICKER_CONFIG = { const DATEPICKER_CONFIG = {
'datetime-local': { 'global': {
enableTime: true, // minimize overlaps with other date inputs
altInput: true, position: 'right',
altFormat: 'j. F Y, H:i', // maybe interpolate these formats for locale
dateFormat: 'Y-m-dTH:i', // set default time to 00:00:00
time_24hr: true, timeHours: 0,
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,
// prevent the instance from closing when selecting a date before selecting a time
stayOpen: true,
// hide the close button (we handle closing the datepicker manually by clicking outside)
closeButton: false,
// disable the decades view because nobody will ever need it (i.e. cap the switch to the more relevant year view)
viewDecades: false,
}, },
'datetime-local': {},
'date': { 'date': {
altFormat: 'j. F Y', // disable date picker
dateFormat: 'Y-m-d', timeFormat: false,
altInput: true,
}, },
'time': { 'time': {
enableTime: true, // disable time picker
noCalendar: true, dateFormat: false,
altFormat: 'H:i',
dateFormat: 'H:i',
altInput: true,
time_24hr: true,
}, },
}; };
@ -33,7 +93,12 @@ const DATEPICKER_CONFIG = {
}) })
export class Datepicker { export class Datepicker {
flatpickrInstance; // singleton Map that maps a formID to a Map of Datepicker objects
static datepickerCollections;
datepickerInstance;
_element;
elementType;
constructor(element) { constructor(element) {
if (!element) { if (!element) {
@ -44,19 +109,140 @@ export class Datepicker {
return false; return false;
} }
const flatpickrConfig = DATEPICKER_CONFIG[element.getAttribute('type')]; // initialize datepickerCollections singleton if not already done
if (!Datepicker.datepickerCollections) {
Datepicker.datepickerCollections = new Map();
}
if (!flatpickrConfig) { this._element = element;
// store the previously set type to select the input format
this.elementType = this._element.getAttribute('type');
// get all relevant config options for this datepicker type
const datepickerGlobalConfig = DATEPICKER_CONFIG['global'];
const datepickerConfig = DATEPICKER_CONFIG[this.elementType];
// manually set the type attribute to text because datepicker handles displaying the date
this._element.setAttribute('type', 'text');
// additional position config (optional data-datepicker-position attribute in html) that can specialize the global config
const datepickerPosition = this._element.dataset.datepickerPosition;
if (datepickerPosition) {
datepickerGlobalConfig.position = datepickerPosition;
}
if (!datepickerConfig || !FORM_DATE_FORMAT[this.elementType]) {
throw new Error('Datepicker utility called on unsupported element!'); throw new Error('Datepicker utility called on unsupported element!');
} }
this.flatpickrInstance = flatpickr(element, flatpickrConfig); // initialize tail.datetime (datepicker) instance
this.datepickerInstance = datetime(this._element, { ...datepickerGlobalConfig, ...datepickerConfig });
// mark initialized // register this datepicker instance with the formID of the given element in the datepicker collection
element.classList.add(DATEPICKER_INITIALIZED_CLASS); const formID = this._element.form.id;
const elemID = this._element.id;
if (!Datepicker.datepickerCollections.has(formID)) {
// insert a new key value pair if the formID key is not there already
Datepicker.datepickerCollections.set(formID, new Map([[elemID, this]]));
} else {
// otherwise, insert this instance into the Map
Datepicker.datepickerCollections.get(formID).set(elemID, this);
}
// mark the form input element as initialized
this._element.classList.add(DATEPICKER_INITIALIZED_CLASS);
const setDatepickerDate = () => {
// try to parse the current input element value with fancy and internal format string
const parsedMomentDate = moment(this._element.value, FORM_DATE_FORMAT_MOMENT[this.elementType]);
const parsedMomentDateInternal = moment(this._element.value, FORM_DATE_FORMAT[this.elementType]);
// only set the datepicker date if the input is either in valid fancy format or in valid internal format
if (parsedMomentDate.isValid()) {
this.datepickerInstance.selectDate(parsedMomentDate.toDate());
} else if (parsedMomentDateInternal.isValid()) {
this.datepickerInstance.selectDate(parsedMomentDateInternal.toDate());
}
// reregister change event to prevent event loop
this._element.addEventListener('change', setDatepickerDate, { once: true });
};
// 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)) {
this.datepickerInstance.close();
}
});
// close the datepicker on escape keydown events
this._element.addEventListener('keydown', event => {
if (event.keyCode === KEYCODE_ESCAPE) {
this.datepickerInstance.close();
}
});
// format the date value of the form input element of this datepicker before form submission
this._element.form.addEventListener('submit', () => this.formatElementValue());
// format any existing dates to fancy display format on pageload
this.formatElementValue(true);
} }
destroy() { destroy() {
this.flatpickrInstance.destroy(); this.datepickerInstance.remove();
}
/**
* Formats the value of this input element from datepicker format (i.e. DATEPICKER_CONFIG.dateFormat + " " + datetime.defaults.timeFormat) to Uni2work internal date format (i.e. FORM_DATE_FORMAT) required for form submission
* @param {*} toFancy optional target format switch (boolean value; default is false). If set to a truthy value, formats the element value to fancy instead of internal date format.
*/
formatElementValue(toFancy) {
const dp = this.datepickerInstance;
if (this._element.value) {
if (toFancy) {
const parsedDate = parseDateWithFormat(this._element.value, FORM_DATE_FORMAT[this.elementType]);
if (parsedDate) dp.selectDate();
} else {
this._element.value = this.unformat();
}
}
}
/**
* Returns a datestring in internal format from the current state of the input element value.
*/
unformat() {
return reformatDateString(this._element.value, FORM_DATE_FORMAT_MOMENT[this.elementType], FORM_DATE_FORMAT[this.elementType]);
}
/**
* Takes a Form and a FormData and returns a new FormData with all dates formatted to uni2work date format. This function will not change the value of the date input elements.
* @param {*} form Form for which all dates will be formatted in the FormData
* @param {*} formData Initial FormData
*/
static unformatAll(form, formData) {
// only proceed if there are any datepickers and if both form and formData are defined
if (Datepicker.datepickerCollections && form && formData) {
// if the form has no id, assign one randomly
if (!form.id) {
form.id = `f${Math.floor(Math.random() * 100000)}`;
}
const formId = form.id;
if (Datepicker.datepickerCollections.has(formId)) {
const datepickerInstances = Datepicker.datepickerCollections.get(formId);
datepickerInstances.forEach(instance => {
formData.set(instance._element.name, instance.unformat());
});
}
}
// return the (possibly changed) FormData
return formData;
} }
} }

6
frontend/src/utils/form/datepicker.md
View File

@ -6,3 +6,9 @@ Provides UI for entering dates and times
## Example usage: ## Example usage:
(any form that uses inputs of type date, time, or datetime-local) (any form that uses inputs of type date, time, or datetime-local)
## Methods
### static unformatAll(form, formData)
Call this function on a form and its formData to get back a new FormData object with "unformatted" date values (i.e. all dates formatted from fancy format to backend format).

17
frontend/src/utils/form/interactive-fieldset.js
View File

@ -16,6 +16,7 @@ export class InteractiveFieldset {
conditionalValue; conditionalValue;
target; target;
childInputs; childInputs;
negated;
constructor(element) { constructor(element) {
if (!element) { if (!element) {
@ -43,11 +44,13 @@ export class InteractiveFieldset {
} }
// param conditionalValue // param conditionalValue
if (!this._element.dataset.conditionalValue && !this._isCheckbox()) { if (!('conditionalValue' in this._element.dataset) && !this._isCheckbox()) {
throw new Error('Interactive Fieldset needs a conditional value!'); throw new Error('Interactive Fieldset needs a conditional value!');
} }
this.conditionalValue = this._element.dataset.conditionalValue; this.conditionalValue = this._element.dataset.conditionalValue;
this.negated = 'conditionalNegated' in this._element.dataset;
this.target = this._element.closest(INTERACTIVE_FIELDSET_UTIL_TARGET_SELECTOR); this.target = this._element.closest(INTERACTIVE_FIELDSET_UTIL_TARGET_SELECTOR);
if (!this.target || this._element.matches(INTERACTIVE_FIELDSET_UTIL_TARGET_SELECTOR)) { if (!this.target || this._element.matches(INTERACTIVE_FIELDSET_UTIL_TARGET_SELECTOR)) {
this.target = this._element; this.target = this._element;
@ -88,11 +91,19 @@ export class InteractiveFieldset {
} }
_matchesConditionalValue() { _matchesConditionalValue() {
var matches;
if (this._isCheckbox()) { if (this._isCheckbox()) {
return this.conditionalInput.checked === true; matches = this.conditionalInput.checked === true;
} else {
matches = this.conditionalInput.value === this.conditionalValue;
} }
return this.conditionalInput.value === this.conditionalValue; if (this.negated) {
return !matches;
} else {
return matches;
}
} }
_isCheckbox() { _isCheckbox() {

2
frontend/src/utils/form/interactive-fieldset.md
View File

@ -8,6 +8,8 @@ Shows/hides inputs based on value of particular input
Selector for the input that this fieldset watches for changes Selector for the input that this fieldset watches for changes
- `data-conditional-value: string`\ - `data-conditional-value: string`\
The value the conditional input needs to be set to for this fieldset to be shown. Can be omitted if conditionalInput is a checkbox The value the conditional input needs to be set to for this fieldset to be shown. Can be omitted if conditionalInput is a checkbox
- `data-conditional-negated`\
If present, negates the match on `data-conditional-value`
## Example usage: ## Example usage:
### example with text input ### example with text input

32
frontend/src/utils/form/navigate-away-prompt.js
View File

@ -2,6 +2,16 @@ import { Utility } from '../../core/utility';
import { AUTO_SUBMIT_BUTTON_UTIL_SELECTOR } from './auto-submit-button'; import { AUTO_SUBMIT_BUTTON_UTIL_SELECTOR } from './auto-submit-button';
import { AUTO_SUBMIT_INPUT_UTIL_SELECTOR } from './auto-submit-input'; import { AUTO_SUBMIT_INPUT_UTIL_SELECTOR } from './auto-submit-input';
/**
* Key generator from an arbitrary number of FormData objects.
* @param {...any} formDatas FormData objects
*/
function* generatorFromFormDatas(...formDatas) {
for (let formData of formDatas) {
yield* formData.keys();
}
}
const NAVIGATE_AWAY_PROMPT_INITIALIZED_CLASS = 'navigate-away-prompt--initialized'; const NAVIGATE_AWAY_PROMPT_INITIALIZED_CLASS = 'navigate-away-prompt--initialized';
const NAVIGATE_AWAY_PROMPT_UTIL_OPTOUT = '[uw-no-navigate-away-prompt]'; const NAVIGATE_AWAY_PROMPT_UTIL_OPTOUT = '[uw-no-navigate-away-prompt]';
@ -12,7 +22,7 @@ export class NavigateAwayPrompt {
_element; _element;
_touched = false; _initFormData;
_unloadDueToSubmit = false; _unloadDueToSubmit = false;
constructor(element) { constructor(element) {
@ -21,6 +31,7 @@ export class NavigateAwayPrompt {
} }
this._element = element; this._element = element;
this._initFormData = new FormData(this._element);
if (this._element.classList.contains(NAVIGATE_AWAY_PROMPT_INITIALIZED_CLASS)) { if (this._element.classList.contains(NAVIGATE_AWAY_PROMPT_INITIALIZED_CLASS)) {
return false; return false;
@ -40,10 +51,6 @@ export class NavigateAwayPrompt {
this._element.addEventListener('submit', () => { this._element.addEventListener('submit', () => {
this._unloadDueToSubmit = true; this._unloadDueToSubmit = true;
}); });
this._element.addEventListener('change', () => {
this._touched = true;
this._unloadDueToSubmit = false;
});
// mark initialized // mark initialized
this._element.classList.add(NAVIGATE_AWAY_PROMPT_INITIALIZED_CLASS); this._element.classList.add(NAVIGATE_AWAY_PROMPT_INITIALIZED_CLASS);
@ -55,9 +62,20 @@ export class NavigateAwayPrompt {
} }
_beforeUnloadHandler = (event) => { _beforeUnloadHandler = (event) => {
// compare every value of the current FormData with every corresponding value of the initial FormData and set formDataHasChanged to true if there is at least one change
const currentFormData = new FormData(this._element);
var formDataHasChanged = false;
for (let key of generatorFromFormDatas(this._initFormData, currentFormData)) {
if (currentFormData.get(key) !== this._initFormData.get(key)) {
formDataHasChanged = true;
break;
}
}
// allow the event to happen if the form was not touched by the // allow the event to happen if the form was not touched by the
// user or the unload event was initiated by a form submit // user (i.e. if the current FormData is equal to the initial FormData)
if (!this._touched || this._unloadDueToSubmit) { // or the unload event was initiated by a form submit
if (!formDataHasChanged || this._unloadDueToSubmit) {
return false; return false;
} }

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

@ -1,6 +1,15 @@
/* GENERAL STYLES FOR FORMS */ /* GENERAL STYLES FOR FORMS */
/* FORM GROUPS */ /* FORM GROUPS */
.form-section-title {
color: var(--color-fontsec);
margin: 0;
+ .form-group {
margin-top: 11px;
}
}
.form-group { .form-group {
position: relative; position: relative;
display: flex; display: flex;
@ -9,11 +18,9 @@
grid-gap: 5px; grid-gap: 5px;
justify-content: flex-start; justify-content: flex-start;
align-items: flex-start; align-items: flex-start;
padding: 4px 0;
border-left: 2px solid transparent;
+ .form-group { + .form-group, + .form-section-legend, + .form-section-notification {
margin-top: 7px; margin-top: 11px;
} }
+ .form-section-title { + .form-section-title {
@ -21,15 +28,22 @@
} }
} }
.form-section-title {
color: var(--color-fontsec);
}
.form-section-legend { .form-section-legend {
color: var(--color-fontsec); color: var(--color-fontsec);
margin: 7px 0; margin: 7px 0;
} }
.form-section-title__hint {
margin-top: 7px;
color: var(--color-fontsec);
font-size: 0.9rem;
font-weight: 600;
+ .form-group {
margin-top: 11px;
}
}
.form-group-label { .form-group-label {
font-weight: 600; font-weight: 600;
padding-top: 6px; padding-top: 6px;

5
frontend/src/utils/mass-input/mass-input.js
View File

@ -1,4 +1,6 @@
import { Utility } from '../../core/utility'; import { Utility } from '../../core/utility';
import { Datepicker } from '../form/datepicker';
import './mass-input.scss';
const MASS_INPUT_CELL_SELECTOR = '.massinput__cell'; const MASS_INPUT_CELL_SELECTOR = '.massinput__cell';
const MASS_INPUT_ADD_CELL_SELECTOR = '.massinput__cell--add'; const MASS_INPUT_ADD_CELL_SELECTOR = '.massinput__cell--add';
@ -157,7 +159,8 @@ export class MassInput {
} }
_serializeForm(submitButton, enctype) { _serializeForm(submitButton, enctype) {
const formData = new FormData(this._massInputForm); // create new FormData and format any date values
const formData = Datepicker.unformatAll(this._massInputForm, new FormData(this._massInputForm));
// manually add name and value of submit button to formData // manually add name and value of submit button to formData
formData.append(submitButton.name, submitButton.value); formData.append(submitButton.name, submitButton.value);

18
frontend/src/utils/mass-input/mass-input.scss Normal file
View File

@ -0,0 +1,18 @@
.massinput-list__wrapper, .massinput-list__cell {
display: grid;
grid: auto / auto 50px;
max-width: 600px;
grid-gap: 7px;
}
.massinput-list__field {
grid-column: 1;
}
.massinput-list__add, .massinput-list__delete {
grid-column: 2;
}
.massinput-list__cell {
grid-column: 1 / 3;
}

727
frontend/vendor/datetime.css vendored Normal file
View File

@ -0,0 +1,727 @@
@charset "UTF-8";
/*
| tail.datetime - The vanilla way to select dates and times!
| @file ./less/tail.datetime-default-green.less
| @author SamBrishes <sam@pytes.net>
| @version 0.4.13 - Beta
|
| @website https://github.com/pytesNET/tail.DateTime
| @license X11 / MIT License
| @copyright Copyright © 2018 - 2019 SamBrishes, pytesNET <info@pytes.net>
*/
/* @start MAIN CALENDAR */
.tail-datetime-calendar, .tail-datetime-calendar *, .tail-datetime-calendar *:before,
.tail-datetime-calendar *:after{
box-sizing: border-box;
-webkit-box-sizing: border-box;
}
.tail-datetime-calendar{
top: 0;
left: 0;
width: 275px;
height: auto;
margin: 15px;
padding: 0;
z-index: 15;
display: block;
position: absolute;
visibility: hidden;
direction: ltr;
border-collapse: separate;
font-family: "Open Sans", Calibri, Arial, sans-serif;
background-color: white;
border-width: 0;
border-style: solid;
border-color: transparent;
border-radius: 3px;
box-shadow: 0 1px 3px rgba(0, 0, 0, 0.3125);
-webkit-box-shadow: 0 1px 3px rgba(0, 0, 0, 0.3125);
}
.tail-datetime-calendar:after{
clear: both;
content: "";
display: block;
font-size: 0;
visibility: hidden;
}
.tail-datetime-calendar.calendar-static{
top: auto;
left: auto;
margin-left: auto;
margin-right: auto;
position: static;
visibility: visible;
}
.tail-datetime-calendar button.calendar-close{
top: 100%;
right: 15px;
color: #303438;
width: 35px;
height: 25px;
margin: 1px 0 0 0;
padding: 5px 10px;
opacity: 0.5;
outline: none;
display: inline-block;
position: absolute;
font-size: 14px;
line-height: 1.125em;
text-shadow: none;
background-color: white;
background-image: url("data:image/svg+xml;base64,PHN2ZyB4bWxucz0iaHR0cDovL3d3dy53My5vcmcvMjAwMC\
9zdmciIHdpZHRoPSIxMiIgaGVpZ2h0PSIxNiIgdmlld0JveD0iMCAwIDEyIDE2Ij48cGF0aCBmaWxsPSIjMzAzNDM4IiBkP\
SJNNy40OCA4bDMuNzUgMy43NS0xLjQ4IDEuNDhMNiA5LjQ4bC0zLjc1IDMuNzUtMS40OC0xLjQ4TDQuNTIgOCAuNzcgNC4y\
NWwxLjQ4LTEuNDhMNiA2LjUybDMuNzUtMy43NSAxLjQ4IDEuNDhMNy40OCA4eiIvPjwvc3ZnPg==");
background-repeat: no-repeat;
background-position: center center;
border-width: 0;
border-style: solid;
border-color: transparent;
border-radius: 0 0 3px 3px;
box-shadow: 0 1px 3px rgba(0, 0, 0, 0.3125);
-webkit-box-shadow: 0 1px 3px rgba(0, 0, 0, 0.3125);
transition: opacity 142ms linear;
-webkit-transition: opacity 142ms linear;
}
.tail-datetime-calendar button.calendar-close:hover{
opacity: 1;
}
/* @end MAIN CALENDAR */
/* @start CALENDAR TOOLTIP */
.tail-datetime-calendar .calendar-tooltip{
color: white;
width: auto;
margin: 0;
padding: 0;
display: block;
position: absolute;
background-color: #202428;
border-radius: 3px;
}
.tail-datetime-calendar .calendar-tooltip:before{
top: -7px;
left: 50%;
width: 0;
height: 0;
margin: 0 0 0 -6px;
content: "";
display: block;
position: absolute;
border-width: 0 7px 7px 7px;
border-style: solid;
border-color: transparent transparent #202428 transparent;
}
.tail-datetime-calendar .calendar-tooltip .tooltip-inner{
width: auto;
margin: 0;
padding: 4px 7px;
display: block;
font-size: 12px;
line-height: 14px;
}
/* @end CALENDAR TOOLTIP */
/* @start CALENDAR ACTIONs */
.tail-datetime-calendar .calendar-actions{
color: white;
width: 100%;
height: 36px;
margin: 0;
padding: 0;
display: table;
overflow: hidden;
border-spacing: 0;
border-collapse: separate;
background-color: var(--color-primary);
border-width: 0;
border-style: solid;
border-color: transparent;
border-radius: 3px 3px 0 0;
}
.tail-datetime-calendar .calendar-actions span{
margin: 0;
padding: 0;
display: table-cell;
position: relative;
text-align: center;
line-height: 36px;
text-shadow: -1px -1px 0 var(--color-dark);
background-repeat: no-repeat;
background-position: center center;
}
.tail-datetime-calendar .calendar-actions span[data-action]{
cursor: pointer;
}
.tail-datetime-calendar .calendar-actions span.action{
width: 36px;
font-size: 22px;
}
.tail-datetime-calendar .calendar-actions span.label{
width: auto;
}
.tail-datetime-calendar .calendar-actions span:first-child:before{
right: -1px;
}
.tail-datetime-calendar .calendar-actions span:last-child:before{
left: -1px;
}
.tail-datetime-calendar .calendar-actions span:first-child:hover:before,
.tail-datetime-calendar .calendar-actions span:last-child:hover:before{
display: none;
}
.tail-datetime-calendar .calendar-actions span[data-action]:hover{
background-color: var(--color-dark);
}
.tail-datetime-calendar .calendar-actions span.action-prev{
background-image: url("data:image/svg+xml;base64,PHN2ZyB4bWxucz0iaHR0cDovL3d3dy53My5vcmcvMjAwMC\
9zdmciIHdpZHRoPSI2IiBoZWlnaHQ9IjE2IiB2aWV3Qm94PSIwIDAgNiAxNiI+PHBhdGggZmlsbD0iI2ZmZmZmZiIgZD0iT\
TYgMkwwIDhsNiA2VjJ6Ii8+PC9zdmc+");
}
.tail-datetime-calendar .calendar-actions span.action-next{
background-image: url("data:image/svg+xml;base64,PHN2ZyB4bWxucz0iaHR0cDovL3d3dy53My5vcmcvMjAwMC\
9zdmciIHdpZHRoPSI2IiBoZWlnaHQ9IjE2IiB2aWV3Qm94PSIwIDAgNiAxNiI+PHBhdGggZmlsbD0iI2ZmZmZmZiIgZD0iT\
TAgMTRsNi02LTYtNnYxMnoiLz48L3N2Zz4=");
}
.tail-datetime-calendar .calendar-actions span.action-submit{
background-image: url("data:image/svg+xml;base64,PHN2ZyB4bWxucz0iaHR0cDovL3d3dy53My5vcmcvMjAwMC\
9zdmciIHdpZHRoPSIxMiIgaGVpZ2h0PSIxNiIgdmlld0JveD0iMCAwIDEyIDE2Ij48cGF0aCBmaWxsPSIjZmZmZmZmIiBkP\
SJNMTIgNWwtOCA4LTQtNCAxLjUtMS41TDQgMTBsNi41LTYuNUwxMiA1eiIvPjwvc3ZnPg==");
}
.tail-datetime-calendar .calendar-actions span.action-cancel{
background-image: url("data:image/svg+xml;base64,PHN2ZyB4bWxucz0iaHR0cDovL3d3dy53My5vcmcvMjAwMC\
9zdmciIHdpZHRoPSIxMiIgaGVpZ2h0PSIxNiIgdmlld0JveD0iMCAwIDEyIDE2Ij48cGF0aCBmaWxsPSIjZmZmZmZmIiBkP\
SJNNy40OCA4bDMuNzUgMy43NS0xLjQ4IDEuNDhMNiA5LjQ4bC0zLjc1IDMuNzUtMS40OC0xLjQ4TDQuNTIgOCAuNzcgNC4y\
NWwxLjQ4LTEuNDhMNiA2LjUybDMuNzUtMy43NSAxLjQ4IDEuNDhMNy40OCA4eiIvPjwvc3ZnPg==");
}
/* @end CALENDAR ACTIONs */
/* @start CALENDAR DATEPICKER */
.tail-datetime-calendar .calendar-datepicker{
width: 100%;
margin: 0;
padding: 0;
display: block;
position: relative;
}
.tail-datetime-calendar .calendar-datepicker table{
width: 100%;
margin: 0;
padding: 0;
border-spacing: 0;
border-collapse: separate;
}
.tail-datetime-calendar .calendar-datepicker table tr th,
.tail-datetime-calendar .calendar-datepicker table tr td{
color: #303438;
height: 30px;
padding: 0;
position: relative;
font-size: 13px;
text-align: center;
font-weight: normal;
text-shadow: none;
line-height: 30px;
background-color: transparent;
border-width: 0;
border-style: solid;
border-color: transparent;
border-radius: 0px;
}
.tail-datetime-calendar .calendar-datepicker table tr th{
color: white;
background-color: var(--color-lightblack);
}
.tail-datetime-calendar .calendar-datepicker table tr td{
cursor: pointer;
}
.tail-datetime-calendar .calendar-datepicker table tr td span.inner{
margin: 0;
padding: 0;
display: inline-block;
}
.tail-datetime-calendar .calendar-datepicker table tr td.date-disabled{
cursor: not-allowed;
color: #909498;
background-color: #F0F0F0;
}
.tail-datetime-calendar .calendar-datepicker table tr td.date-disabled:after{
left: 3px;
bottom: 3px;
width: 35px;
height: 1px;
margin: 0;
padding: 0;
content: "";
display: inline-block;
position: absolute;
background-color: #bfbfbf;
transform-origin: 2px -5px;
transform: rotate(-45deg);
-moz-transform: rotate(-45deg);
-webkit-transform: rotate(-45deg);
}
.tail-datetime-calendar .calendar-datepicker table tr td.date-previous,
.tail-datetime-calendar .calendar-datepicker table tr td.date-next{
color: #909498;
background-color: #F0F0F0;
}
.tail-datetime-calendar .calendar-datepicker table tr td.date-today:before,
.tail-datetime-calendar .calendar-datepicker table tr td .tooltip-tick{
top: 5px;
width: 5px;
height: 5px;
margin: 0;
padding: 0;
z-index: 20;
content: "";
display: inline-block;
position: absolute;
border-width: 0;
border-style: solid;
border-color: transparent;
border-radius: 50%;
}
.tail-datetime-calendar .calendar-datepicker table tr td.date-today:before{
left: 5px;
background-color: #E67D1E;
}
.tail-datetime-calendar .calendar-datepicker table tr td .tooltip-tick{
right: 5px;
background-color: #202428;
}
.tail-datetime-calendar .calendar-datepicker table tr td .tooltip-tick:before,
.tail-datetime-calendar .calendar-datepicker table tr td .tooltip-tick:after{
display: none;
}
.tail-datetime-calendar .calendar-datepicker table tr th.calendar-week,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-day{
width: 14.28571429%;
height: 35px;
}
.tail-datetime-calendar .calendar-datepicker table tr th.calendar-week span.inner,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-day span.inner{
width: 31px;
height: 31px;
line-height: 29px;
border-width: 1px;
border-style: solid;
border-color: transparent;
border-radius: 50%;
}
.tail-datetime-calendar .calendar-datepicker table tr th.calendar-week:hover span.inner,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-day:hover span.inner{
border-color: #cccccc;
}
.tail-datetime-calendar .calendar-datepicker table tr th.calendar-week.date-disabled span.inner,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-day.date-disabled span.inner,
.tail-datetime-calendar .calendar-datepicker table tr th.calendar-week.date-disabled:hover span.inner,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-day.date-disabled:hover span.inner{
border-color: transparent;
}
.tail-datetime-calendar .calendar-datepicker table tr th.calendar-week.date-select span.inner,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-day.date-select span.inner,
.tail-datetime-calendar .calendar-datepicker table tr th.calendar-week.date-select:hover span.inner,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-day.date-select:hover span.inner{
color: var(--color-fontsec);
border-color: var(--color-fontsec);
}
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-month,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-year,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-decade{
width: 33.33333333%;
height: 40px;
transition: color 142ms linear;
-webkit-transition: color 142ms linear;
}
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-month.date-today:before,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-year.date-today:before,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-decade.date-today:before{
left: 50%;
margin-left: -2.5px;
}
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-month span.inner,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-year span.inner,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-decade span.inner{
width: auto;
height: 31px;
line-height: 29px;
}
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-month span.inner:before,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-year span.inner:before,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-decade span.inner:before,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-month span.inner:after,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-year span.inner:after,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-decade span.inner:after{
width: 20px;
height: 20px;
content: "";
z-index: 15;
display: inline-block;
position: absolute;
border-width: 1px;
border-style: solid;
border-color: transparent;
transition: all 142ms linear;
-webkit-transition: all 142ms linear;
}
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-month span.inner:before,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-year span.inner:before,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-decade span.inner:before{
top: 0;
left: 0;
}
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-month:hover span.inner:before,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-year:hover span.inner:before,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-decade:hover span.inner:before{
top: 6px;
left: 6px;
border-top-color: #cccccc;
border-left-color: #cccccc;
}
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-month span.inner:after,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-year span.inner:after,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-decade span.inner:after{
right: 0;
bottom: 0;
}
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-month:hover span.inner:after,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-year:hover span.inner:after,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-decade:hover span.inner:after{
right: 6px;
bottom: 6px;
border-right-color: #cccccc;
border-bottom-color: #cccccc;
}
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-year,
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-decade{
width: 25%;
}
.tail-datetime-calendar .calendar-datepicker table tr td.calendar-decade span.inner{
height: 54px;
padding: 7px 15px;
text-align: left;
line-height: 20px;
}
/* @end CALENDAR DATEPICKER */
/* @start CALENDAR TIMEPICKER */
.tail-datetime-calendar .calendar-timepicker{
width: 100%;
margin: 0;
padding: 0;
display: block;
text-align: center;
border-width: 1px 0 0 0;
border-style: solid;
border-color: #d9d9d9;
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field{
width: 28%;
margin: 0;
padding: 15px 0 7px 0;
display: inline-block;
position: relative;
text-align: center;
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field:first-of-type{
text-align: right;
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field:last-of-type{
text-align: left;
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field input[type="text"]{
color: #303438;
width: 100%;
height: 29px;
margin: 0;
z-index: 4;
padding: 3px 20px 3px 5px;
outline: 0;
display: inline-block;
position: relative;
font-size: 12px;
text-align: center;
line-height: 23px;
appearance: textfield;
-moz-appearance: textfield;
-webkit-appearance: textfield;
background-color: #F0F0F0;
border-width: 0;
border-style: solid;
border-color: transparent;
border-radius: 3px;
box-shadow: none;
-webkit-box-shadow: none;
transition: color 142ms linear, border 142ms linear, background 142ms linear;
-webkit-transition: color 142ms linear, border 142ms linear, background 142ms linear;
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field input[type="text"]:hover{
color: #303438;
background-color: #E0E0E0;
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field input[type="text"]:focus{
color: #303438;
background-color: #E0E0E0;
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field input[type="text"]:disabled{
cursor: not-allowed;
color: #A0A4A8;
background-color: #F6F6F6;
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field button.picker-step{
min-width: 0px;
width: 20px;
height: 15px;
right: 0;
margin: 0;
padding: 0;
z-index: 15;
display: inline-block;
position: absolute;
background-color: #F0F0F0;
box-shadow: none;
-webkit-box-shadow: none;
transition: border 142ms linear, background 142ms linear;
-webkit-transition: border 142ms linear, background 142ms linear;
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field button.picker-step:before{
top: 4px;
left: 50%;
width: 0;
height: 0;
margin: 0 0 0 -4px;
padding: 0;
content: "";
display: inline-block;
position: absolute;
transition: border 142ms linear;
-webkit-transition: border 142ms linear;
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field button.picker-step.step-up{
top: 15px;
border-width: 0 0 1px 1px;
border-style: solid;
border-color: white;
border-radius: 0 2px 0 0;
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field button.picker-step.step-up:hover{
background-color: #E0E0E0;
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field button.picker-step.step-up:before{
border-width: 0 4px 5px 4px;
border-style: solid;
border-color: transparent transparent #303438 transparent;
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field button.picker-step.step-down{
top: 29px;
border-width: 1px 0 0 1px;
border-style: solid;
border-color: white;
border-radius: 0 0 2px 0;
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field button.picker-step.step-down:hover{
background-color: #E0E0E0;
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field button.picker-step.step-down:before{
border-width: 5px 4px 0 4px;
border-style: solid;
border-color: #303438 transparent transparent transparent;
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field input:focus + button.step-up{
border-color: rgba(255, 255, 255, 0.8);
background-color: var(--color-primary);
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field input:focus + button.step-up:hover{
background-color: var(--color-dark);
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field input:focus + button.step-up:before{
border-bottom-color: white;
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field input:focus + button + button.step-down{
border-color: rgba(255, 255, 255, 0.8);
background-color: var(--color-primary);
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field input:focus + button + button.step-down:hover{
background-color: var(--color-dark);
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field input:focus + button + button.step-down:before{
border-top-color: white;
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field input:disabled + button.step-up{
cursor: not-allowed;
border-color: rgba(255, 255, 255, 0.8);
background-color: #F6F6F6;
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field input:disabled + button.step-up:hover{
background-color: #F6F6F6;
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field input:disabled + button.step-up:before{
border-bottom-color: #A0A4A8;
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field input:disabled + button + button.step-down{
cursor: not-allowed;
border-color: rgba(255, 255, 255, 0.8);
background-color: #F6F6F6;
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field input:disabled + button + button.step-down:hover{
background-color: #F6F6F6;
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field input:disabled + button + button.step-down:before{
border-top-color: #A0A4A8;
}
.tail-datetime-calendar .calendar-timepicker .timepicker-field label{
color: #303438;
margin: 0;
padding: 0;
display: block;
font-size: 12px;
text-align: center;
}
.tail-datetime-calendar .calendar-timepicker label.timepicker-switch{
cursor: pointer;
margin: 15px 0 -5px 0;
display: block;
text-align: center;
vertical-align: top;
}
.tail-datetime-calendar .calendar-timepicker label.timepicker-switch:before,
.tail-datetime-calendar .calendar-timepicker label.timepicker-switch:after{
width: auto;
margin: 0;
padding: 0 5px;
font-size: 12px;
line-height: 16px;
vertical-align: top;
}
.tail-datetime-calendar .calendar-timepicker label.timepicker-switch:before{
content: attr(data-am);
}
.tail-datetime-calendar .calendar-timepicker label.timepicker-switch:after{
content: attr(data-pm);
}
.tail-datetime-calendar .calendar-timepicker label.timepicker-switch input[type="checkbox"]{
display: none;
}
.tail-datetime-calendar .calendar-timepicker label.timepicker-switch input[type="checkbox"] + span{
display: inline-block;
position: relative;
vertical-align: top;
}
.tail-datetime-calendar .calendar-timepicker label.timepicker-switch input[type="checkbox"] + span:before{
width: 50px;
height: 16px;
content: "";
display: inline-block;
vertical-align: top;
border-width: 1px;
border-style: solid;
border-color: var(--color-primary);
border-radius: 14px;
transition: border 284ms linear;
-webkit-transition: border 284ms linear;
}
.tail-datetime-calendar .calendar-timepicker label.timepicker-switch input[type="checkbox"] + span:after{
top: 3px;
left: 4px;
right: 30px;
width: auto;
height: 10px;
margin: 0;
padding: 0;
content: "";
display: inline-block;
position: absolute;
background-color: var(--color-primary);
border-radius: 15px;
vertical-align: top;
transition: left 284ms linear, right 284ms linear 284ms, background 284ms linear;
-webkit-transition: left 284ms linear, right 284ms linear 284ms, background 284ms linear;
}
.tail-datetime-calendar .calendar-timepicker label.timepicker-switch input[type="checkbox"]:checked + span:before{
border-color: #E67D1E;
}
.tail-datetime-calendar .calendar-timepicker label.timepicker-switch input[type="checkbox"]:checked + span:after{
left: 30px;
right: 4px;
background-color: #E67D1E;
transition: right 284ms linear, left 284ms linear 284ms, background 284ms linear;
-webkit-transition: right 284ms linear, left 284ms linear 284ms, background 284ms linear;
}
.tail-datetime-calendar .calendar-actions + .calendar-timepicker{
border-width: 0;
}
/* @end CALENDAR TIMEPICKER */
/* @start RTL */
.tail-datetime-calendar.rtl{
direction: rtl;
}
.tail-datetime-calendar.rtl .calendar-actions span.action-next,
.tail-datetime-calendar.rtl .calendar-actions span.action-prev{
transform: rotate(180deg);
-moz-transform: rotate(180deg);
-webkit-transform: rotate(180deg);
}
.tail-datetime-calendar.rtl .calendar-datepicker table tr td.date-disabled:after{
right: 3px;
transform: rotate(45deg);
-moz-transform: rotate(45deg);
-webkit-transform: rotate(45deg);
}
.tail-datetime-calendar.rtl .calendar-datepicker table tr td.date-today:before{
right: 5px;
}
.tail-datetime-calendar.rtl .calendar-datepicker table tr td .tooltip-tick{
left: 5px;
}
.tail-datetime-calendar.rtl .calendar-datepicker table tr td.calendar-month.date-today:before,
.tail-datetime-calendar.rtl .calendar-datepicker table tr td.calendar-year.date-today:before,
.tail-datetime-calendar.rtl .calendar-datepicker table tr td.calendar-decade.date-today:before{
right: 50%;
margin-right: -2.5px;
}
.tail-datetime-calendar.rtl .calendar-datepicker table tr td.calendar-month:hover span.inner:before,
.tail-datetime-calendar.rtl .calendar-datepicker table tr td.calendar-year:hover span.inner:before,
.tail-datetime-calendar.rtl .calendar-datepicker table tr td.calendar-decade:hover span.inner:before{
right: 6px;
border-right-color: #cccccc;
}
.tail-datetime-calendar.rtl .calendar-datepicker table tr td.calendar-month span.inner:after,
.tail-datetime-calendar.rtl .calendar-datepicker table tr td.calendar-year span.inner:after,
.tail-datetime-calendar.rtl .calendar-datepicker table tr td.calendar-decade span.inner:after{
left: 0;
}
.tail-datetime-calendar.rtl .calendar-datepicker table tr td.calendar-month:hover span.inner:after,
.tail-datetime-calendar.rtl .calendar-datepicker table tr td.calendar-year:hover span.inner:after,
.tail-datetime-calendar.rtl .calendar-datepicker table tr td.calendar-decade:hover span.inner:after{
left: 6px;
border-left-color: #cccccc;
}
.tail-datetime-calendar.rtl .calendar-datepicker table tr td.calendar-decade span.inner{
text-align: right;
}
.tail-datetime-calendar.rtl .calendar-timepicker .timepicker-field:first-child{
text-align: left;
padding-left: 0;
padding-right: 25px;
}
.tail-datetime-calendar.rtl .calendar-timepicker .timepicker-field:last-child{
text-align: right;
padding-left: 25px;
padding-right: 0;
}
.tail-datetime-calendar.rtl .calendar-timepicker .timepicker-field:first-child input[type="text"]{
margin-left: -1px;
margin-right: 0;
border-radius: 0 3px 3px 0;
}
.tail-datetime-calendar.rtl .calendar-timepicker .timepicker-field:last-child input[type="text"]{
margin-left: 0;
margin-right: -1px;
border-radius: 3px 0 0 3px;
}
/* @end RTL */
/*# sourceMappingURL=tail.datetime-default-green.map */

755
frontend/vendor/flatpickr.css vendored
View File

@ -1,755 +0,0 @@
/*
custom code
hides the up/down arrows in time (number) inputs
*/
/* webkit */
.flatpickr-calendar input[type=number]::-webkit-inner-spin-button,
.flatpickr-calendar input[type=number]::-webkit-outer-spin-button {
-webkit-appearance: none;
margin: 0;
}
/* firefox */
.flatpickr-calendar input[type=number] {
-moz-appearance:textfield;
}
/* vendor code */
.flatpickr-calendar {
background: transparent;
opacity: 0;
display: none;
text-align: center;
visibility: hidden;
padding: 0;
-webkit-animation: none;
animation: none;
direction: ltr;
border: 0;
font-size: 14px;
line-height: 24px;
border-radius: 5px;
position: absolute;
width: 307.875px;
-webkit-box-sizing: border-box;
box-sizing: border-box;
-ms-touch-action: manipulation;
touch-action: manipulation;
background: #fff;
-webkit-box-shadow: 1px 0 0 #e6e6e6, -1px 0 0 #e6e6e6, 0 1px 0 #e6e6e6, 0 -1px 0 #e6e6e6, 0 3px 13px rgba(0,0,0,0.08);
box-shadow: 1px 0 0 #e6e6e6, -1px 0 0 #e6e6e6, 0 1px 0 #e6e6e6, 0 -1px 0 #e6e6e6, 0 3px 13px rgba(0,0,0,0.08);
}
.flatpickr-calendar.open,
.flatpickr-calendar.inline {
opacity: 1;
max-height: 640px;
visibility: visible;
}
.flatpickr-calendar.open {
display: inline-block;
z-index: 99999;
}
.flatpickr-calendar.animate.open {
-webkit-animation: fpFadeInDown 300ms cubic-bezier(0.23, 1, 0.32, 1);
animation: fpFadeInDown 300ms cubic-bezier(0.23, 1, 0.32, 1);
}
.flatpickr-calendar.inline {
display: block;
position: relative;
top: 2px;
}
.flatpickr-calendar.static {
position: absolute;
top: calc(100% + 2px);
}
.flatpickr-calendar.static.open {
z-index: 999;
display: block;
}
.flatpickr-calendar.multiMonth .flatpickr-days .dayContainer:nth-child(n+1) .flatpickr-day.inRange:nth-child(7n+7) {
-webkit-box-shadow: none !important;
box-shadow: none !important;
}
.flatpickr-calendar.multiMonth .flatpickr-days .dayContainer:nth-child(n+2) .flatpickr-day.inRange:nth-child(7n+1) {
-webkit-box-shadow: -2px 0 0 #e6e6e6, 5px 0 0 #e6e6e6;
box-shadow: -2px 0 0 #e6e6e6, 5px 0 0 #e6e6e6;
}
.flatpickr-calendar .hasWeeks .dayContainer,
.flatpickr-calendar .hasTime .dayContainer {
border-bottom: 0;
border-bottom-right-radius: 0;
border-bottom-left-radius: 0;
}
.flatpickr-calendar .hasWeeks .dayContainer {
border-left: 0;
}
.flatpickr-calendar.showTimeInput.hasTime .flatpickr-time {
height: 40px;
border-top: 1px solid #e6e6e6;
}
.flatpickr-calendar.noCalendar.hasTime .flatpickr-time {
height: auto;
}
.flatpickr-calendar:before,
.flatpickr-calendar:after {
position: absolute;
display: block;
pointer-events: none;
border: solid transparent;
content: '';
height: 0;
width: 0;
left: 22px;
}
.flatpickr-calendar.rightMost:before,
.flatpickr-calendar.rightMost:after {
left: auto;
right: 22px;
}
.flatpickr-calendar:before {
border-width: 5px;
margin: 0 -5px;
}
.flatpickr-calendar:after {
border-width: 4px;
margin: 0 -4px;
}
.flatpickr-calendar.arrowTop:before,
.flatpickr-calendar.arrowTop:after {
bottom: 100%;
}
.flatpickr-calendar.arrowTop:before {
border-bottom-color: #e6e6e6;
}
.flatpickr-calendar.arrowTop:after {
border-bottom-color: #fff;
}
.flatpickr-calendar.arrowBottom:before,
.flatpickr-calendar.arrowBottom:after {
top: 100%;
}
.flatpickr-calendar.arrowBottom:before {
border-top-color: #e6e6e6;
}
.flatpickr-calendar.arrowBottom:after {
border-top-color: #fff;
}
.flatpickr-calendar:focus {
outline: 0;
}
.flatpickr-wrapper {
position: relative;
display: inline-block;
}
.flatpickr-months {
display: -webkit-box;
display: -webkit-flex;
display: -ms-flexbox;
display: flex;
}
.flatpickr-months .flatpickr-month {
background: transparent;
color: rgba(0,0,0,0.9);
fill: rgba(0,0,0,0.9);
height: 28px;
line-height: 1;
text-align: center;
position: relative;
-webkit-user-select: none;
-moz-user-select: none;
-ms-user-select: none;
user-select: none;
overflow: hidden;
-webkit-box-flex: 1;
-webkit-flex: 1;
-ms-flex: 1;
flex: 1;
}
.flatpickr-months .flatpickr-prev-month,
.flatpickr-months .flatpickr-next-month {
text-decoration: none;
cursor: pointer;
position: absolute;
top: 0px;
line-height: 16px;
height: 28px;
padding: 10px;
z-index: 3;
}
.flatpickr-months .flatpickr-prev-month.disabled,
.flatpickr-months .flatpickr-next-month.disabled {
display: none;
}
.flatpickr-months .flatpickr-prev-month i,
.flatpickr-months .flatpickr-next-month i {
position: relative;
}
.flatpickr-months .flatpickr-prev-month.flatpickr-prev-month,
.flatpickr-months .flatpickr-next-month.flatpickr-prev-month {
/*
/*rtl:begin:ignore*/
/*
*/
left: 0;
/*
/*rtl:end:ignore*/
/*
*/
}
/*
/*rtl:begin:ignore*/
/*
/*rtl:end:ignore*/
.flatpickr-months .flatpickr-prev-month.flatpickr-next-month,
.flatpickr-months .flatpickr-next-month.flatpickr-next-month {
/*
/*rtl:begin:ignore*/
/*
*/
right: 0;
/*
/*rtl:end:ignore*/
/*
*/
}
/*
/*rtl:begin:ignore*/
/*
/*rtl:end:ignore*/
.flatpickr-months .flatpickr-prev-month:hover,
.flatpickr-months .flatpickr-next-month:hover {
color: #959ea9;
}
.flatpickr-months .flatpickr-prev-month:hover svg,
.flatpickr-months .flatpickr-next-month:hover svg {
fill: #f64747;
}
.flatpickr-months .flatpickr-prev-month svg,
.flatpickr-months .flatpickr-next-month svg {
width: 14px;
height: 14px;
}
.flatpickr-months .flatpickr-prev-month svg path,
.flatpickr-months .flatpickr-next-month svg path {
-webkit-transition: fill 0.1s;
transition: fill 0.1s;
fill: inherit;
}
.numInputWrapper {
position: relative;
height: auto;
}
.numInputWrapper input,
.numInputWrapper span {
display: inline-block;
}
.numInputWrapper input {
width: 100%;
min-width: auto !important;
}
.numInputWrapper input::-ms-clear {
display: none;
}
.numInputWrapper span {
position: absolute;
right: 0;
width: 14px;
padding: 0 4px 0 2px;
height: 50%;
line-height: 50%;
opacity: 0;
cursor: pointer;
border: 1px solid rgba(57,57,57,0.15);
-webkit-box-sizing: border-box;
box-sizing: border-box;
}
.numInputWrapper span:hover {
background: rgba(0,0,0,0.1);
}
.numInputWrapper span:active {
background: rgba(0,0,0,0.2);
}
.numInputWrapper span:after {
display: block;
content: '';
position: absolute;
}
.numInputWrapper span.arrowUp {
top: 0;
border-bottom: 0;
}
.numInputWrapper span.arrowUp:after {
border-left: 4px solid transparent;
border-right: 4px solid transparent;
border-bottom: 4px solid rgba(57,57,57,0.6);
top: 26%;
}
.numInputWrapper span.arrowDown {
top: 50%;
}
.numInputWrapper span.arrowDown:after {
border-left: 4px solid transparent;
border-right: 4px solid transparent;
border-top: 4px solid rgba(57,57,57,0.6);
top: 40%;
}
.numInputWrapper span svg {
width: inherit;
height: auto;
}
.numInputWrapper span svg path {
fill: rgba(0,0,0,0.5);
}
.numInputWrapper:hover {
background: rgba(0,0,0,0.05);
}
.numInputWrapper:hover span {
opacity: 1;
}
.flatpickr-current-month {
font-size: 135%;
line-height: inherit;
font-weight: 300;
color: inherit;
position: absolute;
width: 75%;
left: 12.5%;
padding: 6.16px 0 0 0;
line-height: 1;
height: 28px;
display: inline-block;
text-align: center;
-webkit-transform: translate3d(0px, 0px, 0px);
transform: translate3d(0px, 0px, 0px);
}
.flatpickr-current-month span.cur-month {
font-family: inherit;
font-weight: 700;
color: inherit;
display: inline-block;
margin-left: 0.5ch;
padding: 0;
}
.flatpickr-current-month span.cur-month:hover {
background: rgba(0,0,0,0.05);
}
.flatpickr-current-month .numInputWrapper {
width: 6ch;
width: 7ch\0;
display: inline-block;
}
.flatpickr-current-month .numInputWrapper span.arrowUp:after {
border-bottom-color: rgba(0,0,0,0.9);
}
.flatpickr-current-month .numInputWrapper span.arrowDown:after {
border-top-color: rgba(0,0,0,0.9);
}
.flatpickr-current-month input.cur-year {
background: transparent;
-webkit-box-sizing: border-box;
box-sizing: border-box;
color: inherit;
cursor: text;
padding: 0 0 0 0.5ch;
margin: 0;
display: inline-block;
font-size: inherit;
font-family: inherit;
font-weight: 300;
line-height: inherit;
height: auto;
border: 0;
border-radius: 0;
vertical-align: initial;
}
.flatpickr-current-month input.cur-year:focus {
outline: 0;
}
.flatpickr-current-month input.cur-year[disabled],
.flatpickr-current-month input.cur-year[disabled]:hover {
font-size: 100%;
color: rgba(0,0,0,0.5);
background: transparent;
pointer-events: none;
}
.flatpickr-weekdays {
background: transparent;
text-align: center;
overflow: hidden;
width: 100%;
display: -webkit-box;
display: -webkit-flex;
display: -ms-flexbox;
display: flex;
-webkit-box-align: center;
-webkit-align-items: center;
-ms-flex-align: center;
align-items: center;
height: 28px;
}
.flatpickr-weekdays .flatpickr-weekdaycontainer {
display: -webkit-box;
display: -webkit-flex;
display: -ms-flexbox;
display: flex;
-webkit-box-flex: 1;
-webkit-flex: 1;
-ms-flex: 1;
flex: 1;
}
span.flatpickr-weekday {
cursor: default;
font-size: 90%;
background: transparent;
color: rgba(0,0,0,0.54);
line-height: 1;
margin: 0;
text-align: center;
display: block;
-webkit-box-flex: 1;
-webkit-flex: 1;
-ms-flex: 1;
flex: 1;
font-weight: bolder;
}
.dayContainer,
.flatpickr-weeks {
padding: 1px 0 0 0;
}
.flatpickr-days {
position: relative;
overflow: hidden;
display: -webkit-box;
display: -webkit-flex;
display: -ms-flexbox;
display: flex;
-webkit-box-align: start;
-webkit-align-items: flex-start;
-ms-flex-align: start;
align-items: flex-start;
width: 307.875px;
}
.flatpickr-days:focus {
outline: 0;
}
.dayContainer {
padding: 0;
outline: 0;
text-align: left;
width: 307.875px;
min-width: 307.875px;
max-width: 307.875px;
-webkit-box-sizing: border-box;
box-sizing: border-box;
display: inline-block;
display: -ms-flexbox;
display: -webkit-box;
display: -webkit-flex;
display: flex;
-webkit-flex-wrap: wrap;
flex-wrap: wrap;
-ms-flex-wrap: wrap;
-ms-flex-pack: justify;
-webkit-justify-content: space-around;
justify-content: space-around;
-webkit-transform: translate3d(0px, 0px, 0px);
transform: translate3d(0px, 0px, 0px);
opacity: 1;
}
.dayContainer + .dayContainer {
-webkit-box-shadow: -1px 0 0 #e6e6e6;
box-shadow: -1px 0 0 #e6e6e6;
}
.flatpickr-day {
background: none;
border: 1px solid transparent;
border-radius: 150px;
-webkit-box-sizing: border-box;
box-sizing: border-box;
color: #393939;
cursor: pointer;
font-weight: 400;
width: 14.2857143%;
-webkit-flex-basis: 14.2857143%;
-ms-flex-preferred-size: 14.2857143%;
flex-basis: 14.2857143%;
max-width: 39px;
height: 39px;
line-height: 39px;
margin: 0;
display: inline-block;
position: relative;
-webkit-box-pack: center;
-webkit-justify-content: center;
-ms-flex-pack: center;
justify-content: center;
text-align: center;
}
.flatpickr-day.inRange,
.flatpickr-day.prevMonthDay.inRange,
.flatpickr-day.nextMonthDay.inRange,
.flatpickr-day.today.inRange,
.flatpickr-day.prevMonthDay.today.inRange,
.flatpickr-day.nextMonthDay.today.inRange,
.flatpickr-day:hover,
.flatpickr-day.prevMonthDay:hover,
.flatpickr-day.nextMonthDay:hover,
.flatpickr-day:focus,
.flatpickr-day.prevMonthDay:focus,
.flatpickr-day.nextMonthDay:focus {
cursor: pointer;
outline: 0;
background: #e6e6e6;
border-color: #e6e6e6;
}
.flatpickr-day.today {
border-color: #959ea9;
}
.flatpickr-day.today:hover,
.flatpickr-day.today:focus {
border-color: #959ea9;
background: #959ea9;
color: #fff;
}
.flatpickr-day.selected,
.flatpickr-day.startRange,
.flatpickr-day.endRange,
.flatpickr-day.selected.inRange,
.flatpickr-day.startRange.inRange,
.flatpickr-day.endRange.inRange,
.flatpickr-day.selected:focus,
.flatpickr-day.startRange:focus,
.flatpickr-day.endRange:focus,
.flatpickr-day.selected:hover,
.flatpickr-day.startRange:hover,
.flatpickr-day.endRange:hover,
.flatpickr-day.selected.prevMonthDay,
.flatpickr-day.startRange.prevMonthDay,
.flatpickr-day.endRange.prevMonthDay,
.flatpickr-day.selected.nextMonthDay,
.flatpickr-day.startRange.nextMonthDay,
.flatpickr-day.endRange.nextMonthDay {
background: #569ff7;
-webkit-box-shadow: none;
box-shadow: none;
color: #fff;
border-color: #569ff7;
}
.flatpickr-day.selected.startRange,
.flatpickr-day.startRange.startRange,
.flatpickr-day.endRange.startRange {
border-radius: 50px 0 0 50px;
}
.flatpickr-day.selected.endRange,
.flatpickr-day.startRange.endRange,
.flatpickr-day.endRange.endRange {
border-radius: 0 50px 50px 0;
}
.flatpickr-day.selected.startRange + .endRange,
.flatpickr-day.startRange.startRange + .endRange,
.flatpickr-day.endRange.startRange + .endRange {
-webkit-box-shadow: -10px 0 0 #569ff7;
box-shadow: -10px 0 0 #569ff7;
}
.flatpickr-day.selected.startRange.endRange,
.flatpickr-day.startRange.startRange.endRange,
.flatpickr-day.endRange.startRange.endRange {
border-radius: 50px;
}
.flatpickr-day.inRange {
border-radius: 0;
-webkit-box-shadow: -5px 0 0 #e6e6e6, 5px 0 0 #e6e6e6;
box-shadow: -5px 0 0 #e6e6e6, 5px 0 0 #e6e6e6;
}
.flatpickr-day.disabled,
.flatpickr-day.disabled:hover,
.flatpickr-day.prevMonthDay,
.flatpickr-day.nextMonthDay,
.flatpickr-day.notAllowed,
.flatpickr-day.notAllowed.prevMonthDay,
.flatpickr-day.notAllowed.nextMonthDay {
color: rgba(57,57,57,0.3);
background: transparent;
border-color: transparent;
cursor: default;
}
.flatpickr-day.disabled,
.flatpickr-day.disabled:hover {
cursor: not-allowed;
color: rgba(57,57,57,0.1);
}
.flatpickr-day.week.selected {
border-radius: 0;
-webkit-box-shadow: -5px 0 0 #569ff7, 5px 0 0 #569ff7;
box-shadow: -5px 0 0 #569ff7, 5px 0 0 #569ff7;
}
.flatpickr-day.hidden {
visibility: hidden;
}
.rangeMode .flatpickr-day {
margin-top: 1px;
}
.flatpickr-weekwrapper {
display: inline-block;
float: left;
}
.flatpickr-weekwrapper .flatpickr-weeks {
padding: 0 12px;
-webkit-box-shadow: 1px 0 0 #e6e6e6;
box-shadow: 1px 0 0 #e6e6e6;
}
.flatpickr-weekwrapper .flatpickr-weekday {
float: none;
width: 100%;
line-height: 28px;
}
.flatpickr-weekwrapper span.flatpickr-day,
.flatpickr-weekwrapper span.flatpickr-day:hover {
display: block;
width: 100%;
max-width: none;
color: rgba(57,57,57,0.3);
background: transparent;
cursor: default;
border: none;
}
.flatpickr-innerContainer {
display: block;
display: -webkit-box;
display: -webkit-flex;
display: -ms-flexbox;
display: flex;
-webkit-box-sizing: border-box;
box-sizing: border-box;
overflow: hidden;
}
.flatpickr-rContainer {
display: inline-block;
padding: 0;
-webkit-box-sizing: border-box;
box-sizing: border-box;
}
.flatpickr-time {
text-align: center;
outline: 0;
display: block;
height: 0;
line-height: 40px;
max-height: 40px;
-webkit-box-sizing: border-box;
box-sizing: border-box;
overflow: hidden;
display: -webkit-box;
display: -webkit-flex;
display: -ms-flexbox;
display: flex;
}
.flatpickr-time:after {
content: '';
display: table;
clear: both;
}
.flatpickr-time .numInputWrapper {
-webkit-box-flex: 1;
-webkit-flex: 1;
-ms-flex: 1;
flex: 1;
width: 40%;
height: 40px;
float: left;
}
.flatpickr-time .numInputWrapper span.arrowUp:after {
border-bottom-color: #393939;
}
.flatpickr-time .numInputWrapper span.arrowDown:after {
border-top-color: #393939;
}
.flatpickr-time.hasSeconds .numInputWrapper {
width: 26%;
}
.flatpickr-time.time24hr .numInputWrapper {
width: 49%;
}
.flatpickr-time input {
background: transparent;
-webkit-box-shadow: none;
box-shadow: none;
border: 0;
border-radius: 0;
text-align: center;
margin: 0;
padding: 0;
height: inherit;
line-height: inherit;
cursor: pointer;
color: #393939;
font-size: 14px;
position: relative;
-webkit-box-sizing: border-box;
box-sizing: border-box;
}
.flatpickr-time input.flatpickr-hour {
font-weight: bold;
}
.flatpickr-time input.flatpickr-minute,
.flatpickr-time input.flatpickr-second {
font-weight: 400;
}
.flatpickr-time input:focus {
outline: 0;
border: 0;
}
.flatpickr-time .flatpickr-time-separator,
.flatpickr-time .flatpickr-am-pm {
height: inherit;
display: inline-block;
float: left;
line-height: inherit;
color: #393939;
font-weight: bold;
width: 2%;
-webkit-user-select: none;
-moz-user-select: none;
-ms-user-select: none;
user-select: none;
-webkit-align-self: center;
-ms-flex-item-align: center;
align-self: center;
}
.flatpickr-time .flatpickr-am-pm {
outline: 0;
width: 18%;
cursor: pointer;
text-align: center;
font-weight: 400;
}
.flatpickr-time .flatpickr-am-pm:hover,
.flatpickr-time .flatpickr-am-pm:focus {
background: #f0f0f0;
}
.flatpickr-input[readonly] {
cursor: pointer;
min-width: auto;
}
@-webkit-keyframes fpFadeInDown {
from {
opacity: 0;
-webkit-transform: translate3d(0, -20px, 0);
transform: translate3d(0, -20px, 0);
}
to {
opacity: 1;
-webkit-transform: translate3d(0, 0, 0);
transform: translate3d(0, 0, 0);
}
}
@keyframes fpFadeInDown {
from {
opacity: 0;
-webkit-transform: translate3d(0, -20px, 0);
transform: translate3d(0, -20px, 0);
}
to {
opacity: 1;
-webkit-transform: translate3d(0, 0, 0);
transform: translate3d(0, 0, 0);
}
}

2
frontend/vendor/main.js vendored
View File

@ -1,2 +1,2 @@
import './fontawesome.css'; import './fontawesome.css';
import './flatpickr.css'; import './datetime.css';

5
jsconfig.json Normal file
View File

@ -0,0 +1,5 @@
{
"compilerOptions": {
"experimentalDecorators": true
},
}

185
messages/uniworx/de.msg
View File

@ -30,6 +30,7 @@ Aborted: Abgebrochen
Remarks: Hinweise Remarks: Hinweise
Registered: Angemeldet Registered: Angemeldet
RegisteredSince: Angemeldet seit RegisteredSince: Angemeldet seit
Registration: Anmeldung
RegisterFrom: Anmeldungen von RegisterFrom: Anmeldungen von
RegisterTo: Anmeldungen bis RegisterTo: Anmeldungen bis
DeRegUntil: Abmeldungen bis DeRegUntil: Abmeldungen bis
@ -127,7 +128,7 @@ CourseShorthand: Kürzel
CourseShorthandUnique: Muss innerhalb Institut und Semester eindeutig sein CourseShorthandUnique: Muss innerhalb Institut und Semester eindeutig sein
CourseSemester: Semester CourseSemester: Semester
CourseSchool: Institut CourseSchool: Institut
CourseSchoolShort: Fach CourseSchoolShort: Institut
CourseSecretTip: Anmeldung zum Kurs erfordert Eingabe des Passworts, sofern gesetzt CourseSecretTip: Anmeldung zum Kurs erfordert Eingabe des Passworts, sofern gesetzt
CourseSecretFormat: beliebige Zeichenkette CourseSecretFormat: beliebige Zeichenkette
CourseRegisterFromTip: Ohne Datum ist KEINE eigenständige Anmeldung von Studierenden möglich CourseRegisterFromTip: Ohne Datum ist KEINE eigenständige Anmeldung von Studierenden möglich
@ -170,6 +171,18 @@ CourseApplicationInstructionsRegistration: Anweisungen zur Anmeldung
CourseApplicationTemplateApplication: Bewerbungsvorlage(n) CourseApplicationTemplateApplication: Bewerbungsvorlage(n)
CourseApplicationTemplateRegistration: Anmeldungsvorlage(n) CourseApplicationTemplateRegistration: Anmeldungsvorlage(n)
CourseApplicationTemplateArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-bewerbungsvorlagen CourseApplicationTemplateArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-bewerbungsvorlagen
CourseApplication: Bewerbung
CourseApplicationExists: Sie haben sich bereits für diesen Kurs beworben
CourseApplicationInvalidAction: Angegeben 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
CourseApplicationRated: Bewertung erfolgreich angepasst
CourseApplicationRatingDeleted: Bewertung erfolgreich entfernt
CourseApplicationDeleted csh@CourseShorthand: Bewerbung zu #{csh} erfolgreich zurückgezogen
CourseApplicationTitle displayName@Text csh@CourseShorthand: Bewerbung für #{csh}: #{displayName}
CourseApplicationText: Text-Bewerbung CourseApplicationText: Text-Bewerbung
CourseApplicationFollowInstructions: Beachten Sie die Anweisungen zur Bewerbung! CourseApplicationFollowInstructions: Beachten Sie die Anweisungen zur Bewerbung!
@ -183,6 +196,8 @@ CourseRegistrationFile: Datei zur Anmeldung
CourseRegistrationFiles: Datei(en) zur Anmeldung CourseRegistrationFiles: Datei(en) zur Anmeldung
CourseRegistrationArchive: Zip-Archiv der Datei(en) zur Anmeldung CourseRegistrationArchive: Zip-Archiv der Datei(en) zur Anmeldung
CourseApplicationNoFiles: Keine Datei(en) CourseApplicationNoFiles: Keine Datei(en)
CourseApplicationFilesNeedReupload: Bewerbungsdateien müssen neu hochgeladen werden, wann immer die Bewerbung angepasst wird
CourseRegistrationFilesNeedReupload: Dateien zur Anmeldung müssen neu hochgeladen werden, wann immer die Anmeldung angepasst wird
CourseApplicationDeleteToEdit: Um Ihre Bewerbung zu editieren müssen Sie sie zunächst zurückziehen und sich erneut bewerben. CourseApplicationDeleteToEdit: Um Ihre Bewerbung zu editieren müssen Sie sie zunächst zurückziehen und sich erneut bewerben.
CourseRegistrationDeleteToEdit: Um Ihre Anmeldungsdaten zu editieren müssen Sie sich zunächst ab- und dann erneut anmelden. CourseRegistrationDeleteToEdit: Um Ihre Anmeldungsdaten zu editieren müssen Sie sich zunächst ab- und dann erneut anmelden.
@ -191,9 +206,12 @@ CourseLoginToApply: Um sich zum Kurz zu bewerben müssen Sie sich zunächst in U
CourseLoginToRegister: Um sich zum Kurs anzumelden müssen Sie zunächst in Uni2work anmelden CourseLoginToRegister: Um sich zum Kurs anzumelden müssen Sie zunächst in Uni2work anmelden
CourseApplicationArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand appId@CryptoFileNameCourseApplication displayName@Text: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase (toPathPiece appId)}-#{foldCase displayName} CourseApplicationArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand appId@CryptoFileNameCourseApplication displayName@Text: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase (toPathPiece appId)}-#{foldCase displayName}
CourseAllApplicationsArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-bewerbungen
CourseApplicationsAllocatedDirectory: zentral
CourseApplicationsNotAllocatedDirectory: direkt
CourseNoAllocationsAvailable: Es sind aktuell keine Zentralanmeldungen verfügbar CourseNoAllocationsAvailable: Es sind aktuell keine Zentralanmeldungen verfügbar
AllocationStaffRegisterToExpired: Es dürfen keine Änderungen an der Eintragung des Kurses zur Zentralanmeldung mehr vorgenommen werden AllocationStaffRegisterToExpired: Es dürfen keine Änderungen an der Eintragung des Kurses zur Zentralanmeldung mehr vorgenommen werden. Ihre Änderungen wurden ignoriert.
CourseFormSectionRegistration: Anmeldung zum Kurs CourseFormSectionRegistration: Anmeldung zum Kurs
@ -212,6 +230,8 @@ CourseAllocationCapacityMayNotBeChanged: Kapazität eines Kurses, der an einer Z
CourseLecturerRightsIdentical: Alle Sorten von Kursverwalter haben identische Rechte. CourseLecturerRightsIdentical: Alle Sorten von Kursverwalter haben identische Rechte.
School: Institut
NoSuchTerm tid@TermId: Semester #{tid} gibt es nicht. NoSuchTerm tid@TermId: Semester #{tid} gibt es nicht.
NoSuchSchool ssh@SchoolId: Institut #{ssh} gibt es nicht. NoSuchSchool ssh@SchoolId: Institut #{ssh} gibt es nicht.
NoSuchCourseShorthand csh@CourseShorthand: Kein Kurs mit Kürzel #{csh} bekannt. NoSuchCourseShorthand csh@CourseShorthand: Kein Kurs mit Kürzel #{csh} bekannt.
@ -332,7 +352,7 @@ MaterialArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand materialName@Mat
Unauthorized: Sie haben hierfür keine explizite Berechtigung. Unauthorized: Sie haben hierfür keine explizite Berechtigung.
UnauthorizedAnd l@Text r@Text: (#{l} UND #{r}) UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})
UnauthorizedOr l@Text r@Text: (#{l} ODER #{r}) UnauthorizedOr l@Text r@Text: (#{l} ODER #{r})
UnauthorizedNot i@Text: (NICHT #{i}) UnauthorizedNot r@Text: (NICHT #{r})
UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt. UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt.
UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen. UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen.
UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig. UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig.
@ -345,13 +365,16 @@ UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut e
UnauthorizedAdminEscalation: Sie sind nicht Administrator für alle Institute, für die dieser Nutzer Administrator oder Veranstalter ist. UnauthorizedAdminEscalation: Sie sind nicht Administrator für alle Institute, für die dieser Nutzer Administrator oder Veranstalter ist.
UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen. UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen.
UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen. UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen.
UnauthorizedAllocationLecturer: Sie sind nicht als Veranstalter für eine Veranstaltung dieser Zentralanmeldung eingetragen.
UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung eingetragen. UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung eingetragen.
UnauthorizedSheetCorrector: Sie sind nicht als Korrektor für dieses Übungsblatt eingetragen. UnauthorizedSheetCorrector: Sie sind nicht als Korrektor für dieses Übungsblatt eingetragen.
UnauthorizedCorrectorAny: Sie sind nicht als Korrektor für eine Veranstaltung eingetragen. UnauthorizedCorrectorAny: Sie sind nicht als Korrektor für eine Veranstaltung eingetragen.
UnauthorizedRegistered: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert. UnauthorizedRegistered: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert.
UnauthorizedAllocationRegistered: Sie sind nicht als Teilnehmer für diese Zentralanmeldung registriert.
UnauthorizedExamResult: Sie haben keine Ergebnisse in dieser Prüfung. UnauthorizedExamResult: Sie haben keine Ergebnisse in dieser Prüfung.
UnauthorizedParticipant: Angegebener Benutzer ist nicht als Teilnehmer dieser Veranstaltung registriert. UnauthorizedParticipant: Angegebener Benutzer ist nicht als Teilnehmer dieser Veranstaltung registriert.
UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen. UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen.
UnauthorizedAllocationRegisterTime: Diese Zentralanmeldung erlaubt momentan keine Bewerbungen.
UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben. UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
UnauthorizedApplicationTime: Diese Bewerbung ist momentan nicht freigegeben. UnauthorizedApplicationTime: Diese Bewerbung ist momentan nicht freigegeben.
UnauthorizedMaterialTime: Dieses Material ist momentan nicht freigegeben. UnauthorizedMaterialTime: Dieses Material ist momentan nicht freigegeben.
@ -369,7 +392,7 @@ MaterialFree: Kursmaterialien ohne Anmeldung zugänglich
UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung
UnauthorizedSystemMessageTime: Diese Systemnachricht ist noch nicht oder nicht mehr einsehbar. UnauthorizedSystemMessageTime: Diese Systemnachricht ist noch nicht oder nicht mehr einsehbar.
UnauthorizedSystemMessageAuth: Diese Systemnachricht ist nur für angemeldete Benutzer einsehbar. UnauthorizedSystemMessageAuth: Diese Systemnachricht ist nur für angemeldete Benutzer einsehbar.
UnsupportedAuthPredicate authTagT@Text shownRoute@String: "#{authTagT}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute} UnsupportedAuthPredicate authTagT@Text shownRoute@Text: „#{authTagT}“ wurde auf eine Route angewandt, die dies nicht unterstützt: „#{shownRoute}“
UnauthorizedDisabledTag authTag@AuthTag: Authorisierungsprädikat "#{toPathPiece authTag}" ist für Ihre Sitzung nicht aktiv UnauthorizedDisabledTag authTag@AuthTag: Authorisierungsprädikat "#{toPathPiece authTag}" ist für Ihre Sitzung nicht aktiv
UnknownAuthPredicate tag@String: Authorisierungsprädikat "#{tag}" ist dem System nicht bekannt UnknownAuthPredicate tag@String: Authorisierungsprädikat "#{tag}" ist dem System nicht bekannt
UnauthorizedRedirect: Die angeforderte Seite existiert nicht oder Sie haben keine Berechtigung, die angeforderte Seite zu sehen. UnauthorizedRedirect: Die angeforderte Seite existiert nicht oder Sie haben keine Berechtigung, die angeforderte Seite zu sehen.
@ -433,7 +456,7 @@ NotificationSettingsHeading displayName@Text: Benachrichtigungs-Einstellungen f
TokensLastReset: Tokens zuletzt invalidiert TokensLastReset: Tokens zuletzt invalidiert
TokensResetSuccess: Authorisierungs-Tokens invalidiert TokensResetSuccess: Authorisierungs-Tokens invalidiert
HomeOpenCourses: Kurse mit offener Registrierung HomeOpenAllocations: Offene Zentralanmeldungen
HomeUpcomingSheets: Anstehende Übungsblätter HomeUpcomingSheets: Anstehende Übungsblätter
HomeUpcomingExams: Bevorstehende Prüfungen HomeUpcomingExams: Bevorstehende Prüfungen
@ -558,7 +581,7 @@ RatingFilesUpdated: Korrigierte Dateien überschrieben
RatingNotUnicode uexc@UnicodeException: Bewertungsdatei nicht in UTF-8 kodiert: #{tshow uexc} RatingNotUnicode uexc@UnicodeException: Bewertungsdatei nicht in UTF-8 kodiert: #{tshow uexc}
RatingMissingSeparator: Präambel der Bewertungsdatei konnte nicht identifziert werden RatingMissingSeparator: Präambel der Bewertungsdatei konnte nicht identifziert werden
RatingMultiple: Bewertungen enthält mehrere Punktzahlen für die gleiche Abgabe RatingMultiple: Bewertungen enthält mehrere Punktzahlen für die gleiche Abgabe
RatingInvalid parseErr@String: Bewertungspunktzahl konnte nicht als Zahl verstanden werden: #{parseErr} RatingInvalid parseErr@Text: Bewertungspunktzahl konnte nicht als Zahl verstanden werden: #{parseErr}
RatingFileIsDirectory: Unerwarteter Fehler: Datei ist unerlaubterweise ein Verzeichnis RatingFileIsDirectory: Unerwarteter Fehler: Datei ist unerlaubterweise ein Verzeichnis
RatingNegative: Bewertungspunkte dürfen nicht negativ sein RatingNegative: Bewertungspunkte dürfen nicht negativ sein
RatingExceedsMax: Bewertung übersteigt die erlaubte Maximalpunktzahl RatingExceedsMax: Bewertung übersteigt die erlaubte Maximalpunktzahl
@ -576,7 +599,7 @@ MultiSinkException name@Text error@Text: In Abgabe #{name} ist ein Fehler aufget
NoTableContent: Kein Tabelleninhalt NoTableContent: Kein Tabelleninhalt
NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter
NoUpcomingExams: In den nächsten 14 Tagen gibt es keine Prüfung mit offener Registrierung in Ihren Kursen NoUpcomingExams difftime@Text: In den nächsten #{difftime} gibt es keine Prüfungen oder ablaufende Prüfungsanmeldungen in Ihren Kursen
AdminHeading: Administration AdminHeading: Administration
AdminUserHeading: Benutzeradministration AdminUserHeading: Benutzeradministration
@ -592,7 +615,8 @@ TutorsFor n@Int: #{pluralDE n "Tutor" "Tutoren"}
CorrectorsFor n@Int: #{pluralDE n "Korrektor" "Korrektoren"} CorrectorsFor n@Int: #{pluralDE n "Korrektor" "Korrektoren"}
ForSchools n@Int: für #{pluralDE n "Institut" "Institute"} ForSchools n@Int: für #{pluralDE n "Institut" "Institute"}
UserListTitle: Komprehensive Benutzerliste UserListTitle: Komprehensive Benutzerliste
AccessRightsSaved: Berechtigungsänderungen wurden gespeichert. AccessRightsSaved: Berechtigungen erfolgreich verändert
AccessRightsNotChanged: Berechtigungen wurden nicht verändert
LecturersForN n@Int: #{pluralDE n "Dozent" "Dozenten"} LecturersForN n@Int: #{pluralDE n "Dozent" "Dozenten"}
@ -602,7 +626,11 @@ DateFormat: Datumsformat
TimeFormat: Uhrzeitformat TimeFormat: Uhrzeitformat
DownloadFiles: Dateien automatisch herunterladen 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 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).
WarningDays: Fristen-Vorschau
WarningDaysTip: Wie viele Tage im Voraus sollen Fristen von Klausuren etc. auf Ihrer Startseite angezeigt werden?
NotificationSettings: Erwünschte Benachrichtigungen NotificationSettings: Erwünschte Benachrichtigungen
UserSchools: Relevante Institute
UserSchoolsTip: Sie erhalten nur institutweite Benachrichtigungen für Institute, die hier ausgewählt sind.
FormNotifications: Benachrichtigungen FormNotifications: Benachrichtigungen
FormBehaviour: Verhalten FormBehaviour: Verhalten
FormCosmetics: Oberfläche FormCosmetics: Oberfläche
@ -637,7 +665,8 @@ CampusUserInvalidGivenName: Konnte anhand des Campus-Logins keinen Vornamen ermi
CampusUserInvalidSurname: Konnte anhand des Campus-Logins keinen Nachname ermitteln CampusUserInvalidSurname: Konnte anhand des Campus-Logins keinen Nachname ermitteln
CampusUserInvalidTitle: Konnte anhand des Campus-Logins keinen akademischen Titel ermitteln CampusUserInvalidTitle: Konnte anhand des Campus-Logins keinen akademischen Titel ermitteln
CampusUserInvalidMatriculation: Konnte anhand des Campus-Logins keine Matrikelnummer ermitteln CampusUserInvalidMatriculation: Konnte anhand des Campus-Logins keine Matrikelnummer ermitteln
CampusUserInvalidFeaturesOfStudy parseErr@String: Konnte anhand des Campus-Logins keine Matrikelnummer ermitteln: #{parseErr} CampusUserInvalidFeaturesOfStudy parseErr@Text: Konnte anhand des Campus-Logins keine Studiengänge ermitteln
CampusUserInvalidAssociatedSchools parseErr@Text: Konnte anhand des Campus-Logins keine Institute ermitteln
CorrectorNormal: Normal CorrectorNormal: Normal
CorrectorMissing: Abwesend CorrectorMissing: Abwesend
@ -836,6 +865,8 @@ NotificationTriggerKindExamParticipant: Für Prüfungsteilnehmer
NotificationTriggerKindCorrector: Für Korrektoren NotificationTriggerKindCorrector: Für Korrektoren
NotificationTriggerKindLecturer: Für Dozenten NotificationTriggerKindLecturer: Für Dozenten
NotificationTriggerKindAdmin: Für Administratoren NotificationTriggerKindAdmin: Für Administratoren
NotificationTriggerKindExamOffice: Für das Prüfungsamt
NotificationTriggerKindEvaluation: Für Vorlesungsumfragen
CorrCreate: Abgaben erstellen CorrCreate: Abgaben erstellen
UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}" UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"
@ -933,6 +964,8 @@ ErrorCryptoIdMismatch: Verschlüsselte Id der Abgabe passte nicht zu anderen Dat
InvalidRoute: Konnte URL nicht interpretieren InvalidRoute: Konnte URL nicht interpretieren
MenuOpenCourses: Kurse mit offener Registrierung
MenuOpenAllocations: Aktive Zentralanmeldungen
MenuHome: Aktuell MenuHome: Aktuell
MenuInformation: Informationen MenuInformation: Informationen
MenuImpressum: Impressum MenuImpressum: Impressum
@ -944,10 +977,12 @@ MenuHelp: Hilfe
MenuProfile: Anpassen MenuProfile: Anpassen
MenuLogin: Login MenuLogin: Login
MenuLogout: Logout MenuLogout: Logout
MenuAllocationList: Zentralanmeldungen
MenuCourseList: Kurse MenuCourseList: Kurse
MenuCourseMembers: Kursteilnehmer MenuCourseMembers: Kursteilnehmer
MenuCourseAddMembers: Kursteilnehmer hinzufügen MenuCourseAddMembers: Kursteilnehmer hinzufügen
MenuCourseCommunication: Kursmitteilung MenuCourseCommunication: Kursmitteilung
MenuCourseApplications: Bewerbungen
MenuTermShow: Semester MenuTermShow: Semester
MenuSubmissionDelete: Abgabe löschen MenuSubmissionDelete: Abgabe löschen
MenuUsers: Benutzer MenuUsers: Benutzer
@ -1000,6 +1035,10 @@ MenuExamEdit: Bearbeiten
MenuExamUsers: Teilnehmer MenuExamUsers: Teilnehmer
MenuExamAddMembers: Prüfungsteilnehmer hinzufügen MenuExamAddMembers: Prüfungsteilnehmer hinzufügen
MenuLecturerInvite: Dozenten hinzufügen MenuLecturerInvite: Dozenten hinzufügen
MenuAllocationInfo: Hinweise zum Ablauf einer Zentralanmeldung
MenuCourseApplicationsFiles: Dateien aller Bewerbungen
MenuSchoolList: Institute
MenuSchoolNew: Neues Institut anlegen
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. 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 AuthPredsActive: Aktive Authorisierungsprädikate
@ -1014,8 +1053,10 @@ AuthTagLecturer: Nutzer ist Dozent
AuthTagCorrector: Nutzer ist Korrektor AuthTagCorrector: Nutzer ist Korrektor
AuthTagTutor: Nutzer ist Tutor AuthTagTutor: Nutzer ist Tutor
AuthTagTime: Zeitliche Einschränkungen sind erfüllt AuthTagTime: Zeitliche Einschränkungen sind erfüllt
AuthTagStaffTime: Zeitliche Einschränkungen für Lehrbeteiligte sind erfüllt
AuthTagAllocationTime: Zeitliche Einschränkungen durch Zentralanmeldung sind erfüllt AuthTagAllocationTime: Zeitliche Einschränkungen durch Zentralanmeldung sind erfüllt
AuthTagCourseRegistered: Nutzer ist Kursteilnehmer AuthTagCourseRegistered: Nutzer ist Kursteilnehmer
AuthTagAllocationRegistered: Nutzer nimmt an der Zentralanmeldung teil
AuthTagTutorialRegistered: Nutzer ist Tutoriumsteilnehmer AuthTagTutorialRegistered: Nutzer ist Tutoriumsteilnehmer
AuthTagExamRegistered: Nutzer ist Prüfungsteilnehmer AuthTagExamRegistered: Nutzer ist Prüfungsteilnehmer
AuthTagExamResult: Nutzer hat Prüfungsergebnisse AuthTagExamResult: Nutzer hat Prüfungsergebnisse
@ -1353,11 +1394,12 @@ BtnCsvImport: CSV-Datei importieren
BtnCsvImportConfirm: CSV-Import abschließen BtnCsvImportConfirm: CSV-Import abschließen
CsvImportNotConfigured: CSV-Import nicht vorgesehen CsvImportNotConfigured: CSV-Import nicht vorgesehen
CsvImportConfirmationHeading: CSV-Import abschließen CsvImportConfirmationHeading: CSV-Import Vorschau (noch keine Änderungen importiert)
CsvImportConfirmationTip: Durch den CSV-Import würden die unten aufgeführten Änderungen vorgenommen. Bitte überprüfen Sie diese zunächst sorgfältig. CsvImportConfirmationTip: Es wurden noch keine Änderungen übernommen! Durch den CSV-Import könnten die unten aufgeführten Änderungen vorgenommen werden. Wählen Sie jetzt die gewünschten Änderungen aus, bevor Sie den CSV-Import abschließen.
CsvImportUnnecessary: Durch den CSV-Import würden keine Änderungen vorgenommen werden CsvImportUnnecessary: Durch den CSV-Import würden keine Änderungen vorgenommen werden
CsvImportSuccessful n@Int: CSV-Import erfolgreich, es #{pluralDE n "wurde eine Aktion" (mappend (mappend "wurden " (toMessage n)) " Aktionen")} durchgeführt CsvImportSuccessful n@Int: CSV-Import erfolgreich, es #{pluralDE n "wurde eine Aktion" (mappend (mappend "wurden " (toMessage n)) " Aktionen")} durchgeführt
CsvImportAborted: CSV-Import abgebrochen CsvImportAborted: CSV-Import abgebrochen
CsvImportExplanationLabel: Hinweise zum CSV-Import
Proportion c@Text of@Text prop@Rational: #{c}/#{of} (#{rationalToFixed2 (100 * prop)}%) Proportion c@Text of@Text prop@Rational: #{c}/#{of} (#{rationalToFixed2 (100 * prop)}%)
@ -1377,6 +1419,18 @@ CsvColumnExamUserExercisePasses: Anzahl von Übungsblättern, die der Teilnehmer
CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Prüfungstermin bestehen hätte können CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Prüfungstermin bestehen hätte können
CsvColumnExamUserResult: Erreichte Prüfungsleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0") CsvColumnExamUserResult: Erreichte Prüfungsleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0")
CsvColumnExamUserCourseNote: Notizen zum Teilnehmer CsvColumnExamUserCourseNote: Notizen zum Teilnehmer
CsvColumnApplicationsAllocation: Zentralanmeldung über die die Bewerbung eingegangen ist
CsvColumnApplicationsApplication: Eindeutige Nummer der Bewerbung (zur Zuordnung im ZIP-Archiv aller Bewerbungsdateien)
CsvColumnApplicationsName: Voller Name des Bewerbers
CsvColumnApplicationsMatriculation: Matrikelnummer des Bewerbers
CsvColumnApplicationsField: Studienfach, mit dem der Bewerber seine Bewerbung assoziiert hat
CsvColumnApplicationsDegree: Abschluss, den der Bewerber im assoziierten Studienfach anstrebt
CsvColumnApplicationsSemester: Fachsemester des Bewerbes im assoziierten Studienfach
CsvColumnApplicationsText: Text-Bewerbung
CsvColumnApplicationsHasFiles: Hat der Bewerber Dateien zu seiner Bewerbung eingereicht (siehe ZIP-Archiv aller Bewerbungsdateien)?
CsvColumnApplicationsVeto: Bewerber mit Veto werden garantiert nicht dem Kurs zugeteilt; "veto" oder leer
CsvColumnApplicationsRating: Bewertung der Bewerbung; "1.0", "1.3", "1.7", ..., "4.0", "5.0"
CsvColumnApplicationsComment: Kommentar zur Bewerbung; je nach Kurs-Einstellungen entweder nur als Notiz für die Kursverwalter oder Feedback für den Bewerber
Action: Aktion Action: Aktion
@ -1399,6 +1453,15 @@ ExamUserCsvExceptionNoMatchingUser: Kursteilnehmer konnte nicht eindeutig identi
ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Studienfach des Kursteilnehmers zugeordnet werden ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Studienfach des Kursteilnehmers zugeordnet werden
ExamUserCsvExceptionNoMatchingOccurrence: Raum/Termin konnte nicht eindeutig identifiziert werden ExamUserCsvExceptionNoMatchingOccurrence: Raum/Termin konnte nicht eindeutig identifiziert werden
CourseApplicationsTableCsvSetField: Bewerbungs-assoziiertes Studienfach ändern
CourseApplicationsTableCsvSetVeto: Veto setzen/entfernen
CourseApplicationsTableCsvSetRating: Bewertung eintragen
CourseApplicationsTableCsvSetComment: Bewertungskommentar eintragen
CourseApplicationsTableCsvExceptionNoMatchingUser: Bewerber konnte nicht eindeutig identifiziert werden
CourseApplicationsTableCsvExceptionNoMatchingAllocation: Zentralanmeldung konnte nicht eindeutig identifiziert werden
CourseApplicationsTableCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Studienfach des Kursteilnehmers zugeordnet werden
TableHeadingFilter: Filter TableHeadingFilter: Filter
TableHeadingCsvImport: CSV-Import TableHeadingCsvImport: CSV-Import
TableHeadingCsvExport: CSV-Export TableHeadingCsvExport: CSV-Export
@ -1434,14 +1497,96 @@ PasswordRepeatInvalid: Wiederholung stimmt nicht mit neuem Passwort überein
UserPasswordHeadingFor: Passwort ändern für UserPasswordHeadingFor: Passwort ändern für
PasswordChangedSuccess: Passwort erfolgreich geändert PasswordChangedSuccess: Passwort erfolgreich geändert
LecturerInviteSchool: Institut FunctionaryInviteFunction: Funktion
LecturerInviteField: Einzuladende EMail Addressen FunctionaryInviteSchool: Institut
LecturerInviteHeading: Dozenten hinzufügen FunctionaryInviteField: Einzuladende EMail Addressen
FunctionaryInviteHeading: Institut-Funktionäre hinzufügen
LecturersInvited n@Int: #{n} #{pluralDE n "Dozent" "Dozenten"} per EMail eingeladen FunctionariesInvited n@Int: #{n} #{pluralDE n "Funktionär" "Funktionäre"} per EMail eingeladen
LecturersAdded n@Int: #{n} #{pluralDE n "Dozent" "Dozenten"} eingetragen FunctionariesAdded n@Int: #{n} #{pluralDE n "Funktionär" "Funktionäre"} eingetragen
MailSubjectSchoolLecturerInvitation school@SchoolName: Einladung zum Dozent für „#{school}“ MailSubjectSchoolFunctionInvitation school@SchoolName renderedFunction@Text: #{renderedFunction}-Einladung für „#{school}“
MailSchoolLecturerInviteHeading school@SchoolName: Einladung zum Dozent für „#{school}“ MailSchoolFunctionInviteHeading school@SchoolName renderedFunction@Text: #{renderedFunction}-Einladung für „#{school}“
SchoolLecturerInviteExplanation: Sie wurden eingeladen, Dozent für ein Institut zu sein. Sie können, nachdem Sie die Einladung annehmen, eigenständig neue Kurse anlegen. SchoolFunctionInviteExplanation renderedFunction@Text: Sie wurden eingeladen, als #{renderedFunction} für ein Institut zu wirken. Sie erhalten, nachdem Sie die Einladung annehmen, erweiterte Rechte innerhalb des Instituts.
SchoolLecturerInvitationAccepted school@SchoolName: Einladung zum Dozent für „#{school}“ angenommen SchoolFunctionInvitationAccepted school@SchoolName renderedFunction@Text: #{renderedFunction}-Einladung zum Dozent für „#{school}“ angenommen
AllocationActive: Aktiv
AllocationName: Name
AllocationTitle termText@Text ssh'@SchoolShorthand allocation@AllocationName: #{termText} - #{ssh'}: #{allocation}
AllocationShortTitle termText@Text ssh'@SchoolShorthand ash@AllocationShorthand: #{termText} - #{ssh'} - #{ash}
AllocationDescription: Beschreibung
AllocationStaffRegisterFrom: Eintragung der Kurse ab
AllocationStaffRegister: Eintragung der Kurse
AllocationRegisterFrom: Bewerbung ab
AllocationRegister: Bewerbung
AllocationRegisterClosed: Die Zentralanmeldung ist aktuell geschlossen.
AllocationRegisterOpensIn difftime@Text: Die Zentralanmeldung öffnet voraussichtlich in #{difftime}
AllocationStaffAllocationFrom: Bewertung der Bewerbungen ab
AllocationStaffAllocation: Bewertung der Bewerbungen
AllocationProcess: Platzvergabe
AllocationNoApplication: Keine Bewerbung
AllocationPriority: Priorität
AllocationPriorityTip: Kurse, denen Sie eine höhere Priorität zuteilen, werden bei der Platzvergabe präferiert.
AllocationPriorityRelative: Die absoluten Prioritäts-Werte sind bedeutungslos, es wird nur jeweils betrachtet ob ein Kurs höhere Priorität hat als ein anderer.
AllocationTotalCoursesNegative: Gewünschte Kursanzahl muss größer null sein
AllocationTotalCourses: Gewünschte Anzahl von Kursen
AllocationTotalCoursesTip: Sie werden im Laufe dieser Zentralanmeldung maximal so vielen Kursen zugeteilt, wie Sie hier angeben
AllocationRegistered: Teilnahme an der Zentralanmeldung erfolgreich registriert
AllocationRegistrationEdited: Einstellungen zur Teilnahme an der Zentralanmeldung erfolgreich angepasst
BtnAllocationRegister: Teilnahme registrieren
BtnAllocationRegistrationEdit: Teilnahme anpassen
AllocationParticipation: Teilnahme an der Zentralanmeldung
AllocationParticipationLoginFirst: Um an der Zentralanmeldung teilzunehmen, loggen Sie sich bitte zunächst ein.
AllocationCourses: Kurse dieser Zentralanmeldung
AllocationData: Organisatorisches
AllocationCoursePriority i@Natural: #{i}. Wahl
AllocationCourseNoApplication: Keine Bewerbung
BtnAllocationApply: Bewerben
BtnAllocationApplicationEdit: Bewerbung ersetzen
BtnAllocationApplicationRetract: Bewerbung zurückziehen
BtnAllocationApplicationRate: Bewerbung bewerten
ApplicationPriority: Priorität
ApplicationVeto: Veto
ApplicationVetoTip: Bewerber mit Veto werden garantiert nicht dem Kurs zugeteilt
ApplicationRatingPoints: Bewertung
ApplicationRatingPointsTip: Bewerber mit 5.0 werden garantiert nicht dem Kurs zugeteilt
ApplicationRatingComment: Kommentar
ApplicationRatingCommentVisibleTip: Feedback an den Bewerbers
ApplicationRatingCommentInvisibleTip: Dient zunächst nur als Notiz für Kursverwalter
ApplicationRatingSection: Bewertung
ApplicationRatingSectionSelfTip: Sie verfügen über hinreichende Authorisierung um sowohl die Bewerbung als auch ihre Bewertung zu editieren.
AllocationSchoolShort: Institut
Allocation: Zentralanmeldung
AllocationRegisterTo: Anmeldungen bis
AllocationListTitle: Zentralanmeldungen
CourseApplicationsListTitle: Bewerbungen
CourseApplicationId: Bewerbungsnummer
CourseApplicationRatingPoints: Bewertung
CourseApplicationVeto: Veto
CourseApplicationNoVeto: Kein Veto
CourseApplicationNoRatingPoints: Keine Bewertung
CourseApplicationNoRatingComment: Kein Kommentar
UserDisplayName: Voller Name
UserMatriculation: Matrikelnummer
SchoolShort: Kürzel
SchoolName: Name
SchoolLdapOrganisations: Assoziierte LDAP-Fragmente
SchoolLdapOrganisationsTip: Beim Login via LDAP werden dem Nutzer alle Institute zugeordnet deren assoziierte LDAP-Fragmente im Eintrag des Nutzer gefunden werden
SchoolUpdated ssh@SchoolId: #{ssh} erfolgreich angepasst
SchoolTitle ssh@SchoolId: Institut „#{ssh}“
TitleSchoolNew: Neues Institut anlegen
SchoolCreated ssh@SchoolId: #{ssh} erfolgreich angelegt
SchoolExists ssh@SchoolId: Institut „#{ssh}“ existiert bereits
SchoolAdmin: Admin
SchoolLecturer: Dozent
SchoolEvaluation: Kursumfragenverwaltung
SchoolExamOffice: Prüfungsamt
ApplicationEditTip: Während des Bewerbungszeitraums können eigene Bewerbungen beliebig angepasst und auch wieder zurückgezogen werden.

9
models/allocations
View File

@ -1,12 +1,10 @@
Allocation -- attributes with prefix staff- affect lecturers only, but are invisble to students Allocation -- attributes with prefix staff- affect lecturers only, but are invisble to students
name (CI Text)
shorthand (CI Text) -- practical shorthand
term TermId term TermId
school SchoolId -- school that manages this central allocation, not necessarily school of courses school SchoolId -- school that manages this central allocation, not necessarily school of courses
shorthand AllocationShorthand -- practical shorthand
name AllocationName
description Html Maybe -- description for prospective students description Html Maybe -- description for prospective students
staffDescription Html Maybe -- description seen by prospective lecturers only staffDescription Html Maybe -- description seen by prospective lecturers only
linkExternal Text Maybe -- arbitrary user-defined url for external course page
capacity Int Maybe -- number of allowed enrolements, if restricte
staffRegisterFrom UTCTime Maybe -- lectureres may register courses staffRegisterFrom UTCTime Maybe -- lectureres may register courses
staffRegisterTo UTCTime Maybe -- course registration stops staffRegisterTo UTCTime Maybe -- course registration stops
-- staffDeregisterUntil not needed: staff may make arbitrary changes until staffRegisterTo, always frozen afterwards -- staffDeregisterUntil not needed: staff may make arbitrary changes until staffRegisterTo, always frozen afterwards
@ -17,7 +15,6 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
registerFrom UTCTime Maybe -- student applications allowed from a given day onwwards or prohibited registerFrom UTCTime Maybe -- student applications allowed from a given day onwwards or prohibited
registerTo UTCTime Maybe -- student applications may be prohibited from a given date onwards registerTo UTCTime Maybe -- student applications may be prohibited from a given date onwards
-- deregisterUntil not needed: students may withdraw applicants until registerTo, but never after. Also see overrideDeregister -- deregisterUntil not needed: students may withdraw applicants until registerTo, but never after. Also see overrideDeregister
registerSecret Text Maybe -- student application maybe protected by a simple common passphrase
-- overrides -- overrides
registerByStaffFrom UTCTime Maybe -- lecturers may directly enrol/disenrol students after a given date or prohibited registerByStaffFrom UTCTime Maybe -- lecturers may directly enrol/disenrol students after a given date or prohibited
registerByStaffTo UTCTime Maybe registerByStaffTo UTCTime Maybe
@ -26,6 +23,7 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
-- overrideVisible not needed, since courses are always visible -- overrideVisible not needed, since courses are always visible
TermSchoolAllocationShort term school shorthand -- shorthand must be unique within school and semester TermSchoolAllocationShort term school shorthand -- shorthand must be unique within school and semester
TermSchoolAllocationName term school name -- name must be unique within school and semester TermSchoolAllocationName term school name -- name must be unique within school and semester
deriving Show Eq Ord Generic
AllocationCourse AllocationCourse
allocation AllocationId allocation AllocationId
@ -41,7 +39,6 @@ AllocationUser
AllocationDeregister -- self-inflicted user-deregistrations from an allocated course AllocationDeregister -- self-inflicted user-deregistrations from an allocated course
user UserId user UserId
allocation AllocationId Maybe
course CourseId Maybe course CourseId Maybe
time UTCTime time UTCTime
reason Text Maybe -- if this deregistration was done by proxy (e.g. the lecturer pressed the button) reason Text Maybe -- if this deregistration was done by proxy (e.g. the lecturer pressed the button)

2
models/courses
View File

@ -76,11 +76,13 @@ CourseApplication
user UserId user UserId
field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades
text Text Maybe -- free text entered by user text Text Maybe -- free text entered by user
ratingVeto Bool default=false
ratingPoints ExamGrade Maybe ratingPoints ExamGrade Maybe
ratingComment Text Maybe ratingComment Text Maybe
allocation AllocationId Maybe allocation AllocationId Maybe
allocationPriority Natural Maybe allocationPriority Natural Maybe
time UTCTime default=now() time UTCTime default=now()
ratingTime UTCTime Maybe
CourseApplicationFile CourseApplicationFile
application CourseApplicationId application CourseApplicationId
file FileId file FileId

1
models/invitations
View File

@ -2,4 +2,5 @@ Invitation
email UserEmail email UserEmail
for Value for Value
data Value data Value
expiresAt UTCTime Maybe
UniqueInvitation email for UniqueInvitation email for

9
models/schools
View File

@ -6,4 +6,11 @@ School json
UniqueSchool name UniqueSchool name
UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text
Primary shorthand -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand } Primary shorthand -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand }
deriving Eq Show Generic deriving Ord Eq Show Generic
SchoolLdap
school SchoolId Maybe
orgUnit (CI Text)
UniqueOrgUnit orgUnit
SchoolTerms
school SchoolId
terms StudyTermsId

43
models/users
View File

@ -8,14 +8,16 @@
-- Each table will also have an column storing a unique numeric row key, unless there is a row Primary columnname -- Each table will also have an column storing a unique numeric row key, unless there is a row Primary columnname
-- --
User json -- Each Uni2work user has a corresponding row in this table; created upon first login. User json -- Each Uni2work user has a corresponding row in this table; created upon first login.
surname UserSurname -- Display user names always through 'nameWidget displayName surname'
displayName UserDisplayName -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained)
email (CI Text) -- Case-insensitive eMail address
ident (CI Text) -- Case-insensitive user-identifier ident (CI Text) -- Case-insensitive user-identifier
authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash) authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
lastAuthentication UTCTime Maybe -- last login date lastAuthentication UTCTime Maybe -- last login date
created UTCTime default=now()
lastLdapSynchronisation UTCTime Maybe
tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null) tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null)
matrikelnummer Text Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...) matrikelnummer UserMatriculation Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...)
email (CI Text) -- Case-insensitive eMail address
displayName Text -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained)
surname Text -- Display user names always through 'nameWidget displayName surname'
firstName Text -- For export in tables, pre-split firstName from displayName firstName Text -- For export in tables, pre-split firstName from displayName
title Text Maybe -- For upcoming name customisation title Text Maybe -- For upcoming name customisation
maxFavourites Int default=12 -- max number of rows with this userId in table "CourseFavourite"; for convenience links; user-defined maxFavourites Int default=12 -- max number of rows with this userId in table "CourseFavourite"; for convenience links; user-defined
@ -23,20 +25,27 @@ User json -- Each Uni2work user has a corresponding row in this table; create
dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" -- preferred Date+Time display format for user; user-defined dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" -- preferred Date+Time display format for user; user-defined
dateFormat DateTimeFormat "default='%d.%m.%Y'" -- preferred Date-only display format for user; user-defined 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 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) 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 mailLanguages MailLanguages "default='[]'::jsonb" -- Preferred language for eMail; i18n not yet implemented; user-defined
notificationSettings NotificationSettings -- Bit-array for which events email notifications are requested by user; user-defined notificationSettings NotificationSettings -- Bit-array for which events email notifications are requested by user; user-defined
UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table warningDays NominalDiffTime default=1209600 -- timedistance to pending deadlines for homepage infos
UniqueEmail email -- Column 'email' can be used as a row-key in this table UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table
deriving Show Eq Generic -- Haskell-specific settings for runtime-value representing a row in memory UniqueEmail email -- Column 'email' can be used as a row-key in this table
UserAdmin -- Each row in this table grants school-specific administrator-rights to a specific user deriving Show Eq Ord Generic -- Haskell-specific settings for runtime-value representing a row in memory
user UserId UserFunction -- Administratively assigned functions (lecturer, admin, evaluation, ...)
school SchoolId user UserId
UniqueUserAdmin user school -- combination of user+school must be unique, i.e. no duplicate rows school SchoolId
UserLecturer -- Each row in this table grants school-specific lecturer-rights to a specific user function SchoolFunction
user UserId UniqueUserFunction user school function
school SchoolId UserExamOffice
UniqueSchoolLecturer user school -- combination of user+school must be unique, i.e. no duplicate rows user UserId
field StudyTermsId
UniqueUserExamOffice user field
UserSchool -- Managed by users themselves, encodes "schools of interest"
user UserId
school SchoolId
isOptOut Bool -- true if this a marker, that the user manually deleted this entry; it should not be recreated automatically
UniqueUserSchool user school
StudyFeatures -- multiple entries possible for students pursuing several degrees at once, usually created upon LDAP login StudyFeatures -- multiple entries possible for students pursuing several degrees at once, usually created upon LDAP login
user UserId user UserId
degree StudyDegreeId -- Abschluss, i.e. Master, Bachelor, etc. degree StudyDegreeId -- Abschluss, i.e. Master, Bachelor, etc.

1825
package-lock.json generated
View File

File diff suppressed because it is too large Load Diff

37
package.json
View File

@ -1,6 +1,6 @@
{ {
"name": "uni2work", "name": "uni2work",
"version": "5.0.2", "version": "5.5.0",
"description": "", "description": "",
"keywords": [], "keywords": [],
"author": "", "author": "",
@ -49,16 +49,17 @@
"defaults" "defaults"
], ],
"devDependencies": { "devDependencies": {
"@babel/cli": "^7.4.4", "@babel/cli": "^7.5.5",
"@babel/core": "^7.4.5", "@babel/core": "^7.5.5",
"@babel/plugin-proposal-class-properties": "^7.4.4", "@babel/plugin-proposal-class-properties": "^7.5.5",
"@babel/plugin-proposal-decorators": "^7.4.4", "@babel/plugin-proposal-decorators": "^7.4.4",
"@babel/preset-env": "^7.4.5", "@babel/plugin-transform-runtime": "^7.5.5",
"@babel/preset-env": "^7.5.5",
"@commitlint/cli": "^8.1.0", "@commitlint/cli": "^8.1.0",
"@commitlint/config-conventional": "^8.0.0", "@commitlint/config-conventional": "^8.1.0",
"autoprefixer": "^9.6.0", "autoprefixer": "^9.6.1",
"babel-core": "^6.26.3", "babel-core": "^6.26.3",
"babel-eslint": "^10.0.1", "babel-eslint": "^10.0.3",
"babel-loader": "^8.0.6", "babel-loader": "^8.0.6",
"babel-plugin-syntax-dynamic-import": "^6.18.0", "babel-plugin-syntax-dynamic-import": "^6.18.0",
"babel-plugin-transform-decorators-legacy": "^1.3.5", "babel-plugin-transform-decorators-legacy": "^1.3.5",
@ -66,9 +67,9 @@
"css-loader": "^2.1.1", "css-loader": "^2.1.1",
"eslint": "^5.16.0", "eslint": "^5.16.0",
"extract-text-webpack-plugin": "^4.0.0-beta.0", "extract-text-webpack-plugin": "^4.0.0-beta.0",
"husky": "^2.4.1", "husky": "^2.7.0",
"jasmine-core": "^3.4.0", "jasmine-core": "^3.4.0",
"karma": "^4.1.0", "karma": "^4.3.0",
"karma-chrome-launcher": "^2.2.0", "karma-chrome-launcher": "^2.2.0",
"karma-cli": "^2.0.0", "karma-cli": "^2.0.0",
"karma-jasmine": "^2.0.1", "karma-jasmine": "^2.0.1",
@ -81,15 +82,19 @@
"npm-run-all": "^4.1.5", "npm-run-all": "^4.1.5",
"null-loader": "^2.0.0", "null-loader": "^2.0.0",
"postcss-loader": "^3.0.0", "postcss-loader": "^3.0.0",
"sass-loader": "^7.1.0", "sass-loader": "^7.3.1",
"standard-version": "^6.0.1", "standard-version": "^6.0.1",
"style-loader": "^0.23.1", "style-loader": "^0.23.1",
"uglifyjs-webpack-plugin": "^2.1.3", "uglifyjs-webpack-plugin": "^2.2.0",
"webpack": "^4.34.0", "webpack": "^4.39.3",
"webpack-cli": "^3.3.4" "webpack-cli": "^3.3.7"
}, },
"dependencies": { "dependencies": {
"flatpickr": "^4.5.7", "@babel/runtime": "^7.5.5",
"npm": "^6.10.1" "moment": "^2.24.0",
"npm": "^6.11.2",
"tail.datetime": "git+https://github.com/uni2work/tail.DateTime.git#master",
"core-js": "^3.2.1",
"whatwg-fetch": "^3.0.0"
} }
} }

4
package.yaml
View File

@ -1,5 +1,5 @@
name: uniworx name: uniworx
version: 5.0.2 version: 5.5.0
dependencies: dependencies:
# Due to a bug in GHC 8.0.1, we block its usage # Due to a bug in GHC 8.0.1, we block its usage
@ -194,7 +194,7 @@ ghc-options:
- -fno-warn-unrecognised-pragmas - -fno-warn-unrecognised-pragmas
- -fno-warn-partial-type-signatures - -fno-warn-partial-type-signatures
- -fno-max-relevant-binds - -fno-max-relevant-binds
- -j3 - -j
when: when:
- condition: flag(pedantic) - condition: flag(pedantic)

32
routes
View File

@ -49,8 +49,8 @@
/users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation /users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation
/users/#CryptoUUIDUser/notifications UserNotificationR GET POST !self /users/#CryptoUUIDUser/notifications UserNotificationR GET POST !self
/users/#CryptoUUIDUser/password UserPasswordR GET POST !selfANDis-pw-hash /users/#CryptoUUIDUser/password UserPasswordR GET POST !selfANDis-pw-hash
!/users/lecturer-invite/new AdminNewLecturerInviteR GET POST !/users/functionary-invite/new AdminNewFunctionaryInviteR GET POST
!/users/lecturer-invite AdminLecturerInviteR GET POST !/users/functionary-invite AdminFunctionaryInviteR GET POST
/admin AdminR GET /admin AdminR GET
/admin/features AdminFeaturesR GET POST /admin/features AdminFeaturesR GET POST
/admin/test AdminTestR GET POST /admin/test AdminTestR GET POST
@ -61,6 +61,7 @@
/info InfoR GET !free /info InfoR GET !free
/info/lecturer InfoLecturerR GET !lecturer /info/lecturer InfoLecturerR GET !lecturer
/info/data DataProtR GET !free /info/data DataProtR GET !free
/info/allocation InfoAllocationR GET !free
/impressum ImpressumR GET !free /impressum ImpressumR GET !free
/version VersionR GET !free /version VersionR GET !free
@ -77,8 +78,16 @@
!/term/#TermId TermCourseListR GET !free !/term/#TermId TermCourseListR GET !free
!/term/#TermId/#SchoolId TermSchoolCourseListR GET !free !/term/#TermId/#SchoolId TermSchoolCourseListR GET !free
/school SchoolListR GET !development /school SchoolListR GET
/school/#SchoolId SchoolShowR GET !development !/school/new SchoolNewR GET POST
/school/#SchoolId SchoolR:
/ SchoolEditR GET POST
/allocation/ AllocationListR GET !free
/allocation/#TermId/#SchoolId/#AllocationShorthand AllocationR:
/ AShowR GET !free
/register ARegisterR POST !time
/course/#CryptoUUIDCourse/apply AApplyR POST !timeANDallocation-registered
-- For Pattern Synonyms see Foundation -- For Pattern Synonyms see Foundation
@ -100,11 +109,11 @@
/notes CNotesR GET POST !corrector -- THIS route is used to check for overall course corrector access! /notes CNotesR GET POST !corrector -- THIS route is used to check for overall course corrector access!
/subs CCorrectionsR GET POST /subs CCorrectionsR GET POST
/subs/assigned CAssignR GET POST /subs/assigned CAssignR GET POST
/ex SheetListR GET !course-registered !materials !corrector /sheet SheetListR GET !course-registered !materials !corrector
/ex/new SheetNewR GET POST /sheet/new SheetNewR GET POST
/ex/current SheetCurrentR GET !course-registered !materials !corrector /sheet/current SheetCurrentR GET !course-registered !materials !corrector
/ex/unassigned SheetOldUnassignedR GET /sheet/unassigned SheetOldUnassignedR GET
/ex/#SheetName SheetR: /sheet/#SheetName SheetR:
/show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor /show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
/show/download SArchiveR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor /show/download SArchiveR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
/edit SEditR GET POST /edit SEditR GET POST
@ -154,8 +163,11 @@
/users/new EAddUserR GET POST /users/new EAddUserR GET POST
/users/invite EInviteR GET POST /users/invite EInviteR GET POST
/register ERegisterR POST !timeANDcourse-registeredAND¬exam-registered !timeANDexam-registeredAND¬exam-result /register ERegisterR POST !timeANDcourse-registeredAND¬exam-registered !timeANDexam-registeredAND¬exam-result
/apps CApplicationsR GET POST
!/apps/files CAppsFilesR GET
/apps/#CryptoFileNameCourseApplication CourseApplicationR: /apps/#CryptoFileNameCourseApplication CourseApplicationR:
/files CAFilesR GET !self !lecturerANDtime / CAEditR GET POST !timeANDself !lecturerANDstaff-time !selfANDread
/files CAFilesR GET !self !lecturerANDstaff-time
/subs CorrectionsR GET POST !corrector !lecturer /subs CorrectionsR GET POST !corrector !lecturer
/subs/upload CorrectionsUploadR GET POST !corrector !lecturer /subs/upload CorrectionsUploadR GET POST !corrector !lecturer

5
src/Application.hs
View File

@ -64,10 +64,6 @@ import qualified Yesod.Core.Types as Yesod (Logger(..))
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Utils.Lens
import Data.Proxy
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import System.Exit import System.Exit
@ -112,6 +108,7 @@ import Handler.CryptoIDDispatch
import Handler.SystemMessage import Handler.SystemMessage
import Handler.Health import Handler.Health
import Handler.Exam import Handler.Exam
import Handler.Allocation
-- This line actually creates our YesodDispatch instance. It is the second half -- This line actually creates our YesodDispatch instance. It is the second half

33
src/Auth/LDAP.hs
View File

@ -2,15 +2,15 @@ module Auth.LDAP
( apLdap ( apLdap
, campusLogin , campusLogin
, CampusUserException(..) , CampusUserException(..)
, campusUser , campusUser, campusUser'
, CampusMessage(..) , CampusMessage(..)
, ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName , ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname , ldapUserMatriculation, ldapUserFirstName, ldapUserSurname
, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName , ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName
, ldapUserSchoolAssociation
) where ) where
import Import.NoFoundation hiding (userEmail, userDisplayName) import Import.NoFoundation
import Control.Lens
import Network.Connection import Network.Connection
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
@ -59,16 +59,17 @@ findUser LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not
, Ldap.derefAliases Ldap.DerefAlways , Ldap.derefAliases Ldap.DerefAlways
] ]
ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName :: Ldap.Attr ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation :: Ldap.Attr
ldapUserPrincipalName = Ldap.Attr "userPrincipalName" ldapUserPrincipalName = Ldap.Attr "userPrincipalName"
ldapUserEmail = Ldap.Attr "mail" ldapUserEmail = Ldap.Attr "mail"
ldapUserDisplayName = Ldap.Attr "displayName" ldapUserDisplayName = Ldap.Attr "displayName"
ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer" ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer"
ldapUserFirstName = Ldap.Attr "givenName" ldapUserFirstName = Ldap.Attr "givenName"
ldapUserSurname = Ldap.Attr "sn" ldapUserSurname = Ldap.Attr "sn"
ldapUserTitle = Ldap.Attr "title" ldapUserTitle = Ldap.Attr "title"
ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy" ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy"
ldapUserFieldName = Ldap.Attr "dfnEduPersonFieldOfStudyString" ldapUserFieldName = Ldap.Attr "dfnEduPersonFieldOfStudyString"
ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString"
data CampusUserException = CampusUserLdapError LdapPoolError data CampusUserException = CampusUserLdapError LdapPoolError
@ -81,6 +82,8 @@ data CampusUserException = CampusUserLdapError LdapPoolError
instance Exception CampusUserException instance Exception CampusUserException
makePrisms ''CampusUserException
campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList []) campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList [])
campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
Ldap.bind ldap ldapDn ldapPassword Ldap.bind ldap ldapDn ldapPassword
@ -106,6 +109,10 @@ campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $
, Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs , Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
] ]
campusUser' :: (MonadBaseControl IO m, MonadCatch m, MonadIO m) => LdapConf -> LdapPool -> User -> m (Maybe (Ldap.AttrList []))
campusUser' conf pool User{userIdent}
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser conf pool (Creds apLdap (CI.original userIdent) [])
campusForm :: ( RenderMessage site FormMessage campusForm :: ( RenderMessage site FormMessage
, RenderMessage site CampusMessage , RenderMessage site CampusMessage

19
src/Colonnade/Instances.hs Normal file
View File

@ -0,0 +1,19 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Colonnade.Instances
(
) where
import ClassyPrelude
import Control.Lens.Indexed (FunctorWithIndex(imap))
import Colonnade.Encode (Colonnade(..), OneColonnade(..))
instance Functor h => FunctorWithIndex (Maybe a) (Colonnade h a) where
imap f (Colonnade ones) = Colonnade $ dimapColonnade' <$> ones
where
dimapColonnade' OneColonnade{..} = OneColonnade
{ oneColonnadeEncode = \x -> f (Just x) $ oneColonnadeEncode x
, oneColonnadeHead = f Nothing <$> oneColonnadeHead
}

22
src/Crypto/Hash/Instances.hs Normal file
View File

@ -0,0 +1,22 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Crypto.Hash.Instances
() where
import ClassyPrelude
import Crypto.Hash
import Database.Persist
import Database.Persist.Sql
import Data.ByteArray (convert)
instance HashAlgorithm hash => PersistField (Digest hash) where
toPersistValue = PersistByteString . convert
fromPersistValue (PersistByteString bs) = maybe (Left "Could not convert Digest from ByteString") Right $ digestFromByteString bs
fromPersistValue _ = Left "Digest values must be converted from PersistByteString"
instance HashAlgorithm hash => PersistFieldSql (Digest hash) where
sqlType _ = SqlBlob

1
src/CryptoID.hs
View File

@ -49,6 +49,7 @@ decCryptoIDs [ ''SubmissionId
, ''ExamPartId , ''ExamPartId
, ''AllocationId , ''AllocationId
, ''CourseApplicationId , ''CourseApplicationId
, ''CourseId
] ]
-- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission" -- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission"

28
src/Data/Bool/Instances.hs Normal file
View File

@ -0,0 +1,28 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Bool.Instances
() where
import ClassyPrelude
import qualified Data.Csv as Csv
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Data.CaseInsensitive.Instances ()
import qualified Data.Text as Text
instance Csv.ToField Bool where
toField True = "t"
toField False = "f"
instance Csv.FromField Bool where
parseField f = do
(CI.map Text.strip -> t :: CI Text) <- Csv.parseField f
(True <$ guard (isTrue t)) <|> (False <$ guard (isFalse t)) <|> fail "Could not decode Bool"
where
isTrue = flip elem
[ "yes", "y", "ja", "j", "wahr", "w", "true", "t", "1" ]
isFalse = flip elem
[ "no", "n", "nein", "falsch", "f", "false", "0" ]

31
src/Data/CryptoID/Instances.hs
View File

@ -13,8 +13,35 @@ import ClassyPrelude
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
instance {-# OVERLAPS #-} ToMarkup s => ToMarkup (CID.CryptoID c (CI s)) where import Web.PathPieces
toMarkup = toMarkup . CI.foldedCase . CID.ciphertext import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..))
import qualified Data.Csv as Csv
instance ToMarkup s => ToMarkup (CID.CryptoID c s) where instance ToMarkup s => ToMarkup (CID.CryptoID c s) where
toMarkup = toMarkup . CID.ciphertext toMarkup = toMarkup . CID.ciphertext
instance {-# OVERLAPS #-} ToMarkup s => ToMarkup (CID.CryptoID c (CI s)) where
toMarkup = toMarkup . CI.foldedCase . CID.ciphertext
instance {-# OVERLAPS #-} ToJSON s => ToJSON (CID.CryptoID c (CI s)) where
toJSON = toJSON . CI.foldedCase . CID.ciphertext
instance {-# OVERLAPS #-} (ToJSON s, ToJSONKey s) => ToJSONKey (CID.CryptoID c (CI s)) where
toJSONKey = case toJSONKey of
ToJSONKeyText toT toE -> ToJSONKeyText (toT . CI.foldedCase . CID.ciphertext) (toE . CI.foldedCase . CID.ciphertext)
ToJSONKeyValue toV toE -> ToJSONKeyValue (toV . CI.foldedCase . CID.ciphertext) (toE . CI.foldedCase . CID.ciphertext)
instance {-# OVERLAPS #-} (PathPiece s, CI.FoldCase s) => PathPiece (CID.CryptoID c (CI s)) where
toPathPiece = toPathPiece . CI.foldedCase . CID.ciphertext
fromPathPiece = fmap (CID.CryptoID . CI.mk) . fromPathPiece
instance Csv.FromField s => Csv.FromField (CID.CryptoID c s) where
parseField = fmap CID.CryptoID . Csv.parseField
instance Csv.ToField s => Csv.ToField (CID.CryptoID c s) where
toField = Csv.toField . CID.ciphertext
instance {-# OVERLAPS #-} (Csv.ToField s, CI.FoldCase s) => Csv.ToField (CID.CryptoID c (CI s)) where
toField = Csv.toField . CI.foldedCase . CID.ciphertext

12
src/Data/Time/Clock/Instances.hs
View File

@ -6,17 +6,27 @@ module Data.Time.Clock.Instances
import ClassyPrelude import ClassyPrelude
import Data.Time.Clock import Database.Persist.Sql
import Data.Proxy
import Data.Binary (Binary) import Data.Binary (Binary)
import qualified Data.Binary as Binary import qualified Data.Binary as Binary
import Data.Time.Clock
import Data.Time.Calendar.Instances () import Data.Time.Calendar.Instances ()
instance Hashable DiffTime where instance Hashable DiffTime where
hashWithSalt s = hashWithSalt s . toRational hashWithSalt s = hashWithSalt s . toRational
instance PersistField NominalDiffTime where
toPersistValue = toPersistValue . toRational
fromPersistValue = fmap fromRational . fromPersistValue
instance PersistFieldSql NominalDiffTime where
sqlType _ = sqlType (Proxy @Rational)
deriving instance Generic UTCTime deriving instance Generic UTCTime
instance Hashable UTCTime instance Hashable UTCTime

12
src/Data/Void/Instances.hs Normal file
View File

@ -0,0 +1,12 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Void.Instances
(
) where
import ClassyPrelude.Yesod
import Data.Void
instance ToContent Void where
toContent = absurd
instance ToTypedContent Void where
toTypedContent = absurd

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

@ -15,10 +15,14 @@ module Database.Esqueleto.Utils
, orderByOrd, orderByEnum , orderByOrd, orderByEnum
, lower, ciEq , lower, ciEq
, selectExists , selectExists
, SqlHashable
, sha256
, maybe
, SqlProject(..)
) where ) where
import ClassyPrelude.Yesod hiding (isInfixOf, any, all, or, and, isJust) import ClassyPrelude.Yesod hiding (isInfixOf, any, all, or, and, isJust, maybe)
import Data.Universe import Data.Universe
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.List as List import qualified Data.List as List
@ -27,6 +31,11 @@ import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Internal.Sql as E import qualified Database.Esqueleto.Internal.Sql as E
import Database.Esqueleto.Utils.TH import Database.Esqueleto.Utils.TH
import qualified Data.Text.Lazy as Lazy (Text)
import qualified Data.ByteString.Lazy as Lazy (ByteString)
import Crypto.Hash (Digest, SHA256)
{-# ANN any ("HLint: ignore Use any" :: String) #-} {-# ANN any ("HLint: ignore Use any" :: String) #-}
{-# ANN all ("HLint: ignore Use all" :: String) #-} {-# ANN all ("HLint: ignore Use all" :: String) #-}
@ -55,6 +64,8 @@ false = E.val False
isJust :: (E.Esqueleto query expr backend, PersistField typ) => expr (E.Value (Maybe typ)) -> expr (E.Value Bool) isJust :: (E.Esqueleto query expr backend, PersistField typ) => expr (E.Value (Maybe typ)) -> expr (E.Value Bool)
isJust = E.not_ . E.isNothing isJust = E.not_ . E.isNothing
infix 4 `isInfixOf`, `hasInfix`
-- | Check if the first string is contained in the text derived from the second argument -- | Check if the first string is contained in the text derived from the second argument
isInfixOf :: ( E.Esqueleto query expr backend isInfixOf :: ( E.Esqueleto query expr backend
, E.SqlString s1 , E.SqlString s1
@ -153,21 +164,17 @@ mkExistsFilter query row criterias
| otherwise = any (E.exists . query row) $ Set.toList criterias | otherwise = any (E.exists . query row) $ Set.toList criterias
-- | Combine several filters, using logical or -- | Combine several filters, using logical or
anyFilter :: (Foldable f) anyFilter :: Foldable f
=> f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool)) => f (t -> cs -> E.SqlExpr (E.Value Bool))
-> t -> (t -> cs -> E.SqlExpr (E.Value Bool))
-> Set.Set Text
-> E.SqlExpr (E.Value Bool)
anyFilter fltrs needle criterias = F.foldr aux false fltrs anyFilter fltrs needle criterias = F.foldr aux false fltrs
where where
aux fltr acc = fltr needle criterias E.||. acc aux fltr acc = fltr needle criterias E.||. acc
-- | Combine several filters, using logical and -- | Combine several filters, using logical and
allFilter :: (Foldable f) allFilter :: Foldable f
=> f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool)) => f (t -> cs -> E.SqlExpr (E.Value Bool))
-> t -> (t -> cs -> E.SqlExpr (E.Value Bool))
-> Set.Set Text
-> E.SqlExpr (E.Value Bool)
allFilter fltrs needle criterias = F.foldr aux true fltrs allFilter fltrs needle criterias = F.foldr aux true fltrs
where where
aux fltr acc = fltr needle criterias E.&&. acc aux fltr acc = fltr needle criterias E.&&. acc
@ -199,3 +206,41 @@ selectExists query = do
case res of case res of
[E.Value b] -> return b [E.Value b] -> return b
_other -> error "SELECT EXISTS ... returned zero or more than one rows" _other -> error "SELECT EXISTS ... returned zero or more than one rows"
class SqlHashable a
instance SqlHashable Text
instance SqlHashable ByteString
instance SqlHashable Lazy.Text
instance SqlHashable Lazy.ByteString
sha256 :: SqlHashable a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value (Digest SHA256))
sha256 = E.unsafeSqlFunction "digest" . (, E.val "sha256" :: E.SqlExpr (E.Value Text))
maybe :: (PersistField a, PersistField b)
=> E.SqlExpr (E.Value b)
-> (E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b))
-> E.SqlExpr (E.Value (Maybe a))
-> E.SqlExpr (E.Value b)
maybe onNothing onJust val = E.case_
[ E.when_
(E.not_ $ E.isNothing val)
E.then_
(onJust $ E.veryUnsafeCoerceSqlExprValue val)
]
(E.else_ onNothing)
class (PersistEntity entity, PersistField value) => SqlProject entity value entity' value' | entity value entity' -> value', entity value value' -> entity' where
sqlProject :: E.SqlExpr entity' -> EntityField entity value -> E.SqlExpr (E.Value value')
unSqlProject :: forall p1 p2. p1 entity -> p2 entity' -> value -> value'
instance (PersistEntity val, PersistField typ) => SqlProject val typ (E.Entity val) typ where
sqlProject = (E.^.)
unSqlProject _ _ = id
instance (PersistEntity val, PersistField typ) => SqlProject val typ (Maybe (E.Entity val)) (Maybe typ) where
sqlProject = (E.?.)
unSqlProject _ _ = Just

401
src/Foundation.hs
View File

@ -65,7 +65,7 @@ import Control.Monad.Memo.Class (MonadMemo(..), for4)
import qualified Control.Monad.Catch as C import qualified Control.Monad.Catch as C
import Handler.Utils.StudyFeatures import Handler.Utils.StudyFeatures
import Utils.Lens import Handler.Utils.SchoolLdap
import Utils.Form import Utils.Form
import Utils.Sheet import Utils.Sheet
import Utils.SystemMessage import Utils.SystemMessage
@ -152,6 +152,8 @@ deriving instance Generic MaterialR
deriving instance Generic TutorialR deriving instance Generic TutorialR
deriving instance Generic ExamR deriving instance Generic ExamR
deriving instance Generic CourseApplicationR deriving instance Generic CourseApplicationR
deriving instance Generic AllocationR
deriving instance Generic SchoolR
deriving instance Generic (Route UniWorX) deriving instance Generic (Route UniWorX)
-- | Convenient Type Synonyms: -- | Convenient Type Synonyms:
@ -261,6 +263,8 @@ instance RenderMessage UniWorX Int64 where
renderMessage f ls = renderMessage f ls . tshow renderMessage f ls = renderMessage f ls . tshow
instance RenderMessage UniWorX Integer where instance RenderMessage UniWorX Integer where
renderMessage f ls = renderMessage f ls . tshow 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 instance HasResolution a => RenderMessage UniWorX (Fixed a) where
renderMessage f ls = renderMessage f ls . showFixed True renderMessage f ls = renderMessage f ls . showFixed True
@ -281,8 +285,12 @@ instance RenderMessage UniWorX MsgLanguage where
where where
mr = renderMessage foundation ls mr = renderMessage foundation ls
instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where instance RenderMessage UniWorX (UnsupportedAuthPredicate AuthTag (Route UniWorX)) where
renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route) renderMessage f ls (UnsupportedAuthPredicate tag route) = mr . MsgUnsupportedAuthPredicate (mr tag) $ Text.intercalate "/" pieces
where
mr :: forall msg. RenderMessage UniWorX msg => msg -> Text
mr = renderMessage f ls
(pieces, _) = renderRoute route
embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>) embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>)
embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel
@ -304,6 +312,7 @@ embedRenderMessage ''UniWorX ''SubmissionModeDescr
embedRenderMessage ''UniWorX ''UploadModeDescr id embedRenderMessage ''UniWorX ''UploadModeDescr id
embedRenderMessage ''UniWorX ''SecretJSONFieldException id embedRenderMessage ''UniWorX ''SecretJSONFieldException id
embedRenderMessage ''UniWorX ''AFormMessage $ concat . drop 2 . splitCamel embedRenderMessage ''UniWorX ''AFormMessage $ concat . drop 2 . splitCamel
embedRenderMessage ''UniWorX ''SchoolFunction id
embedRenderMessage ''UniWorX ''AuthenticationMode id embedRenderMessage ''UniWorX ''AuthenticationMode id
@ -362,6 +371,11 @@ instance RenderMessage UniWorX a => RenderMessage UniWorX (ExamResult' a) where
mr :: RenderMessage UniWorX msg => msg -> Text mr :: RenderMessage UniWorX msg => msg -> Text
mr = renderMessage foundation ls 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) -- ToMessage instances for converting raw numbers to Text (no internationalization)
@ -371,6 +385,8 @@ instance ToMessage Int64 where
toMessage = tshow toMessage = tshow
instance ToMessage Integer where instance ToMessage Integer where
toMessage = tshow toMessage = tshow
instance ToMessage Natural where
toMessage = tshow
instance HasResolution a => ToMessage (Fixed a) where instance HasResolution a => ToMessage (Fixed a) where
toMessage = toMessage . showFixed True toMessage = toMessage . showFixed True
@ -593,17 +609,36 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isAdmin <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` userAdmin) -> do isAdmin <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` userAdmin) -> do
E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserFunctionSchool
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val authId
E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin) guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
return Authorized return Authorized
-- Allocations: access only to school admins
AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isAdmin <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` userAdmin) -> do
E.on $ allocation E.^. AllocationSchool E.==. userAdmin E.^. UserFunctionSchool
E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val authId
E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
E.&&. allocation E.^. AllocationTerm E.==. E.val tid
E.&&. allocation E.^. AllocationSchool E.==. E.val ssh
E.&&. allocation E.^. AllocationShorthand E.==. E.val ash
guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
return Authorized
-- Schools: access only to school admins
SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isAdmin <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin]
guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
return Authorized
-- other routes: access to any admin is granted here -- other routes: access to any admin is granted here
_other -> $cachedHereBinary mAuthId . exceptT return return $ do _other -> $cachedHereBinary mAuthId . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
adrights <- lift $ selectFirst [UserAdminUser ==. authId] [] adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] []
guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin) guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
return Authorized return Authorized
tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $ tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $
@ -612,10 +647,9 @@ tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
AdminHijackUserR cID -> exceptT return return $ do AdminHijackUserR cID -> exceptT return return $ do
myUid <- maybeExceptT AuthenticationRequired $ return mAuthId myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
uid <- decrypt cID uid <- decrypt cID
otherSchoolsAdmin <- lift $ Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] [] otherSchoolsFunctions <- lift $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid] []
otherSchoolsLecturer <- lift $ Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] [] mySchools <- lift $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. myUid, UserFunctionFunction ==. SchoolAdmin] []
mySchools <- lift $ Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. myUid] [] guardMExceptT (otherSchoolsFunctions `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation)
guardMExceptT ((otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation)
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthNoEscalation r r -> $unsupportedAuthPredicate AuthNoEscalation r
tagAccessPredicate AuthDeprecated = APHandler $ \_ r _ -> do tagAccessPredicate AuthDeprecated = APHandler $ \_ r _ -> do
@ -641,10 +675,22 @@ tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer) guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer)
return Authorized return Authorized
AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isLecturer <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` allocationCourse `E.InnerJoin` course `E.InnerJoin` lecturer) -> do
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse
E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation
E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
E.&&. allocation E.^. AllocationTerm E.==. E.val tid
E.&&. allocation E.^. AllocationSchool E.==. E.val ssh
E.&&. allocation E.^. AllocationShorthand E.==. E.val ash
guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedAllocationLecturer)
return Authorized
-- lecturer for any school will do -- lecturer for any school will do
_ -> $cachedHereBinary mAuthId . exceptT return return $ do _ -> $cachedHereBinary mAuthId . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] [] void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolLecturer] []
return Authorized return Authorized
tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
@ -712,8 +758,6 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
return Authorized return Authorized
CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn
@ -823,8 +867,33 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
return Authorized return Authorized
_other -> unauthorizedI MsgUnauthorizedCourseTime _other -> unauthorizedI MsgUnauthorizedCourseTime
CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do
Entity course Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course
allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation
case allocation of
Nothing -> do
cTime <- liftIO getCurrentTime
guard $ maybe False (cTime >=) courseRegisterFrom
guard $ maybe True (cTime <=) courseRegisterTo
Just Allocation{..} -> do
cTime <- liftIO getCurrentTime
guard $ NTop allocationRegisterFrom <= NTop (Just cTime)
guard $ NTop (Just cTime) <= NTop allocationRegisterTo
return Authorized
AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do
-- Checks `registerFrom` and `registerTo`, override as further routes become available
now <- liftIO getCurrentTime
Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash
guard $ NTop allocationRegisterFrom <= NTop (Just now)
guard $ NTop (Just now) <= NTop allocationRegisterTo
return Authorized
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
smId <- decrypt cID smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId
cTime <- (NTop . Just) <$> liftIO getCurrentTime cTime <- (NTop . Just) <$> liftIO getCurrentTime
guard $ NTop systemMessageFrom <= cTime guard $ NTop systemMessageFrom <= cTime
@ -832,6 +901,30 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthTime r r -> $unsupportedAuthPredicate AuthTime r
tagAccessPredicate AuthStaffTime = APDB $ \_ route _ -> case route of
CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course
allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation
case allocation of
Nothing -> return ()
Just Allocation{..} -> do
cTime <- liftIO getCurrentTime
guard $ NTop allocationStaffAllocationFrom <= NTop (Just cTime)
guard $ NTop (Just cTime) <= NTop allocationStaffAllocationTo
return Authorized
AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do
-- Checks `registerFrom` and `registerTo`, override as further routes become available
now <- liftIO getCurrentTime
Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash
guard $ NTop allocationStaffAllocationFrom <= NTop (Just now)
guard $ NTop (Just now) <= NTop allocationStaffAllocationTo
return Authorized
r -> $unsupportedAuthPredicate AuthStaffTime r
tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of
CourseR tid ssh csh CRegisterR -> do CourseR tid ssh csh CRegisterR -> do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
@ -969,12 +1062,20 @@ tagAccessPredicate AuthExamResult = APDB $ \mAuthId route _ -> case route of
guardMExceptT hasResult (unauthorizedI MsgUnauthorizedExamResult) guardMExceptT hasResult (unauthorizedI MsgUnauthorizedExamResult)
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthExamRegistered r r -> $unsupportedAuthPredicate AuthExamRegistered r
tagAccessPredicate AuthAllocationRegistered = APDB $ \mAuthId route _ -> case route of
AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegistered) $ do
uid <- hoistMaybe mAuthId
aId <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getKeyBy $ TermSchoolAllocationShort tid ssh ash
void . MaybeT . $cachedHereBinary (uid, aId) . getKeyBy $ UniqueAllocationUser aId uid
return Authorized
r -> $unsupportedAuthPredicate AuthAllocationRegistered r
tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do
cTime <- liftIO getCurrentTime
let authorizedIfExists f = do let authorizedIfExists f = do
[E.Value ok] <- lift . E.select . return . E.exists $ E.from f [E.Value ok] <- lift . E.select . return . E.exists $ E.from f
whenExceptT ok Authorized whenExceptT ok Authorized
participant <- decrypt cID participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID
-- participant is currently registered -- participant is currently registered
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
@ -1030,6 +1131,17 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is applicant for this course
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \((course `E.InnerJoin` courseApplication) `E.LeftOuterJoin` allocation) -> do
E.on $ allocation E.?. AllocationId E.==. courseApplication E.^. CourseApplicationAllocation
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val participant
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.where_ $ E.maybe E.true (E.maybe E.false $ \f -> f E.<=. E.val cTime) (allocation E.?. AllocationStaffAllocationFrom)
E.&&. E.maybe E.true (E.maybe E.true $ \t -> t E.>=. E.val cTime) (allocation E.?. AllocationStaffAllocationTo)
unauthorizedI MsgUnauthorizedParticipant unauthorizedI MsgUnauthorizedParticipant
r -> $unsupportedAuthPredicate AuthParticipant r r -> $unsupportedAuthPredicate AuthParticipant r
tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of
@ -1105,20 +1217,21 @@ tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r
tagAccessPredicate AuthSelf = APDB $ \mAuthId route _ -> exceptT return return $ do tagAccessPredicate AuthSelf = APDB $ \mAuthId route _ -> exceptT return return $ do
referencedUser <- case route of referencedUser' <- case route of
AdminUserR cID -> decrypt cID AdminUserR cID -> return $ Left cID
AdminUserDeleteR cID -> decrypt cID AdminUserDeleteR cID -> return $ Left cID
AdminHijackUserR cID -> decrypt cID AdminHijackUserR cID -> return $ Left cID
UserNotificationR cID -> decrypt cID UserNotificationR cID -> return $ Left cID
UserPasswordR cID -> decrypt cID UserPasswordR cID -> return $ Left cID
CourseR _ _ _ (CUserR cID) -> decrypt cID CourseR _ _ _ (CUserR cID) -> return $ Left cID
CApplicationR _ _ _ cID _ -> do CApplicationR _ _ _ cID _ -> do
appId <- decrypt cID appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID
application <- $cachedHereBinary appId . lift $ get appId CourseApplication{..} <- maybeMExceptT (unauthorizedI MsgUnauthorizedSelf) . $cachedHereBinary appId $ get appId
case application of return $ Right courseApplicationUser
Nothing -> throwError =<< unauthorizedI MsgUnauthorizedSelf
Just CourseApplication{..} -> return courseApplicationUser
_other -> throwError =<< $unsupportedAuthPredicate AuthSelf route _other -> throwError =<< $unsupportedAuthPredicate AuthSelf route
referencedUser <- case referencedUser' of
Right uid -> return uid
Left cID -> catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID
case mAuthId of case mAuthId of
Just uid Just uid
| uid == referencedUser -> return Authorized | uid == referencedUser -> return Authorized
@ -1133,7 +1246,7 @@ tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do
UserPasswordR cID -> return cID UserPasswordR cID -> return cID
CourseR _ _ _ (CUserR cID) -> return cID CourseR _ _ _ (CUserR cID) -> return cID
_other -> throwError =<< $unsupportedAuthPredicate AuthIsLDAP route _other -> throwError =<< $unsupportedAuthPredicate AuthIsLDAP route
referencedUser' <- decrypt referencedUser referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
maybeTMExceptT (unauthorizedI MsgUnauthorizedLDAP) $ do maybeTMExceptT (unauthorizedI MsgUnauthorizedLDAP) $ do
User{..} <- MaybeT $ get referencedUser' User{..} <- MaybeT $ get referencedUser'
guard $ userAuthentication == AuthLDAP guard $ userAuthentication == AuthLDAP
@ -1147,14 +1260,14 @@ tagAccessPredicate AuthIsPWHash = APDB $ \_ route _ -> exceptT return return $ d
UserPasswordR cID -> return cID UserPasswordR cID -> return cID
CourseR _ _ _ (CUserR cID) -> return cID CourseR _ _ _ (CUserR cID) -> return cID
_other -> throwError =<< $unsupportedAuthPredicate AuthIsPWHash route _other -> throwError =<< $unsupportedAuthPredicate AuthIsPWHash route
referencedUser' <- decrypt referencedUser referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
maybeTMExceptT (unauthorizedI MsgUnauthorizedPWHash) $ do maybeTMExceptT (unauthorizedI MsgUnauthorizedPWHash) $ do
User{..} <- MaybeT $ get referencedUser' User{..} <- MaybeT $ get referencedUser'
guard $ is _AuthPWHash userAuthentication guard $ is _AuthPWHash userAuthentication
return Authorized return Authorized
tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
smId <- decrypt cID smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId
let isAuthenticated = isJust mAuthId let isAuthenticated = isJust mAuthId
guard $ not systemMessageAuthenticatedOnly || isAuthenticated guard $ not systemMessageAuthenticatedOnly || isAuthenticated
@ -1575,6 +1688,8 @@ siteLayout' headingOverride widget = do
hasPageActions = hasPrimaryPageActions || hasSecondaryPageActions hasPageActions = hasPrimaryPageActions || hasSecondaryPageActions
hasSecondaryPageActions = any (is _PageActionSecondary) $ toListOf (traverse . _1 . _menuItemType) menuTypes hasSecondaryPageActions = any (is _PageActionSecondary) $ toListOf (traverse . _1 . _menuItemType) menuTypes
hasPrimaryPageActions = any (is _PageActionPrime) $ toListOf (traverse . _1 . _menuItemType) menuTypes hasPrimaryPageActions = any (is _PageActionPrime) $ toListOf (traverse . _1 . _menuItemType) menuTypes
contentRibbon :: Maybe Widget
contentRibbon = fmap toWidget appRibbon
MsgRenderer mr <- getMsgRenderer MsgRenderer mr <- getMsgRenderer
let let
@ -1588,7 +1703,6 @@ siteLayout' headingOverride widget = do
addStylesheet $ StaticR bundles_css_vendor_css addStylesheet $ StaticR bundles_css_vendor_css
addStylesheet $ StaticR bundles_css_main_css addStylesheet $ StaticR bundles_css_main_css
-- JavaScript -- JavaScript
addScript $ StaticR bundles_js_polyfills_js
addScript $ StaticR bundles_js_vendor_js addScript $ StaticR bundles_js_vendor_js
addScript $ StaticR bundles_js_main_js addScript $ StaticR bundles_js_main_js
toWidget $(juliusFile "templates/i18n.julius") toWidget $(juliusFile "templates/i18n.julius")
@ -1633,9 +1747,14 @@ instance YesodBreadcrumbs UniWorX where
breadcrumb AdminTestR = return ("Test" , Just AdminR) breadcrumb AdminTestR = return ("Test" , Just AdminR)
breadcrumb AdminErrMsgR = return ("Test" , Just AdminR) breadcrumb AdminErrMsgR = return ("Test" , Just AdminR)
breadcrumb SchoolListR = return ("Institute" , Just AdminR)
breadcrumb (SchoolR ssh SchoolEditR) = return (original (unSchoolKey ssh), Just SchoolListR)
breadcrumb SchoolNewR = return ("Neu" , Just SchoolListR)
breadcrumb InfoR = return ("Information" , Nothing) breadcrumb InfoR = return ("Information" , Nothing)
breadcrumb InfoLecturerR = return ("Veranstalter" , Just InfoR) breadcrumb InfoLecturerR = return ("Veranstalter" , Just InfoR)
breadcrumb DataProtR = return ("Datenschutz" , Just InfoR) breadcrumb DataProtR = return ("Datenschutz" , Just InfoR)
breadcrumb InfoAllocationR = return ("Zentralanmeldungen", Just InfoR)
breadcrumb ImpressumR = return ("Impressum" , Just InfoR) breadcrumb ImpressumR = return ("Impressum" , Just InfoR)
breadcrumb VersionR = return ("Versionsgeschichte", Just InfoR) breadcrumb VersionR = return ("Versionsgeschichte", Just InfoR)
@ -1659,6 +1778,12 @@ instance YesodBreadcrumbs UniWorX where
breadcrumb (TermSchoolCourseListR tid ssh) = return (original $ unSchoolKey ssh, Just $ TermCourseListR tid) breadcrumb (TermSchoolCourseListR tid ssh) = return (original $ unSchoolKey ssh, Just $ TermCourseListR tid)
breadcrumb AllocationListR = return ("Zentralanmeldungen", Just HomeR)
breadcrumb (AllocationR tid ssh ash AShowR) = do
mr <- getMessageRender
Entity _ Allocation{allocationName} <- runDB . getBy404 $ TermSchoolAllocationShort tid ssh ash
return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{original (unSchoolKey ssh)})|], Just $ AllocationListR)
breadcrumb CourseListR = return ("Kurse" , Nothing) breadcrumb CourseListR = return ("Kurse" , Nothing)
breadcrumb CourseNewR = return ("Neu" , Just CourseListR) breadcrumb CourseNewR = return ("Neu" , Just CourseListR)
breadcrumb (CourseR tid ssh csh CShowR) = return (original csh, Just $ TermSchoolCourseListR tid ssh) breadcrumb (CourseR tid ssh csh CShowR) = return (original csh, Just $ TermSchoolCourseListR tid ssh)
@ -1681,6 +1806,10 @@ instance YesodBreadcrumbs UniWorX where
breadcrumb (CourseR tid ssh csh CExamListR) = return ("Prüfungen", Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh CExamListR) = return ("Prüfungen", Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid ssh csh CExamNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CExamListR) breadcrumb (CourseR tid ssh csh CExamNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CExamListR)
breadcrumb (CourseR tid ssh csh CApplicationsR) = return ("Bewerbungen", Just $ CourseR tid ssh csh CShowR)
breadcrumb (CApplicationR tid ssh csh _ CAEditR) = return ("Bewerbung", Just $ CourseR tid ssh csh CApplicationsR)
breadcrumb (CExamR tid ssh csh examn EShowR) = return (original examn, Just $ CourseR tid ssh csh CExamListR) breadcrumb (CExamR tid ssh csh examn EShowR) = return (original examn, Just $ CourseR tid ssh csh CExamListR)
breadcrumb (CExamR tid ssh csh examn EEditR) = return ("Bearbeiten", Just $ CExamR tid ssh csh examn EShowR) breadcrumb (CExamR tid ssh csh examn EEditR) = return ("Bearbeiten", Just $ CExamR tid ssh csh examn EShowR)
breadcrumb (CExamR tid ssh csh examn EUsersR) = return ("Teilnehmer", Just $ CExamR tid ssh csh examn EShowR) breadcrumb (CExamR tid ssh csh examn EUsersR) = return ("Teilnehmer", Just $ CExamR tid ssh csh examn EShowR)
@ -1875,15 +2004,33 @@ pageActions (HomeR) =
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, MenuItem , MenuItem
{ menuItemType = PageActionPrime { menuItemType = PageActionPrime
, menuItemLabel = MsgAdminHeading , menuItemLabel = MsgMenuOpenCourses
, menuItemIcon = Just "screwdriver" , menuItemIcon = Nothing
, menuItemRoute = SomeRoute AdminR , menuItemRoute = SomeRoute (CourseListR, [("courses-openregistration", "True")])
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, MenuItem , MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuOpenAllocations
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute (AllocationListR, [("allocations-active", "True")])
, menuItemModal = False
, menuItemAccessCallback' = return True
}
]
pageActions (AdminR) =
[ MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSchoolList
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute SchoolListR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime { menuItemType = PageActionPrime
, menuItemLabel = MsgAdminFeaturesHeading , menuItemLabel = MsgAdminFeaturesHeading
, menuItemIcon = Nothing , menuItemIcon = Nothing
@ -1907,40 +2054,6 @@ pageActions (HomeR) =
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
]
pageActions (AdminR) =
[ MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgAdminFeaturesHeading
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute AdminFeaturesR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuMessageList
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute MessageListR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgErrMsgHeading
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute AdminErrMsgR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuUsers
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute UsersR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem , MenuItem
{ menuItemType = PageActionSecondary { menuItemType = PageActionSecondary
, menuItemLabel = MsgMenuAdminTest , menuItemLabel = MsgMenuAdminTest
@ -1950,12 +2063,22 @@ pageActions (AdminR) =
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (SchoolListR) =
[ MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSchoolNew
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute SchoolNewR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
]
pageActions (UsersR) = pageActions (UsersR) =
[ MenuItem [ MenuItem
{ menuItemType = PageActionPrime { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuLecturerInvite , menuItemLabel = MsgMenuLecturerInvite
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = SomeRoute AdminNewLecturerInviteR , menuItemRoute = SomeRoute AdminNewFunctionaryInviteR
, menuItemModal = True , menuItemModal = True
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
@ -2079,7 +2202,7 @@ pageActions (TermCourseListR tid) =
] ]
pageActions (TermSchoolCourseListR _tid _ssh) = pageActions (TermSchoolCourseListR _tid _ssh) =
[ MenuItem [ MenuItem
{ menuItemType = PageActionPrime { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCourseNew , menuItemLabel = MsgMenuCourseNew
, menuItemIcon = Just "book" , menuItemIcon = Just "book"
, menuItemRoute = SomeRoute CourseNewR , menuItemRoute = SomeRoute CourseNewR
@ -2087,6 +2210,16 @@ pageActions (TermSchoolCourseListR _tid _ssh) =
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (AllocationR _tid _ssh _ash AShowR) =
[ MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuAllocationInfo
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute InfoAllocationR
, menuItemModal = True
, menuItemAccessCallback' = return True
}
]
pageActions (CourseListR) = pageActions (CourseListR) =
[ MenuItem [ MenuItem
{ menuItemType = PageActionPrime { menuItemType = PageActionPrime
@ -2096,6 +2229,14 @@ pageActions (CourseListR) =
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuAllocationList
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute AllocationListR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
] ]
pageActions (CourseNewR) = [ pageActions (CourseNewR) = [
MenuItem MenuItem
@ -2174,6 +2315,28 @@ pageActions (CourseR tid ssh csh CShowR) =
anyM examNames $ examAccess . E.unValue anyM examNames $ examAccess . E.unValue
in runDB $ lecturerAccess `or2M` existsVisible in runDB $ lecturerAccess `or2M` existsVisible
} }
, MenuItem
{ menuItemType = PageActionSecondary
, menuItemLabel = MsgMenuCourseApplications
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CApplicationsR
, menuItemModal = False
, menuItemAccessCallback' =
let courseWhere course = course <$ do
E.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
existsApplications = E.selectExists . E.from $ \(course `E.InnerJoin` courseApplication) -> do
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
void $ courseWhere course
courseApplications = fmap (any E.unValue) . E.select . E.from $ \course -> do
void $ courseWhere course
return $ course E.^. CourseApplicationsRequired
courseAllocation = E.selectExists . E.from $ \(course `E.InnerJoin` allocationCourse) -> do
E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse
void $ courseWhere course
in runDB $ courseAllocation `or2M` courseApplications `or2M` existsApplications
}
, MenuItem , MenuItem
{ menuItemType = PageActionSecondary { menuItemType = PageActionSecondary
, menuItemLabel = MsgMenuCourseMembers , menuItemLabel = MsgMenuCourseMembers
@ -2590,6 +2753,28 @@ pageActions (CSheetR tid ssh csh shn SCorrR) =
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (CourseR tid ssh csh CApplicationsR) =
[ MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCourseApplicationsFiles
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CAppsFilesR
, menuItemModal = False
, menuItemAccessCallback'
= let appAccess (E.Value appId) = do
cID <- encrypt appId
hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR
appSource = E.selectSource . E.from $ \(course `E.InnerJoin` courseApplication) -> do
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
E.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.where_ . E.exists . E.from $ \courseApplicationFile ->
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. courseApplication E.^. CourseApplicationId
return $ courseApplication E.^. CourseApplicationId
in runDB . runConduit $ appSource .| anyMC appAccess
}
]
pageActions (CorrectionsR) = pageActions (CorrectionsR) =
[ MenuItem [ MenuItem
{ menuItemType = PageActionPrime { menuItemType = PageActionPrime
@ -2721,13 +2906,6 @@ pageHeading (TermSchoolCourseListR tid ssh)
School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh
i18nHeading $ MsgTermSchoolCourseListHeading tid school i18nHeading $ MsgTermSchoolCourseListHeading tid school
pageHeading (SchoolListR)
= Just $ i18nHeading MsgSchoolListHeading
pageHeading (SchoolShowR ssh)
= Just $ do
School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh
i18nHeading $ MsgSchoolHeading school
pageHeading (CourseListR) pageHeading (CourseListR)
= Just $ i18nHeading $ MsgCourseListTitle = Just $ i18nHeading $ MsgCourseListTitle
pageHeading CourseNewR pageHeading CourseNewR
@ -2866,7 +3044,8 @@ data CampusUserConversionException
| CampusUserInvalidSurname | CampusUserInvalidSurname
| CampusUserInvalidTitle | CampusUserInvalidTitle
| CampusUserInvalidMatriculation | CampusUserInvalidMatriculation
| CampusUserInvalidFeaturesOfStudy String | CampusUserInvalidFeaturesOfStudy Text
| CampusUserInvalidAssociatedSchools Text
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance Exception CampusUserConversionException instance Exception CampusUserConversionException
@ -2940,15 +3119,19 @@ upsertCampusUser ldapData Creds{..} = do
, userDateFormat = userDefaultDateFormat , userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat , userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles , userDownloadFiles = userDefaultDownloadFiles
, userWarningDays = userDefaultWarningDays
, userNotificationSettings = def , userNotificationSettings = def
, userMailLanguages = def , userMailLanguages = def
, userTokensIssuedAfter = Nothing , userTokensIssuedAfter = Nothing
, userCreated = now
, userLastLdapSynchronisation = Just now
, .. , ..
} }
userUpdate = [ UserMatrikelnummer =. userMatrikelnummer userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
, UserDisplayName =. userDisplayName , UserDisplayName =. userDisplayName
, UserSurname =. userSurname , UserSurname =. userSurname
, UserEmail =. userEmail , UserEmail =. userEmail
, UserLastLdapSynchronisation =. Just now
] ++ ] ++
[ UserLastAuthentication =. Just now | not isDummy ] [ UserLastAuthentication =. Just now | not isDummy ]
@ -2970,7 +3153,7 @@ upsertCampusUser ldapData Creds{..} = do
Right str <- return $ Text.decodeUtf8' v' Right str <- return $ Text.decodeUtf8' v'
return str return str
fs <- either (throwM . CampusUserInvalidFeaturesOfStudy . unpack) return userStudyFeatures fs <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userStudyFeatures
let let
studyTermCandidates = Set.fromList $ do studyTermCandidates = Set.fromList $ do
@ -3000,6 +3183,36 @@ upsertCampusUser ldapData Creds{..} = do
insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
void $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True] void $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True]
associateUserSchoolsByTerms userId
let
userAssociatedSchools = fmap concat $ forM userAssociatedSchools' parseLdapSchools
userAssociatedSchools' = do
(k, v) <- ldapData
guard $ k == ldapUserSchoolAssociation
v' <- v
Right str <- return $ Text.decodeUtf8' v'
return str
ss <- either (throwM . CampusUserInvalidAssociatedSchools . tshow) return userAssociatedSchools
forM_ ss $ \frag -> void . runMaybeT $ do
let
exactMatch = MaybeT . getBy $ UniqueOrgUnit frag
infixMatch = (hoistMaybe . preview _head =<<) . lift . E.select . E.from $ \schoolLdap -> do
E.where_ $ E.val frag `E.isInfixOf` schoolLdap E.^. SchoolLdapOrgUnit
E.&&. E.not_ (E.isNothing $ schoolLdap E.^. SchoolLdapSchool)
return schoolLdap
Entity _ SchoolLdap{..} <- exactMatch <|> infixMatch
ssh <- hoistMaybe schoolLdapSchool
lift . void $ insertUnique UserSchool
{ userSchoolUser = userId
, userSchoolSchool = ssh
, userSchoolIsOptOut = False
}
forM_ ss $ void . insertUnique . SchoolLdap Nothing
return user return user
where where
@ -3007,6 +3220,19 @@ upsertCampusUser ldapData Creds{..} = do
isDummy = credsPlugin == "dummy" isDummy = credsPlugin == "dummy"
isPWHash = credsPlugin == "PWHash" isPWHash = credsPlugin == "PWHash"
associateUserSchoolsByTerms :: UserId -> DB ()
associateUserSchoolsByTerms uid = do
sfs <- selectList [StudyFeaturesUser ==. uid] []
forM_ sfs $ \(Entity _ StudyFeatures{..}) -> do
schoolTerms <- selectList [SchoolTermsTerms ==. studyFeaturesField] []
forM_ schoolTerms $ \(Entity _ SchoolTerms{..}) ->
void $ insertUnique UserSchool
{ userSchoolUser = uid
, userSchoolSchool = schoolTermsSchool
, userSchoolIsOptOut = False
}
instance YesodAuth UniWorX where instance YesodAuth UniWorX where
type AuthId UniWorX = UserId type AuthId UniWorX = UserId
@ -3068,6 +3294,11 @@ instance YesodAuth UniWorX where
acceptExisting = do acceptExisting = do
res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
case res of
Authenticated uid
-> associateUserSchoolsByTerms uid
_other
-> return ()
case res of case res of
Authenticated uid Authenticated uid
| not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ] | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]

89
src/Handler/Admin.hs
View File

@ -8,8 +8,6 @@ import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Control.Monad.Trans.Writer (mapWriterT) import Control.Monad.Trans.Writer (mapWriterT)
import Utils.Lens
-- import Data.Time -- import Data.Time
import Data.Char (isDigit) import Data.Char (isDigit)
import qualified Data.Text as Text import qualified Data.Text as Text
@ -21,7 +19,7 @@ import qualified Data.Map as Map
import Database.Persist.Sql (fromSqlKey) import Database.Persist.Sql (fromSqlKey)
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import Database.Esqueleto.Utils as E import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter)
import Handler.Utils.Table.Cells import Handler.Utils.Table.Cells
import qualified Handler.Utils.TermCandidates as Candidates import qualified Handler.Utils.TermCandidates as Candidates
@ -291,6 +289,7 @@ instance Button UniWorX ButtonAdminStudyTerms where
getAdminFeaturesR, postAdminFeaturesR :: Handler Html getAdminFeaturesR, postAdminFeaturesR :: Handler Html
getAdminFeaturesR = postAdminFeaturesR getAdminFeaturesR = postAdminFeaturesR
postAdminFeaturesR = do postAdminFeaturesR = do
uid <- requireAuthId
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("infer-button" :: Text) (buttonForm :: Form ButtonAdminStudyTerms) ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("infer-button" :: Text) (buttonForm :: Form ButtonAdminStudyTerms)
let btnForm = wrapForm btnWdgt def let btnForm = wrapForm btnWdgt def
{ formAction = Just $ SomeRoute AdminFeaturesR { formAction = Just $ SomeRoute AdminFeaturesR
@ -324,11 +323,21 @@ postAdminFeaturesR = do
newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms
( (degreeResult,degreeTable) ( (degreeResult,degreeTable)
, (studyTermsResult,studytermsTable) , (studyTermsResult,studytermsTable)
, ((), candidateTable)) <- runDB $ (,,) , ((), candidateTable)
<$> mkDegreeTable , userSchools) <- runDB $ do
<*> mkStudytermsTable (Set.fromList newStudyTermKeys) schools <- E.select . E.from $ \school -> do
(Set.fromList $ map entityKey infConflicts) E.where_ . E.exists . E.from $ \schoolFunction ->
<*> mkCandidateTable E.where_ $ schoolFunction E.^. UserFunctionSchool E.==. school E.^. SchoolId
E.&&. schoolFunction E.^. UserFunctionUser E.==. E.val uid
E.&&. schoolFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
return school
(,,,)
<$> mkDegreeTable
<*> mkStudytermsTable (Set.fromList newStudyTermKeys)
(Set.fromList $ map entityKey infConflicts)
(Set.fromList schools)
<*> mkCandidateTable
<*> pure schools
-- This needs to happen after calls to `dbTable` so they can short-circuit correctly -- This needs to happen after calls to `dbTable` so they can short-circuit correctly
unless (null infConflicts) $ addMessageI Warning MsgStudyFeatureConflict unless (null infConflicts) $ addMessageI Warning MsgStudyFeatureConflict
@ -343,12 +352,16 @@ postAdminFeaturesR = do
void . runDB $ Map.traverseWithKey updateDegree res void . runDB $ Map.traverseWithKey updateDegree res
addMessageI Success MsgStudyDegreeChangeSuccess addMessageI Success MsgStudyDegreeChangeSuccess
let studyTermsResult' :: FormResult (Map (Key StudyTerms) (Maybe Text, Maybe Text)) let studyTermsResult' :: FormResult (Map (Key StudyTerms) (Maybe Text, Maybe Text, Set SchoolId))
studyTermsResult' = studyTermsResult <&> getDBFormResult studyTermsResult' = studyTermsResult <&> getDBFormResult
(\row -> ( row ^. _dbrOutput . _entityVal . _studyTermsName (\row -> ( row ^. _dbrOutput . _1 . _entityVal . _studyTermsName
, row ^. _dbrOutput . _entityVal . _studyTermsShorthand , row ^. _dbrOutput . _1 . _entityVal . _studyTermsShorthand
, row ^. _dbrOutput . _2
)) ))
updateStudyTerms studyTermsKey (name,short) = update studyTermsKey [StudyTermsName =. name, StudyTermsShorthand =. short] updateStudyTerms studyTermsKey (name,short,schools) = do
update studyTermsKey [StudyTermsName =. name, StudyTermsShorthand =. short]
forM_ schools $ \ssh -> void . insertUnique $ SchoolTerms ssh studyTermsKey
deleteWhere [SchoolTermsTerms ==. studyTermsKey, SchoolTermsSchool /<-. Set.toList schools, SchoolTermsSchool <-. toListOf (folded . _entityKey) userSchools]
formResult studyTermsResult' $ \res -> do formResult studyTermsResult' $ \res -> do
void . runDB $ Map.traverseWithKey updateStudyTerms res void . runDB $ Map.traverseWithKey updateStudyTerms res
addMessageI Success MsgStudyTermsChangeSuccess addMessageI Success MsgStudyTermsChangeSuccess
@ -357,24 +370,41 @@ postAdminFeaturesR = do
setTitleI MsgAdminFeaturesHeading setTitleI MsgAdminFeaturesHeading
$(widgetFile "adminFeatures") $(widgetFile "adminFeatures")
where where
textInputCell lensRes lensDefault = formCell id (return . view (_dbrOutput . _entityKey)) textInputCell :: Ord i
=> Lens' a (Maybe Text)
-> Getter (DBRow r) (Maybe Text)
-> Getter (DBRow r) i
-> DBRow r
-> DBCell (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult i a (DBRow r)))
textInputCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
(\row _mkUnique -> (\(res,fieldView) -> (set lensRes . assertM (not . Text.null) <$> res, fvInput fieldView)) (\row _mkUnique -> (\(res,fieldView) -> (set lensRes . assertM (not . Text.null) <$> res, fvInput fieldView))
<$> mopt textField "" (Just $ row ^. lensDefault) <$> mopt textField "" (Just $ row ^. lensDefault)
) )
checkboxCell :: Ord i
=> Lens' a Bool
-> Getter (DBRow r) Bool
-> Getter (DBRow r) i
-> DBRow r
-> DBCell (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult i a (DBRow r)))
checkboxCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView))
<$> mpopt checkBoxField "" (Just $ row ^. lensDefault)
)
mkDegreeTable :: DB (FormResult (DBFormResult (Key StudyDegree) (Maybe Text, Maybe Text) (DBRow (Entity StudyDegree))), Widget) mkDegreeTable :: DB (FormResult (DBFormResult (Key StudyDegree) (Maybe Text, Maybe Text) (DBRow (Entity StudyDegree))), Widget)
mkDegreeTable = mkDegreeTable =
let dbtIdent = "admin-studydegrees" :: Text let dbtIdent = "admin-studydegrees" :: Text
dbtStyle = def dbtStyle = def
dbtSQLQuery :: E.SqlExpr (Entity StudyDegree) -> E.SqlQuery ( E.SqlExpr (Entity StudyDegree)) dbtSQLQuery :: E.SqlExpr (Entity StudyDegree) -> E.SqlQuery (E.SqlExpr (Entity StudyDegree))
dbtSQLQuery = return dbtSQLQuery = return
dbtRowKey = (E.^. StudyDegreeKey) dbtRowKey = (E.^. StudyDegreeKey)
dbtProj = return dbtProj = return
dbtColonnade = formColonnade $ mconcat dbtColonnade = formColonnade $ mconcat
[ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey)) [ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
, sortable (Just "name") (i18nCell MsgDegreeName) (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName)) , sortable (Just "name") (i18nCell MsgDegreeName) (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName) (_dbrOutput . _entityKey))
, sortable (Just "short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand)) , sortable (Just "short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand) (_dbrOutput . _entityKey))
, dbRow , dbRow
] ]
dbtSorting = Map.fromList dbtSorting = Map.fromList
@ -392,20 +422,29 @@ postAdminFeaturesR = do
dbtCsvDecode = Nothing dbtCsvDecode = Nothing
in dbTable psValidator DBTable{..} in dbTable psValidator DBTable{..}
mkStudytermsTable :: Set (Key StudyTerms) -> Set (Key StudyTerms) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text) (DBRow (Entity StudyTerms))), Widget) mkStudytermsTable :: Set (Key StudyTerms) -> Set (Key StudyTerms) -> Set (Entity School) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text, Set SchoolId) (DBRow (Entity StudyTerms, Set SchoolId))), Widget)
mkStudytermsTable newKeys badKeys = mkStudytermsTable newKeys badKeys schools =
let dbtIdent = "admin-studyterms" :: Text let dbtIdent = "admin-studyterms" :: Text
dbtStyle = def dbtStyle = def
dbtSQLQuery :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery ( E.SqlExpr (Entity StudyTerms)) dbtSQLQuery :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery (E.SqlExpr (Entity StudyTerms))
dbtSQLQuery = return dbtSQLQuery = return
dbtRowKey = (E.^. StudyTermsKey) dbtRowKey = (E.^. StudyTermsKey)
dbtProj = return dbtProj field = do
fieldSchools <- fmap (setOf $ folded . _Value) . lift . E.select . E.from $ \school -> do
E.where_ . E.exists . E.from $ \schoolTerms ->
E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId
E.&&. schoolTerms E.^. SchoolTermsTerms E.==. E.val (field ^. _dbrOutput . _entityKey)
E.where_ $ school E.^. SchoolShorthand `E.in_` E.valList (toListOf (folded . _entityKey . _SchoolId) schools)
return $ school E.^. SchoolId
return $ field & _dbrOutput %~ (, fieldSchools)
dbtColonnade = formColonnade $ mconcat dbtColonnade = formColonnade $ mconcat
[ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _entityVal . _studyTermsKey)) [ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studyTermsKey))
, sortable (Just "isnew") (i18nCell MsgGenericIsNew) (isNewCell . flip Set.member newKeys . view (_dbrOutput . _entityKey)) , sortable (Just "isnew") (i18nCell MsgGenericIsNew) (isNewCell . flip Set.member newKeys . view (_dbrOutput . _1 . _entityKey))
, sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _entityKey)) , sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _1 . _entityKey))
, sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (_dbrOutput . _entityVal . _studyTermsName)) , sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (_dbrOutput . _1 . _entityVal . _studyTermsName) (_dbrOutput . _1 . _entityKey))
, sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyTermsShorthand)) , sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _1 . _entityVal . _studyTermsShorthand) (_dbrOutput . _1 . _entityKey))
, flip foldMap schools $ \(Entity ssh School{schoolName}) ->
sortable Nothing (cell $ toWidget schoolName) (checkboxCell (_3 . at ssh . _Maybe) (_dbrOutput . _2 . at ssh . _Maybe) (_dbrOutput . _1 . _entityKey))
, dbRow , dbRow
] ]
dbtSorting = Map.fromList dbtSorting = Map.fromList

9
src/Handler/Allocation.hs Normal file
View File

@ -0,0 +1,9 @@
module Handler.Allocation
( module Handler.Allocation
) where
import Handler.Allocation.Info as Handler.Allocation
import Handler.Allocation.Show as Handler.Allocation
import Handler.Allocation.Application as Handler.Allocation
import Handler.Allocation.Register as Handler.Allocation
import Handler.Allocation.List as Handler.Allocation

410
src/Handler/Allocation/Application.hs Normal file
View File

@ -0,0 +1,410 @@
module Handler.Allocation.Application
( AllocationApplicationButton(..)
, ApplicationFormView(..)
, ApplicationForm(..)
, ApplicationFormMode(..)
, ApplicationFormException(..)
, applicationForm, editApplicationR
, postAApplyR
) where
import Import hiding (hash)
import Handler.Utils
import qualified Data.Text as Text
import qualified Data.Set as Set
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import qualified Data.Conduit.List as C
import Crypto.Hash (hash)
import Control.Monad.Trans.State (execStateT)
import Control.Monad.State.Class (modify)
data AllocationApplicationButton = BtnAllocationApply
| BtnAllocationApplicationEdit
| BtnAllocationApplicationRetract
| BtnAllocationApplicationRate
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe AllocationApplicationButton
instance Finite AllocationApplicationButton
nullaryPathPiece ''AllocationApplicationButton $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''AllocationApplicationButton id
makePrisms ''AllocationApplicationButton
instance Button UniWorX AllocationApplicationButton where
btnClasses BtnAllocationApplicationRetract = [BCIsButton, BCDanger]
btnClasses _ = [BCIsButton, BCPrimary]
data ApplicationFormView = ApplicationFormView
{ afvPriority :: Maybe (FieldView UniWorX)
, afvForm :: [FieldView UniWorX]
, afvButtons :: ([AllocationApplicationButton], Widget)
}
data ApplicationForm = ApplicationForm
{ afPriority :: Maybe Natural
, afField :: Maybe StudyFeaturesId
, afText :: Maybe Text
, afFiles :: Maybe (Source Handler File)
, afRatingVeto :: Bool
, afRatingPoints :: Maybe ExamGrade
, afRatingComment :: Maybe Text
, afAction :: AllocationApplicationButton
}
data ApplicationFormMode = ApplicationFormMode
{ afmApplicant :: Bool -- ^ Show priority
, afmApplicantEdit :: Bool -- ^ Allow editing text, files, priority (if shown)
, afmLecturer :: Bool -- ^ Allow editing rating
}
data ApplicationFormException = ApplicationFormNoApplication -- ^ Could not fill forced fields of application form with data from application
deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance Exception ApplicationFormException
applicationForm :: (Maybe AllocationId)
-> CourseId
-> UserId
-> ApplicationFormMode -- ^ Which parts of the shared form to display
-> Html -> MForm Handler (FormResult ApplicationForm, ApplicationFormView)
applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf = do
(mApp, coursesNum, Course{..}, maxPrio) <- liftHandlerT . runDB $ do
mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. maId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1]
coursesNum <- fromIntegral . fromMaybe 1 <$> for maId (\aId -> count [AllocationCourseAllocation ==. aId])
course <- getJust cid
[E.Value (fromMaybe 0 -> maxPrio)] <- E.select . E.from $ \courseApplication -> do
E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid
E.&&. courseApplication E.^. CourseApplicationUser E.==. E.val uid
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.val maId
E.&&. E.not_ (E.isNothing $ courseApplication E.^. CourseApplicationAllocationPriority)
return . E.joinV . E.max_ $ courseApplication E.^. CourseApplicationAllocationPriority
return (mApplication, coursesNum, course, maxPrio)
MsgRenderer mr <- getMsgRenderer
let
oldPrio :: Maybe Natural
oldPrio = mApp >>= courseApplicationAllocationPriority . entityVal
coursesNum' = succ maxPrio `max` coursesNum
mkPrioOption :: Natural -> Option Natural
mkPrioOption i = Option
{ optionDisplay = mr . MsgAllocationCoursePriority $ coursesNum' - i
, optionInternalValue = i
, optionExternalValue = tshow i
}
prioOptions :: OptionList Natural
prioOptions = OptionList
{ olOptions = sortOn (Down . optionInternalValue) . map mkPrioOption $ [0 .. pred coursesNum']
, olReadExternal = readMay
}
prioField = selectField' (Just $ SomeMessage MsgAllocationCourseNoApplication) $ return prioOptions
(prioRes, prioView) <- case (isAlloc, afmApplicant, afmApplicantEdit, mApp) of
(True , True , True , Nothing)
-> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just $ oldPrio)
(True , True , True , Just _ )
-> over (_1 . _FormSuccess) Just . over _2 Just <$> mreq prioField (fslI MsgApplicationPriority) oldPrio
(True , True , False, _ )
-> over _2 Just <$> mforcedOpt prioField (fslI MsgApplicationPriority) oldPrio
(True , False, _ , Just _ )
| is _Just oldPrio
-> pure (FormSuccess oldPrio, Nothing)
(True , _ , _ , _ )
-> throwM ApplicationFormNoApplication
(False, _ , _ , _ )
-> pure (FormSuccess Nothing, Nothing)
(fieldRes, fieldView') <- if
| afmApplicantEdit || afmLecturer
-> mreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) (courseApplicationField . entityVal <$> mApp)
| otherwise
-> mforced (studyFeaturesFieldFor Nothing True (maybeToList $ mApp >>= courseApplicationField . entityVal) $ Just uid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) (mApp >>= courseApplicationField . entityVal)
let textField' = convertField (Text.strip . unTextarea) Textarea textareaField
textFs
| is _Just courseApplicationsInstructions
= fslI MsgCourseApplicationText & setTooltip MsgCourseApplicationFollowInstructions
| otherwise
= fslI MsgCourseApplicationText
(textRes, textView) <- if
| not courseApplicationsText
-> pure (FormSuccess Nothing, Nothing)
| not afmApplicantEdit
-> over _2 Just <$> mforcedOpt textField' textFs (mApp >>= courseApplicationText . entityVal)
| otherwise
-> over _2 Just . over (_1 . _FormSuccess) (assertM $ not . Text.null) <$> mopt textField' textFs (Just $ mApp >>= courseApplicationText . entityVal)
hasFiles <- for mApp $ \(Entity appId _)
-> fmap (not . null) . liftHandlerT . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ]
appCID <- for mApp $ encrypt . entityKey
let appFilesInfo = (,) <$> hasFiles <*> appCID
filesLinkView <- if
| fromMaybe False hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit)
-> let filesLinkField = Field{..}
where
fieldParse _ _ = return $ Right Nothing
fieldEnctype = mempty
fieldView theId _ attrs _ _
= [whamlet|
$newline never
$case appFilesInfo
$of Just (True, appCID)
<a ##{theId} *{attrs} href=@{CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR}>
_{MsgCourseApplicationFiles}
$of _
<span ##{theId} *{attrs}>
_{MsgCourseApplicationNoFiles}
|]
in Just . snd <$> mforced filesLinkField (fslI MsgCourseApplicationFiles) ()
| otherwise
-> return Nothing
filesWarningView <- if
| fromMaybe False hasFiles && isn't _NoUpload courseApplicationsFiles && afmApplicantEdit
-> fmap (Just . snd) . formMessage =<< messageIconI Info IconFileUpload MsgCourseApplicationFilesNeedReupload
| otherwise
-> return Nothing
(filesRes, filesView) <-
let mkFs = bool MsgCourseApplicationFile MsgCourseApplicationArchive
in if
| not afmApplicantEdit || is _NoUpload courseApplicationsFiles
-> return $ (FormSuccess Nothing, Nothing)
| otherwise
-> fmap (over _2 $ Just . ($ [])) . aFormToForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles
(vetoRes, vetoView) <- if
| afmLecturer
-> over _2 Just <$> mpopt checkBoxField (fslI MsgApplicationVeto & setTooltip MsgApplicationVetoTip) (Just . fromMaybe False $ courseApplicationRatingVeto . entityVal <$> mApp)
| otherwise
-> return (FormSuccess . fromMaybe False $ courseApplicationRatingVeto . entityVal <$> mApp, Nothing)
(pointsRes, pointsView) <- if
| afmLecturer
-> over _2 Just <$> mopt examGradeField (fslI MsgApplicationRatingPoints & setTooltip MsgApplicationRatingPointsTip) (fmap Just $ mApp >>= courseApplicationRatingPoints . entityVal)
| otherwise
-> return (FormSuccess $ courseApplicationRatingPoints . entityVal =<< mApp, Nothing)
(commentRes, commentView) <- if
| afmLecturer
-> over _2 Just . over (_1 . _FormSuccess) (assertM $ not . Text.null) <$> mopt textField' (fslI MsgApplicationRatingComment & setTooltip (bool MsgApplicationRatingCommentInvisibleTip MsgApplicationRatingCommentVisibleTip courseApplicationsRatingsVisible)) (fmap Just $ mApp >>= courseApplicationRatingComment . entityVal)
| otherwise
-> return (FormSuccess $ courseApplicationRatingComment . entityVal =<< mApp, Nothing)
let
buttons = catMaybes
[ guardOn (not afmApplicantEdit && is _Just mApp && afmLecturer) BtnAllocationApplicationRate
, guardOn ( afmApplicantEdit && is _Just mApp ) BtnAllocationApplicationEdit
, guardOn ( afmApplicantEdit && is _Nothing mApp ) BtnAllocationApply
, guardOn ( afmApplicantEdit && is _Just mApp ) BtnAllocationApplicationRetract
]
(actionRes, buttonsView) <- buttonForm' buttons csrf
ratingSection <- if
| afmLecturer
, afmApplicantEdit
-> Just . set _fvTooltip (Just . toHtml $ mr MsgApplicationRatingSectionSelfTip) . snd <$> formSection MsgApplicationRatingSection
| afmLecturer
-> Just . snd <$> formSection MsgApplicationRatingSection
| otherwise
-> return Nothing
return ( ApplicationForm
<$> prioRes
<*> fieldRes
<*> textRes
<*> filesRes
<*> vetoRes
<*> pointsRes
<*> commentRes
<*> actionRes
, ApplicationFormView
{ afvPriority = prioView
, afvForm = catMaybes $
[ Just fieldView'
, textView
, filesLinkView
, filesWarningView
] ++ maybe [] (map Just) filesView ++
[ ratingSection
, vetoView
, pointsView
, commentView
]
, afvButtons = (buttons, buttonsView)
}
)
editApplicationR :: Maybe AllocationId
-> UserId
-> CourseId
-> Maybe CourseApplicationId
-> ApplicationFormMode
-> (AllocationApplicationButton -> Bool)
-> SomeRoute UniWorX
-> Handler (ApplicationFormView, Enctype)
editApplicationR maId uid cid mAppId afMode allowAction postAction = do
Course{..} <- runDB $ get404 cid
((appRes, appView), appEnc) <- runFormPost $ applicationForm maId cid uid afMode
formResult appRes $ \ApplicationForm{..} -> do
if
| BtnAllocationApply <- afAction
, allowAction afAction
-> runDB $ do
haveOld <- exists [ CourseApplicationCourse ==. cid
, CourseApplicationUser ==. uid
, CourseApplicationAllocation ==. maId
]
when haveOld $
invalidArgsI [MsgCourseApplicationExists]
now <- liftIO getCurrentTime
let rated = afRatingVeto || is _Just afRatingPoints
appId <- insert CourseApplication
{ courseApplicationCourse = cid
, courseApplicationUser = uid
, courseApplicationField = afField
, courseApplicationText = afText
, courseApplicationRatingVeto = afRatingVeto
, courseApplicationRatingPoints = afRatingPoints
, courseApplicationRatingComment = afRatingComment
, courseApplicationAllocation = maId
, courseApplicationAllocationPriority = afPriority
, courseApplicationTime = now
, courseApplicationRatingTime = guardOn rated now
}
let
sinkFile' file = do
fId <- insert file
insert_ $ CourseApplicationFile appId fId
forM_ afFiles $ \afFiles' ->
runConduit $ transPipe liftHandlerT afFiles' .| C.mapM_ sinkFile'
audit $ TransactionCourseApplicationEdit cid uid appId
addMessageI Success $ MsgCourseApplicationCreated courseShorthand
| is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction
, allowAction afAction
, Just appId <- mAppId
-> runDB $ do
now <- liftIO getCurrentTime
changes <- if
| afmApplicantEdit afMode -> do
oldFiles <- Set.fromList . map (courseApplicationFileFile . entityVal) <$> selectList [CourseApplicationFileApplication ==. appId] []
changes <- flip execStateT oldFiles . forM_ afFiles $ \afFiles' ->
let sinkFile' 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)
E.&&. E.maybe
(E.val . is _Nothing $ fileContent file)
(\fc' -> maybe E.false (\fc -> E.sha256 fc' E.==. E.val (hash fc)) $ fileContent file)
(file' E.^. FileContent)
E.&&. file' E.^. FileId `E.in_` E.valList (Set.toList oldFiles)
return $ file' E.^. FileId
if
| [E.Value oldFileId] <- oldFiles'
-> modify $ Set.delete oldFileId
| otherwise
-> do
fId <- lift $ insert file
lift . insert_ $ CourseApplicationFile appId fId
modify $ Set.insert fId
in runConduit $ transPipe liftHandlerT afFiles' .| C.mapM_ sinkFile'
deleteCascadeWhere [ FileId <-. Set.toList (oldFiles `Set.intersection` changes) ]
return changes
| otherwise
-> return Set.empty
oldApp <- get404 appId
let newApp = oldApp
{ courseApplicationField = afField
, courseApplicationText = afText
, courseApplicationRatingVeto = afRatingVeto
, courseApplicationRatingPoints = afRatingPoints
, courseApplicationRatingComment = afRatingComment
, courseApplicationAllocation = maId
, courseApplicationAllocationPriority = afPriority
}
newRating = any (\f -> f oldApp newApp)
[ (/=) `on` courseApplicationRatingVeto
, (/=) `on` courseApplicationRatingPoints
, (/=) `on` courseApplicationRatingComment
]
hasRating = any ($ newApp)
[ courseApplicationRatingVeto
, is _Just . courseApplicationRatingPoints
]
appChanged = any (\f -> f oldApp newApp)
[ (/=) `on` courseApplicationField
, (/=) `on` courseApplicationText
, \_ _ -> not $ Set.null changes
]
newApp' = newApp
& bool id (set _courseApplicationRatingTime Nothing) appChanged
& bool id (set _courseApplicationRatingTime $ Just now) (newRating && hasRating)
& bool id (set _courseApplicationTime now) appChanged
replace appId newApp'
audit $ TransactionCourseApplicationEdit cid uid appId
uncurry addMessageI =<< case (afmLecturer afMode, newRating, hasRating, appChanged) of
(_, False, _, True) -> return (Success, MsgCourseApplicationEdited courseShorthand)
(_, False, _, False) -> return (Info, MsgCourseApplicationNotEdited courseShorthand)
(True, True, True, _) -> return (Success, MsgCourseApplicationRated)
(True, True, False, _) -> return (Success, MsgCourseApplicationRatingDeleted)
(False, True, _, _) -> permissionDenied "rating changed without lecturer rights"
| is _BtnAllocationApplicationRetract afAction
, allowAction afAction
, Just appId <- mAppId
-> runDB $ do
deleteCascade appId
audit $ TransactionCourseApplicationDeleted cid uid appId
addMessageI Success $ MsgCourseApplicationDeleted courseShorthand
| otherwise
-> invalidArgsI [MsgCourseApplicationInvalidAction]
redirect postAction
return (appView, appEnc)
postAApplyR :: TermId -> SchoolId -> AllocationShorthand -> CryptoUUIDCourse -> Handler Void
postAApplyR tid ssh ash cID = do
uid <- requireAuthId
cid <- decrypt cID
(aId, Course{..}) <- runDB $ do
aId <- getKeyBy404 $ TermSchoolAllocationShort tid ssh ash
course <- get404 cid
return (aId, course)
afmLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
let afMode = ApplicationFormMode
{ afmApplicant = True
, afmApplicantEdit = True
, afmLecturer
}
void . editApplicationR (Just aId) uid cid Nothing afMode (== BtnAllocationApply) . SomeRoute $ AllocationR tid ssh ash AShowR :#: cID
invalidArgs ["Application form required"]

13
src/Handler/Allocation/Info.hs Normal file
View File

@ -0,0 +1,13 @@
module Handler.Allocation.Info
( getInfoAllocationR
) where
import Import
import Handler.Utils
getInfoAllocationR :: Handler Html
getInfoAllocationR =
siteLayoutMsg MsgMenuAllocationInfo $ do
setTitleI MsgMenuAllocationInfo
$(i18nWidgetFile "allocation-info")

89
src/Handler/Allocation/List.hs Normal file
View File

@ -0,0 +1,89 @@
module Handler.Allocation.List
( getAllocationListR
) where
import Import
import qualified Database.Esqueleto as E
import Handler.Utils.Table.Columns
import Handler.Utils.Table.Pagination
type AllocationTableExpr = E.SqlExpr (Entity Allocation)
type AllocationTableData = DBRow (Entity Allocation)
allocationListIdent :: Text
allocationListIdent = "allocations"
queryAllocation :: Getter AllocationTableExpr (E.SqlExpr (Entity Allocation))
queryAllocation = id
resultAllocation :: Lens' AllocationTableData (Entity Allocation)
resultAllocation = _dbrOutput
allocationTermLink :: TermId -> SomeRoute UniWorX
allocationTermLink tid = SomeRoute (AllocationListR, [(dbFilterKey allocationListIdent "term", toPathPiece tid)])
allocationSchoolLink :: SchoolId -> SomeRoute UniWorX
allocationSchoolLink ssh = SomeRoute (AllocationListR, [(dbFilterKey allocationListIdent "school", toPathPiece ssh)])
allocationLink :: Allocation -> SomeRoute UniWorX
allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR
getAllocationListR :: Handler Html
getAllocationListR = do
now <- liftIO getCurrentTime
let
dbtSQLQuery :: AllocationTableExpr -> E.SqlQuery _
dbtSQLQuery = return
dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) AllocationTableData
dbtProj = return
dbtRowKey = view $ queryAllocation . to (E.^. AllocationId)
dbtColonnade :: Colonnade Sortable _ _
dbtColonnade = mconcat
[ anchorColonnade (views (resultAllocation . _entityVal . _allocationTerm) allocationTermLink) $ colTermShort (resultAllocation . _entityVal . _allocationTerm)
, anchorColonnade (views (resultAllocation . _entityVal . _allocationSchool) allocationSchoolLink) $ colSchoolShort (resultAllocation . _entityVal . _allocationSchool)
, anchorColonnade (views (resultAllocation . _entityVal) allocationLink) $ colAllocationName (resultAllocation . _entityVal . _allocationName)
]
dbtSorting = mconcat
[ sortTerm $ queryAllocation . to (E.^. AllocationTerm)
, sortSchool $ queryAllocation . to (E.^. AllocationSchool)
, sortAllocationName $ queryAllocation . to (E.^. AllocationName)
]
dbtFilter = mconcat
[ fltrAllocationActive now queryAllocation
, fltrTerm $ queryAllocation . to (E.^. AllocationTerm)
, fltrSchool $ queryAllocation . to (E.^. AllocationSchool)
, fltrAllocation queryAllocation
]
dbtFilterUI = mconcat
[ fltrAllocationActiveUI
, fltrTermUI
, fltrSchoolUI
, fltrAllocationUI
]
dbtStyle = def
{ dbsFilterLayout = defaultDBSFilterLayout
}
dbtParams = def
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
dbtIdent = allocationListIdent
psValidator :: PSValidator _ _
psValidator = def
& defaultSorting [SortDescBy "term", SortAscBy "school", SortAscBy "allocation"]
table <- runDB $ dbTableWidget' psValidator DBTable{..}
siteLayoutMsg MsgAllocationListTitle $ do
setTitleI MsgAllocationListTitle
table

60
src/Handler/Allocation/Register.hs Normal file
View File

@ -0,0 +1,60 @@
module Handler.Allocation.Register
( AllocationRegisterForm(..)
, AllocationRegisterButton(..)
, allocationRegisterForm
, allocationUserToForm
, postARegisterR
) where
import Import
import Handler.Utils.Form
{-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-}
data AllocationRegisterForm = AllocationRegisterForm
{ arfTotalCourses :: Natural
}
allocationRegisterForm :: Maybe AllocationRegisterForm -> AForm Handler AllocationRegisterForm
allocationRegisterForm template
= AllocationRegisterForm
<$> areq (posIntFieldI MsgAllocationTotalCoursesNegative) (fslI MsgAllocationTotalCourses & setTooltip MsgAllocationTotalCoursesTip) (arfTotalCourses <$> template <|> Just 1)
allocationUserToForm :: AllocationUser -> AllocationRegisterForm
allocationUserToForm AllocationUser{..} = AllocationRegisterForm
{ arfTotalCourses = allocationUserTotalCourses
}
data AllocationRegisterButton = BtnAllocationRegister | BtnAllocationRegistrationEdit
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe AllocationRegisterButton
instance Finite AllocationRegisterButton
nullaryPathPiece ''AllocationRegisterButton $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''AllocationRegisterButton id
instance Button UniWorX AllocationRegisterButton where
btnClasses _ = [BCIsButton, BCPrimary]
postARegisterR :: TermId -> SchoolId -> AllocationShorthand -> Handler Void
postARegisterR tid ssh ash = do
uid <- requireAuthId
((registerRes, _), _) <- runFormPost . renderAForm FormStandard $ allocationRegisterForm Nothing
formResult registerRes $ \AllocationRegisterForm{..} -> runDB $ do
aId <- getKeyBy404 $ TermSchoolAllocationShort tid ssh ash
isRegistered <- existsBy $ UniqueAllocationUser aId uid
void $ upsert AllocationUser
{ allocationUserAllocation = aId
, allocationUserUser = uid
, allocationUserTotalCourses = arfTotalCourses
}
[ AllocationUserTotalCourses =. arfTotalCourses
]
if
| isRegistered -> addMessageI Success MsgAllocationRegistrationEdited
| otherwise -> addMessageI Success MsgAllocationRegistered
redirect $ AllocationR tid ssh ash AShowR :#: ("allocation-participation" :: Text)

99
src/Handler/Allocation/Show.hs Normal file
View File

@ -0,0 +1,99 @@
module Handler.Allocation.Show
( getAShowR
) where
import Import
import Handler.Utils
import Handler.Allocation.Register
import Handler.Allocation.Application
import qualified Database.Esqueleto as E
getAShowR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
getAShowR tid ssh ash = do
muid <- maybeAuthId
now <- liftIO getCurrentTime
let
resultCourse :: Simple Field1 a (Entity Course) => Lens' a (Entity Course)
resultCourse = _1
resultCourseApplication :: Simple Field2 a (Maybe (Entity CourseApplication)) => Traversal' a (Entity CourseApplication)
resultCourseApplication = _2 . _Just
resultHasTemplate :: Simple Field3 a (E.Value Bool) => Lens' a Bool
resultHasTemplate = _3 . _Value
(Entity aId Allocation{..}, courses, registration) <- runDB $ do
alloc@(Entity aId _) <- getBy404 $ TermSchoolAllocationShort tid ssh ash
courses <- E.select . E.from $ \((allocationCourse `E.InnerJoin` course) `E.LeftOuterJoin` courseApplication) -> do
E.on $ courseApplication E.?. CourseApplicationCourse E.==. E.just (course E.^. CourseId)
E.&&. courseApplication E.?. CourseApplicationUser E.==. E.val muid
E.&&. courseApplication E.?. CourseApplicationAllocation E.==. E.just (E.just $ E.val aId)
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId
E.orderBy [E.asc $ course E.^. CourseName]
let hasTemplate = E.exists . E.from $ \courseAppInstructionFile ->
E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. course E.^. CourseId
return (course, courseApplication, hasTemplate)
registration <- fmap join . for muid $ getBy . UniqueAllocationUser aId
return (alloc, nubOn (view $ resultCourse . _entityKey) courses, registration)
MsgRenderer mr <- getMsgRenderer
let title = MsgAllocationTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationName
shortTitle = MsgAllocationShortTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationShorthand
-- staffInformation <- anyM courses $ \(view $ resultCourse . _entityVal -> Course{..}) ->
-- hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CApplicationsR
mayRegister <- hasWriteAccessTo $ AllocationR tid ssh ash ARegisterR
(registerForm, registerEnctype) <- generateFormPost . renderAForm FormStandard . allocationRegisterForm $ allocationUserToForm . entityVal <$> registration
let
registerBtn = bool BtnAllocationRegister BtnAllocationRegistrationEdit $ is _Just registration
registerForm' = wrapForm' registerBtn registerForm FormSettings
{ formMethod = POST
, formAction = Just . SomeRoute $ AllocationR tid ssh ash ARegisterR
, formEncoding = registerEnctype
, formAttrs = []
, formSubmit = FormSubmit
, formAnchor = Nothing :: Maybe Text
}
siteLayoutMsg title $ do
setTitleI shortTitle
let courseWidgets = flip map courses $ \cEntry -> do
let Entity cid Course{..} = cEntry ^. resultCourse
hasApplicationTemplate = cEntry ^. resultHasTemplate
mApp = cEntry ^? resultCourseApplication
cID <- encrypt cid :: WidgetT UniWorX IO CryptoUUIDCourse
mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID
isLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
mApplyFormView <- liftHandlerT . for muid $ \uid -> generateFormPost . applicationForm (Just aId) cid uid $ ApplicationFormMode True mayApply isLecturer
tRoute <- case mApp of
Nothing -> return . AllocationR tid ssh ash $ AApplyR cID
Just (Entity appId _) -> CApplicationR courseTerm courseSchool courseShorthand <$> encrypt appId <*> pure CAEditR
let mApplyFormView' = view _1 <$> mApplyFormView
overrideVisible = not mayApply && is _Just mApp
case mApplyFormView of
Just (_, appFormEnctype)
-> wrapForm $(widgetFile "allocation/show/course") FormSettings
{ formMethod = POST
, formAction = Just $ SomeRoute tRoute
, formEncoding = appFormEnctype
, formAttrs = [ ("class", "allocation-course")
]
, formSubmit = FormNoSubmit
, formAnchor = Just cID
}
Nothing
-> let wdgt = $(widgetFile "allocation/show/course")
in [whamlet|
<div .allocation-course ##{toPathPiece cID}>
^{wdgt}
|]
let daysToRegistrationStart = assertM (>0) $ (`diffUTCTime` now) <$> allocationRegisterFrom
allocationInfoModal = modal [whamlet|_{MsgMenuAllocationInfo}|] $ Left $ SomeRoute InfoAllocationR
$(widgetFile "allocation/show")

2
src/Handler/Corrections.hs
View File

@ -12,8 +12,6 @@ import Handler.Utils.SheetType
import Handler.Utils.Delete import Handler.Utils.Delete
-- import Handler.Utils.Zip -- import Handler.Utils.Zip
import Utils.Lens
import Data.List as List (nub, foldl, foldr) import Data.List as List (nub, foldl, foldr)
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set

38
src/Handler/Course/Application.hs
View File

@ -1,37 +1,7 @@
module Handler.Course.Application module Handler.Course.Application
( getCAFilesR ( module Handler.Course.Application
) where ) where
import Import import Handler.Course.Application.List as Handler.Course.Application
import Handler.Course.Application.Files as Handler.Course.Application
import Handler.Utils import Handler.Course.Application.Edit as Handler.Course.Application
import qualified Database.Esqueleto as E
import System.FilePath (addExtension)
import qualified Data.Conduit.List as C
getCAFilesR :: TermId -> SchoolId -> CourseShorthand -> CryptoFileNameCourseApplication -> Handler TypedContent
getCAFilesR tid ssh csh cID = do
appId <- decrypt cID
User{..} <- runDB $ do
CourseApplication{..} <- get404 appId
Course{..} <- get404 courseApplicationCourse
let matches = and
[ tid == courseTerm
, ssh == courseSchool
, csh == courseShorthand
]
unless matches . redirectWith movedPermanently301 $ CApplicationR courseTerm courseSchool courseShorthand cID CAFilesR
get404 courseApplicationUser
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseApplicationArchiveName tid ssh csh cID userDisplayName
let
fsSource = E.selectSource . E.from $ \(courseApplicationFile `E.InnerJoin` file) -> do
E.on $ courseApplicationFile E.^. CourseApplicationFileFile E.==. file E.^. FileId
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. E.val appId
return file
serveSomeFiles archiveName $ fsSource .| C.map entityVal

55
src/Handler/Course/Application/Edit.hs Normal file
View File

@ -0,0 +1,55 @@
module Handler.Course.Application.Edit
( getCAEditR, postCAEditR
) where
import Import
import Handler.Utils
import Handler.Allocation.Application
getCAEditR, postCAEditR :: TermId -> SchoolId -> CourseShorthand -> CryptoFileNameCourseApplication -> Handler Html
getCAEditR = postCAEditR
postCAEditR tid ssh csh cID = do
uid <- requireAuthId
appId <- decrypt cID
(mAlloc, Entity cid Course{..}, CourseApplication{..}, isAdmin, User{..}) <- runDB $ do
course <- getBy404 $ TermSchoolCourseShort tid ssh csh
app <- get404 appId
mAlloc <- traverse getEntity404 $ courseApplicationAllocation app
appUser <- get404 $ courseApplicationUser app
isAdmin <- case mAlloc of
Just alloc -> exists [UserFunctionUser ==. uid, UserFunctionSchool ==. alloc ^. _entityVal . _allocationSchool, UserFunctionFunction ==. SchoolAdmin]
Nothing -> exists [UserFunctionUser ==. uid, UserFunctionSchool ==. course ^. _entityVal . _courseSchool, UserFunctionFunction ==. SchoolAdmin]
return (mAlloc, course, app, isAdmin, appUser)
afmLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
afmApplicantEdit <- hasWriteAccessTo $ CApplicationR tid ssh csh cID CAEditR
courseCID <- encrypt cid :: Handler CryptoUUIDCourse
let afMode = ApplicationFormMode
{ afmApplicant = uid == courseApplicationUser || isAdmin
, afmApplicantEdit
, afmLecturer
}
(ApplicationFormView{..}, appEnc) <- editApplicationR (entityKey <$> mAlloc) uid cid (Just appId) afMode (/= BtnAllocationApply) $ if
| uid == courseApplicationUser
, Just (Entity _ Allocation{..}) <- mAlloc
-> SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: courseCID
| otherwise
-> SomeRoute $ CApplicationR tid ssh csh cID CAEditR
let title = MsgCourseApplicationTitle userDisplayName courseShorthand
siteLayoutMsg title $ do
setTitleI title
wrapForm ((<> snd afvButtons) . renderFieldViews FormStandard . maybe id (:) afvPriority$ afvForm) FormSettings
{ formMethod = POST
, formAction = Just . SomeRoute $ CApplicationR tid ssh csh cID CAEditR
, formEncoding = appEnc
, formAttrs = []
, formSubmit = FormNoSubmit
, formAnchor = Nothing :: Maybe Text
}

108
src/Handler/Course/Application/Files.hs Normal file
View File

@ -0,0 +1,108 @@
module Handler.Course.Application.Files
( getCAFilesR
, getCAppsFilesR
) where
import Import
import Handler.Utils
import System.FilePath (addExtension, (</>))
import qualified Data.Conduit.List as C
import qualified Database.Esqueleto as E
import qualified Data.CaseInsensitive as CI
getCAFilesR :: TermId -> SchoolId -> CourseShorthand -> CryptoFileNameCourseApplication -> Handler TypedContent
getCAFilesR tid ssh csh cID = do
appId <- decrypt cID
User{..} <- runDB $ do
CourseApplication{..} <- get404 appId
Course{..} <- get404 courseApplicationCourse
let matches = and
[ tid == courseTerm
, ssh == courseSchool
, csh == courseShorthand
]
unless matches . redirectWith movedPermanently301 $ CApplicationR courseTerm courseSchool courseShorthand cID CAFilesR
get404 courseApplicationUser
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseApplicationArchiveName tid ssh csh cID userDisplayName
let
fsSource = E.selectSource . E.from $ \(courseApplicationFile `E.InnerJoin` file) -> do
E.on $ courseApplicationFile E.^. CourseApplicationFileFile E.==. file E.^. FileId
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. E.val appId
return file
serveSomeFiles archiveName $ fsSource .| C.map entityVal
getCAppsFilesR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
getCAppsFilesR tid ssh csh = do
runDB . existsBy404 $ TermSchoolCourseShort tid ssh csh
MsgRenderer mr <- getMsgRenderer
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseAllApplicationsArchiveName tid ssh csh
let
fsSource :: Source DB File
fsSource = do
apps <- lift . E.select . E.from $ \((course `E.InnerJoin` courseApplication `E.InnerJoin` user) `E.LeftOuterJoin` allocation) -> do
E.on $ allocation E.?. AllocationId E.==. courseApplication E.^. CourseApplicationAllocation
E.on $ user E.^. UserId E.==. courseApplication E.^. CourseApplicationUser
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
E.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
return (allocation, user, courseApplication)
apps' <- flip filterM apps $ \(_, _, Entity appId _) -> do
cID <- cachedByBinary appId $ encrypt appId
hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR
let
applicationAllocs = setOf (folded . _1) apps'
allocations = applicationAllocs ^.. folded . _Just . _entityVal . $(multifocusG 3) _allocationTerm _allocationSchool _allocationShorthand
allEqualOn :: Eq x => Getter _ x -> Bool
allEqualOn l = maybe True (\x -> allOf (folded . l) (== x) allocations) (allocations ^? _head . l)
mkAllocationDir mbAlloc
| not $ allEqualOn _1
, Just Allocation{..} <- mbAlloc
= (</>) $ unpack [st|#{CI.foldCase (termToText (unTermKey allocationTerm))}-#{CI.foldedCase (unSchoolKey allocationSchool)}-#{CI.foldedCase allocationShorthand}|]
| not $ allEqualOn _2
, Just Allocation{..} <- mbAlloc
= (</>) $ unpack [st|#{CI.foldedCase (unSchoolKey allocationSchool)}-#{CI.foldedCase allocationShorthand}|]
| not $ allEqualOn _3
, Just Allocation{..} <- mbAlloc
= (</>) . unpack $ CI.foldedCase allocationShorthand
| Just Allocation{} <- mbAlloc
, not $ all (is _Just) applicationAllocs
= (</>) . unpack $ mr MsgCourseApplicationsAllocatedDirectory
| Nothing <- mbAlloc
, any (is _Just) applicationAllocs
= (</>) . unpack $ mr MsgCourseApplicationsNotAllocatedDirectory
| otherwise
= id
forM_ apps' $ \(mbAlloc, Entity _ User{..}, Entity appId CourseApplication{..}) -> do
cID <- cachedByBinary appId $ encrypt appId :: _ CryptoFileNameCourseApplication
let mkAppDir = mkAllocationDir (entityVal <$> mbAlloc) . (</>) (unpack [st|#{CI.foldedCase $ ciphertext cID}-#{CI.foldCase userSurname}|])
dirFiles = C.map $ over _fileTitle mkAppDir . entityVal
fileEntitySource = E.selectSource . E.from $ \(courseApplicationFile `E.InnerJoin` file) -> do
E.on $ courseApplicationFile E.^. CourseApplicationFileFile E.==. file E.^. FileId
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. E.val appId
return file
yield File
{ fileModified = courseApplicationTime
, fileTitle = mkAppDir ""
, fileContent = Nothing
}
fileEntitySource .| dirFiles
serveSomeFiles archiveName fsSource

536
src/Handler/Course/Application/List.hs Normal file
View File

@ -0,0 +1,536 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Handler.Course.Application.List
( getCApplicationsR, postCApplicationsR
) where
import Import
import Handler.Utils
import Handler.Utils.Table.Columns
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH
import qualified Data.Csv as Csv
import qualified Data.Text as Text
import qualified Data.Text.Lens as Text
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import qualified Data.Map as Map
import qualified Data.Conduit.List as C
type CourseApplicationsTableExpr = ( E.SqlExpr (Entity CourseApplication)
`E.InnerJoin` E.SqlExpr (Entity User)
)
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Allocation))
`E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity StudyFeatures))
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree))
)
type CourseApplicationsTableData = DBRow ( Entity CourseApplication
, Entity User
, E.Value Bool -- hasFiles
, Maybe (Entity Allocation)
, Maybe (Entity StudyFeatures)
, Maybe (Entity StudyTerms)
, Maybe (Entity StudyDegree)
)
courseApplicationsIdent :: Text
courseApplicationsIdent = "applications"
queryCourseApplication :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity CourseApplication))
queryCourseApplication = to $ $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
queryUser :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity User))
queryUser = to $ $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
queryHasFiles :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool))
queryHasFiles = to $ hasFiles . $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
where
hasFiles appl = E.exists . E.from $ \courseApplicationFile ->
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. appl E.^. CourseApplicationId
queryAllocation :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity Allocation)))
queryAllocation = to $(sqlLOJproj 3 2)
queryStudyFeatures :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyFeatures)))
queryStudyFeatures = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 3 3)
queryStudyTerms :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyTerms)))
queryStudyTerms = to $ $(sqlIJproj 3 2) . $(sqlLOJproj 3 3)
queryStudyDegree :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyDegree)))
queryStudyDegree = to $ $(sqlIJproj 3 3) . $(sqlLOJproj 3 3)
resultCourseApplication :: Lens' CourseApplicationsTableData (Entity CourseApplication)
resultCourseApplication = _dbrOutput . _1
resultUser :: Lens' CourseApplicationsTableData (Entity User)
resultUser = _dbrOutput . _2
resultHasFiles :: Lens' CourseApplicationsTableData Bool
resultHasFiles = _dbrOutput . _3 . _Value
resultAllocation :: Traversal' CourseApplicationsTableData (Entity Allocation)
resultAllocation = _dbrOutput . _4 . _Just
resultStudyFeatures :: Traversal' CourseApplicationsTableData (Entity StudyFeatures)
resultStudyFeatures = _dbrOutput . _5 . _Just
resultStudyTerms :: Traversal' CourseApplicationsTableData (Entity StudyTerms)
resultStudyTerms = _dbrOutput . _6 . _Just
resultStudyDegree :: Traversal' CourseApplicationsTableData (Entity StudyDegree)
resultStudyDegree = _dbrOutput . _7 . _Just
newtype CourseApplicationsTableVeto = CourseApplicationsTableVeto Bool
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving newtype (Enum, Bounded)
makePrisms ''CourseApplicationsTableVeto
instance Csv.ToField CourseApplicationsTableVeto where
toField (CourseApplicationsTableVeto True) = "veto"
toField (CourseApplicationsTableVeto False) = ""
instance Csv.FromField CourseApplicationsTableVeto where
parseField f = do
(CI.map Text.strip -> t :: CI Text) <- Csv.parseField f
return . CourseApplicationsTableVeto $ any (== t)
[ "veto", "v", "yes", "y", "ja", "j", "wahr", "w", "true", "t", "1" ]
data CourseApplicationsTableCsv = CourseApplicationsTableCsv
{ csvCAAllocation :: Maybe AllocationShorthand
, csvCAApplication :: Maybe CryptoFileNameCourseApplication
, csvCAName :: Maybe Text
, csvCAMatriculation :: Maybe Text
, csvCAField :: Maybe Text
, csvCADegree :: Maybe Text
, csvCASemester :: Maybe Int
, csvCAText :: Maybe Text
, csvCAHasFiles :: Maybe Bool
, csvCAVeto :: Maybe CourseApplicationsTableVeto
, csvCARating :: Maybe ExamGrade
, csvCAComment :: Maybe Text
} deriving (Generic)
makeLenses_ ''CourseApplicationsTableCsv
courseApplicationsTableCsvOptions :: Csv.Options
courseApplicationsTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 2 }
instance Csv.ToNamedRecord CourseApplicationsTableCsv where
toNamedRecord = Csv.genericToNamedRecord courseApplicationsTableCsvOptions
instance Csv.FromNamedRecord CourseApplicationsTableCsv where
parseNamedRecord csv
= CourseApplicationsTableCsv
<$> csv .:?? "allocation"
<*> csv .:?? "application"
<*> csv .:?? "name"
<*> csv .:?? "matriculation"
<*> csv .:?? "field"
<*> csv .:?? "degree"
<*> csv .:?? "semester"
<*> csv .:?? "text"
<*> csv .:?? "has-files"
<*> csv .:?? "veto"
<*> csv .:?? "rating"
<*> csv .:?? "comment"
instance Csv.DefaultOrdered CourseApplicationsTableCsv where
headerOrder = Csv.genericHeaderOrder courseApplicationsTableCsvOptions
instance CsvColumnsExplained CourseApplicationsTableCsv where
csvColumnsExplanations = genericCsvColumnsExplanations courseApplicationsTableCsvOptions $ Map.fromList
[ ('csvCAAllocation , MsgCsvColumnApplicationsAllocation )
, ('csvCAApplication , MsgCsvColumnApplicationsApplication )
, ('csvCAName , MsgCsvColumnApplicationsName )
, ('csvCAMatriculation, MsgCsvColumnApplicationsMatriculation)
, ('csvCAField , MsgCsvColumnApplicationsField )
, ('csvCADegree , MsgCsvColumnApplicationsDegree )
, ('csvCASemester , MsgCsvColumnApplicationsSemester )
, ('csvCAText , MsgCsvColumnApplicationsText )
, ('csvCAHasFiles , MsgCsvColumnApplicationsHasFiles )
, ('csvCAVeto , MsgCsvColumnApplicationsVeto )
, ('csvCARating , MsgCsvColumnApplicationsRating )
, ('csvCAComment , MsgCsvColumnApplicationsComment )
]
data CourseApplicationsTableCsvActionClass
= CourseApplicationsTableCsvSetField
| CourseApplicationsTableCsvSetVeto
| CourseApplicationsTableCsvSetRating
| CourseApplicationsTableCsvSetComment
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvActionClass id
data CourseApplicationsTableCsvAction
= CourseApplicationsTableCsvSetFieldData
{ caCsvActApplication :: CourseApplicationId
, caCsvActField :: Maybe StudyFeaturesId
}
| CourseApplicationsTableCsvSetVetoData
{ caCsvActApplication :: CourseApplicationId
, caCsvActVeto :: Bool
}
| CourseApplicationsTableCsvSetRatingData
{ caCsvActApplication :: CourseApplicationId
, caCsvActRating :: Maybe ExamGrade
}
| CourseApplicationsTableCsvSetCommentData
{ caCsvActApplication :: CourseApplicationId
, caCsvActComment :: Maybe Text
}
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveJSON defaultOptions
{ constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 4 . dropEnd 1 . splitCamel
, fieldLabelModifier = camelToPathPiece' 3
, sumEncoding = TaggedObject "action" "data"
} ''CourseApplicationsTableCsvAction
data CourseApplicationsTableCsvException
= CourseApplicationsTableCsvExceptionNoMatchingUser
| CourseApplicationsTableCsvExceptionNoMatchingAllocation
| CourseApplicationsTableCsvExceptionNoMatchingStudyFeatures
deriving (Show, Generic, Typeable)
instance Exception CourseApplicationsTableCsvException
embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvException id
getCApplicationsR, postCApplicationsR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCApplicationsR = postCApplicationsR
postCApplicationsR tid ssh csh = do
table <- runDB $ do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
let
allocationLink :: Allocation -> SomeRoute UniWorX
allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR
participantLink :: MonadCrypto m => UserId -> m (SomeRoute UniWorX)
participantLink uid = do
cID <- encrypt uid
return . SomeRoute . CourseR tid ssh csh $ CUserR cID
dbtSQLQuery :: CourseApplicationsTableExpr -> E.SqlQuery _
dbtSQLQuery = runReaderT $ do
courseApplication <- view queryCourseApplication
hasFiles <- view queryHasFiles
user <- view queryUser
allocation <- view queryAllocation
studyFeatures <- view queryStudyFeatures
studyTerms <- view queryStudyTerms
studyDegree <- view queryStudyDegree
lift $ do
E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
E.on $ studyTerms E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
E.on $ studyFeatures E.?. StudyFeaturesId E.==. courseApplication E.^. CourseApplicationField
E.on $ courseApplication E.^. CourseApplicationAllocation E.==. allocation E.?. AllocationId
E.on $ user E.^. UserId E.==. courseApplication E.^. CourseApplicationUser
E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid
return (courseApplication, user, hasFiles, allocation, studyFeatures, studyTerms, studyDegree)
dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) CourseApplicationsTableData
dbtProj = runReaderT $ do
appId <- view $ resultCourseApplication . _entityKey
cID <- encrypt appId
guardM . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR
view id
dbtRowKey = view $ queryCourseApplication . to (E.^. CourseApplicationId)
dbtColonnade :: Colonnade Sortable _ _
dbtColonnade = mconcat
[ emptyOpticColonnade (resultAllocation . _entityVal) $ \l -> anchorColonnade (views l allocationLink) $ colAllocationShorthand (l . _allocationShorthand)
, colApplicationId (resultCourseApplication . _entityKey)
, anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
, colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
, emptyOpticColonnade (resultStudyTerms . _entityVal) colStudyTerms
, emptyOpticColonnade (resultStudyDegree . _entityVal) colStudyDegree
, emptyOpticColonnade (resultStudyFeatures . _entityVal . _studyFeaturesSemester) colStudyFeaturesSemester
, colApplicationText (resultCourseApplication . _entityVal . _courseApplicationText)
, lmap ((tid, ssh, csh), ) $ colApplicationFiles ($(multifocusL 5) (_1 . _1) (_1 . _2) (_1 . _3) (_2 . resultCourseApplication . _entityKey) (_2 . resultHasFiles))
, colApplicationVeto (resultCourseApplication . _entityVal . _courseApplicationRatingVeto)
, colApplicationRatingPoints (resultCourseApplication . _entityVal . _courseApplicationRatingPoints)
, colApplicationRatingComment (resultCourseApplication . _entityVal . _courseApplicationRatingComment)
]
dbtSorting = mconcat
[ sortAllocationShorthand $ queryAllocation . to (E.?. AllocationShorthand)
, sortUserName' $ $(multifocusG 2) (queryUser . to (E.^. UserDisplayName)) (queryUser . to (E.^. UserSurname))
, sortUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
, sortStudyTerms queryStudyTerms
, sortStudyDegree queryStudyDegree
, sortStudyFeaturesSemester $ queryStudyFeatures . to (E.?. StudyFeaturesSemester)
, sortApplicationText $ queryCourseApplication . to (E.^. CourseApplicationText)
, sortApplicationFiles queryHasFiles
, sortApplicationVeto $ queryCourseApplication . to (E.^. CourseApplicationRatingVeto)
, sortApplicationRatingPoints $ queryCourseApplication . to (E.^. CourseApplicationRatingPoints)
, sortApplicationRatingComment $ queryCourseApplication . to (E.^. CourseApplicationRatingComment)
]
dbtFilter = mconcat
[ fltrAllocation queryAllocation
, fltrUserName' $ queryUser . to (E.^. UserDisplayName)
, fltrUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
, fltrStudyTerms queryStudyTerms
, fltrStudyDegree queryStudyDegree
, fltrStudyFeaturesSemester $ queryStudyFeatures . to (E.?. StudyFeaturesSemester)
, fltrApplicationText $ queryCourseApplication . to (E.^. CourseApplicationText)
, fltrApplicationFiles queryHasFiles
, fltrApplicationVeto $ queryCourseApplication . to (E.^. CourseApplicationRatingVeto)
, fltrApplicationRatingPoints $ queryCourseApplication . to (E.^. CourseApplicationRatingPoints)
, fltrApplicationRatingComment $ queryCourseApplication . to (E.^. CourseApplicationRatingComment)
]
dbtFilterUI = mconcat
[ fltrAllocationUI
, fltrUserNameUI'
, fltrUserMatriculationUI
, fltrStudyTermsUI
, fltrStudyDegreeUI
, fltrStudyFeaturesSemesterUI
, fltrApplicationTextUI
, fltrApplicationFilesUI
, fltrApplicationVetoUI
, fltrApplicationRatingPointsUI
, fltrApplicationRatingCommentUI
]
dbtStyle = def
{ dbsFilterLayout = defaultDBSFilterLayout
}
dbtParams = def
dbtCsvEncode :: DBTCsvEncode CourseApplicationsTableData CourseApplicationsTableCsv
dbtCsvEncode = DictJust . C.mapM . runReaderT $ CourseApplicationsTableCsv
<$> preview (resultAllocation . _entityVal . _allocationShorthand)
<*> (preview (resultCourseApplication . _entityKey) >>= traverse encrypt)
<*> preview (resultUser . _entityVal . _userDisplayName)
<*> preview (resultUser . _entityVal . _userMatrikelnummer . _Just)
<*> preview (resultStudyTerms . _entityVal . (_studyTermsName . _Just <> _studyTermsShorthand . _Just <> to (tshow . studyTermsKey)))
<*> preview (resultStudyDegree . _entityVal . (_studyDegreeName . _Just <> _studyDegreeShorthand . _Just <> to (tshow . studyDegreeKey)))
<*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
<*> preview (resultCourseApplication . _entityVal . _courseApplicationText . _Just)
<*> preview resultHasFiles
<*> preview (resultCourseApplication . _entityVal . _courseApplicationRatingVeto . re _CourseApplicationsTableVeto)
<*> preview (resultCourseApplication . _entityVal . _courseApplicationRatingPoints . _Just)
<*> preview (resultCourseApplication . _entityVal . _courseApplicationRatingComment . _Just)
dbtCsvDecode = Just DBTCsvDecode
{ dbtCsvRowKey = \csv -> do
appRes <- lift $ guessUser csv
case appRes of
Right appId -> return $ E.Value appId
Left uid -> do
alloc <- lift $ guessAllocation csv
[appId] <- lift $ selectKeysList [CourseApplicationUser ==. uid, CourseApplicationAllocation ==. alloc] [LimitTo 2]
return $ E.Value appId
, dbtCsvComputeActions = \case
DBCsvDiffMissing{}
-> return () -- no deletion
DBCsvDiffNew{}
-> return () -- no addition
DBCsvDiffExisting{..} -> do
let appId = dbCsvOld ^. resultCourseApplication . _entityKey
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $
yield $ CourseApplicationsTableCsvSetFieldData appId newFeatures
let mVeto = dbCsvNew ^? _csvCAVeto . _Just . _CourseApplicationsTableVeto
whenIsJust mVeto $ \veto ->
when (veto /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingVeto) $
yield $ CourseApplicationsTableCsvSetVetoData appId veto
when (dbCsvNew ^. _csvCARating /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingPoints) $
yield $ CourseApplicationsTableCsvSetRatingData appId (dbCsvNew ^. _csvCARating)
when (dbCsvNew ^. _csvCAComment /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingComment) $
yield $ CourseApplicationsTableCsvSetCommentData appId (dbCsvNew ^. _csvCAComment)
, dbtCsvClassifyAction = \case
CourseApplicationsTableCsvSetFieldData{} -> CourseApplicationsTableCsvSetField
CourseApplicationsTableCsvSetVetoData{} -> CourseApplicationsTableCsvSetVeto
CourseApplicationsTableCsvSetRatingData{} -> CourseApplicationsTableCsvSetRating
CourseApplicationsTableCsvSetCommentData{} -> CourseApplicationsTableCsvSetComment
, dbtCsvCoarsenActionClass = const DBCsvActionExisting
, dbtCsvExecuteActions = do
now <- liftIO getCurrentTime
C.mapM_ $ \case
CourseApplicationsTableCsvSetFieldData{..} -> do
CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationField =. caCsvActField
, CourseApplicationTime =. now
]
audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication
CourseApplicationsTableCsvSetVetoData{..} -> do
CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingVeto =. caCsvActVeto
, CourseApplicationRatingTime =. Just now
]
audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication
CourseApplicationsTableCsvSetRatingData{..} -> do
CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingPoints =. caCsvActRating
, CourseApplicationRatingTime =. Just now
]
audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication
CourseApplicationsTableCsvSetCommentData{..} -> do
CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingComment =. caCsvActComment
, CourseApplicationRatingTime =. Just now
]
audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication
return $ CourseR tid ssh csh CApplicationsR
, dbtCsvRenderKey = \(existingApplicantName -> existingApplicantName') -> \case
CourseApplicationsTableCsvSetFieldData{..} ->
[whamlet|
$newline never
^{existingApplicantName' caCsvActApplication}
$maybe features <- caCsvActField
, ^{studyFeaturesWidget features}
$nothing
, _{MsgCourseStudyFeatureNone}
|]
CourseApplicationsTableCsvSetVetoData{..} ->
[whamlet|
$newline never
^{existingApplicantName' caCsvActApplication}
$if caCsvActVeto
, _{MsgCourseApplicationVeto}
$else
, _{MsgCourseApplicationNoVeto}
|]
CourseApplicationsTableCsvSetRatingData{..} ->
[whamlet|
$newline never
^{existingApplicantName' caCsvActApplication}
$maybe newResult <- caCsvActRating
, _{newResult}
$nothing
, _{MsgCourseApplicationNoRatingPoints}
|]
CourseApplicationsTableCsvSetCommentData{..} ->
[whamlet|
$newline never
^{existingApplicantName' caCsvActApplication}
$if is _Nothing caCsvActComment
, _{MsgCourseApplicationNoRatingComment}
|]
, dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
, dbtCsvRenderException = ap getMessageRender . pure :: CourseApplicationsTableCsvException -> DB Text
}
where
guessUser :: CourseApplicationsTableCsv -> DB (Either UserId CourseApplicationId)
guessUser csv = do
mApp <- runMaybeT $ do
appId <- squash . catchIfMaybeT (const True :: CryptoIDError -> Bool) . MaybeT . traverse decrypt $ csv ^? _csvCAApplication . _Just
CourseApplication{..} <- MaybeT $ get appId
guard $ courseApplicationCourse == cid
return appId
maybe (Left <$> guessUser' csv) (return . Right) mApp
where
guessUser' :: CourseApplicationsTableCsv -> DB UserId
guessUser' CourseApplicationsTableCsv{..} = $cachedHereBinary (csvCAMatriculation, csvCAName) $ do
users <- E.select . E.from $ \user -> do
E.where_ . E.and $ catMaybes
[ (user E.^. UserMatrikelnummer E.==.) . E.val . Just <$> csvCAMatriculation
, (user E.^. UserDisplayName E.==.) . E.val <$> csvCAName
]
return $ user E.^. UserId
case users of
[E.Value uid]
-> return uid
_other
-> throwM CourseApplicationsTableCsvExceptionNoMatchingUser
guessAllocation :: CourseApplicationsTableCsv -> DB (Maybe AllocationId)
guessAllocation CourseApplicationsTableCsv{..} = $cachedHereBinary csvCAAllocation . for csvCAAllocation $ \ash -> do
mAlloc <- traverse (getJustEntity . allocationCourseAllocation . entityVal) <=< getBy $ UniqueAllocationCourse cid
case mAlloc of
Just (Entity allocId Allocation{..})
| allocationShorthand == ash
-> return allocId
_other
-> throwM CourseApplicationsTableCsvExceptionNoMatchingAllocation
existingApplicantName :: Map (E.Value CourseApplicationId) CourseApplicationsTableData -> CourseApplicationId -> Widget
existingApplicantName existing (E.Value -> appId) = nameWidget userDisplayName userSurname
where
Entity _ User{..} = existing ^. singular (ix appId . resultUser)
lookupStudyFeatures :: CourseApplicationsTableCsv -> DB (Maybe StudyFeaturesId)
lookupStudyFeatures csv@CourseApplicationsTableCsv{..} = do
appRes <- guessUser csv
(uid, oldFeatures) <- case appRes of
Left uid -> (uid, ) <$> selectList [ CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid ] []
Right appId -> (courseApplicationUser . entityVal &&& pure) <$> getJustEntity appId
studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) ->
E.distinctOnOrderBy [ E.asc (studyFeatures E.^. StudyFeaturesField)
, E.asc (studyFeatures E.^. StudyFeaturesDegree)
, E.asc (studyFeatures E.^. StudyFeaturesSemester)] $ do
E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField
E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree
E.where_ . E.and $ catMaybes
[ do
field <- csvCAField
return . E.or $ catMaybes
[ Just $ studyTerms E.^. StudyTermsName `E.ciEq` E.just (E.val field)
, Just $ studyTerms E.^. StudyTermsShorthand `E.ciEq` E.just (E.val field)
, (studyTerms E.^. StudyTermsKey E.==.) . E.val <$> readMay field
]
, do
degree <- csvCADegree
return . E.or $ catMaybes
[ Just $ studyDegree E.^. StudyDegreeName `E.ciEq` E.just (E.val degree)
, Just $ studyDegree E.^. StudyDegreeShorthand `E.ciEq` E.just (E.val degree)
, (studyDegree E.^. StudyDegreeKey E.==.) . E.val <$> readMay degree
]
, (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvCASemester
]
E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
let isActiveOrPrevious = E.or
$ (studyFeatures E.^. StudyFeaturesValid)
: [ E.val sfid E.==. studyFeatures E.^. StudyFeaturesId
| Entity _ CourseApplication{ courseApplicationField = Just sfid } <- oldFeatures
]
E.where_ isActiveOrPrevious -- either active studyFeature or the one previously associated with this course
E.orderBy [E.desc isActiveOrPrevious, E.asc (E.orderByOrd $ studyFeatures E.^. StudyFeaturesType)]
return $ studyFeatures E.^. StudyFeaturesId
case studyFeatures of
[E.Value fid] -> return $ Just fid
_other
| is _Nothing csvCAField
, is _Nothing csvCADegree
, is _Nothing csvCASemester
-> return Nothing
_other
| [Entity _ CourseApplication{..}] <- oldFeatures
, Just sfid <- courseApplicationField
, E.Value sfid `elem` studyFeatures
-> return $ Just sfid
_other -> throwM CourseApplicationsTableCsvExceptionNoMatchingStudyFeatures
dbtIdent = courseApplicationsIdent
psValidator :: PSValidator _ _
psValidator = def
& defaultSorting [SortAscBy "user-name"]
dbTableWidget' psValidator DBTable{..}
let title = prependCourseTitle tid ssh csh MsgCourseApplicationsListTitle
siteLayoutMsg title $ do
setTitleI title
table

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

@ -5,7 +5,6 @@ module Handler.Course.Edit
import Import import Import
import Utils.Lens
import Utils.Form import Utils.Form
import Handler.Utils import Handler.Utils
import Handler.Utils.Invitations import Handler.Utils.Invitations
@ -106,10 +105,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
MsgRenderer mr <- getMsgRenderer MsgRenderer mr <- getMsgRenderer
uid <- liftHandlerT requireAuthId uid <- liftHandlerT requireAuthId
(lecSchools, admSchools) <- liftHandlerT . runDB $ (,) userSchools <- liftHandlerT . runDB $ map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin, SchoolLecturer]] []
<$> (map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] [] )
<*> (map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] [] )
let userSchools = lecSchools ++ admSchools
termsField <- case template of termsField <- case template of
-- Change of term is only allowed if user may delete the course (i.e. no participants) or admin -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin
@ -279,11 +275,11 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
_ -> (result, widget) _ -> (result, widget)
validateCourse :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseForm -> m [Text] validateCourse :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseForm -> m [Text]
validateCourse CourseForm{..} = do validateCourse CourseForm{..} = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
uid <- liftHandlerT requireAuthId uid <- liftHandlerT requireAuthId
userAdmin <- liftHandlerT . runDB . getBy $ UniqueUserAdmin uid cfSchool -- FIXME: This /needs/ to be a call to `isAuthorized` on a route userAdmin <- hasWriteAccessTo $ SchoolR cfSchool SchoolEditR
MsgRenderer mr <- getMsgRenderer MsgRenderer mr <- getMsgRenderer
allocationTerm <- for (acfAllocation <$> cfAllocation) $ fmap allocationTerm . liftHandlerT . runDB . getJust allocationTerm <- for (acfAllocation <$> cfAllocation) $ fmap allocationTerm . liftHandlerT . runDB . getJust
@ -292,7 +288,7 @@ validateCourse CourseForm{..} = do
prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
fmap join . for prevAllocation $ \Allocation{allocationStaffRegisterTo} -> if fmap join . for prevAllocation $ \Allocation{allocationStaffRegisterTo} -> if
| is _Just userAdmin | userAdmin
-> return Nothing -> return Nothing
| NTop allocationStaffRegisterTo <= NTop (Just now) | NTop allocationStaffRegisterTo <= NTop (Just now)
-> Just . courseCapacity <$> getJust cid -> Just . courseCapacity <$> getJust cid
@ -310,7 +306,7 @@ validateCourse CourseForm{..} = do
( NTop cfRegFrom <= NTop cfDeRegUntil ( NTop cfRegFrom <= NTop cfDeRegUntil
, MsgCourseDeregistrationEndMustBeAfterStart , MsgCourseDeregistrationEndMustBeAfterStart
) )
, ( maybe (anyOf (traverse . _Right . _1) (== uid) cfLecturers) (\(Entity _ UserAdmin{}) -> True) userAdmin , ( bool (anyOf (traverse . _Right . _1) (== uid) cfLecturers) True userAdmin
, MsgCourseUserMustBeLecturer , MsgCourseUserMustBeLecturer
) )
, ( is _Nothing cfAllocation || is _Just cfCapacity , ( is _Nothing cfAllocation || is _Just cfCapacity
@ -358,8 +354,9 @@ getCourseNewR = do
E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
let lecturersSchool = let lecturersSchool =
E.exists $ E.from $ \user -> E.exists $ E.from $ \user ->
E.where_ $ user E.^. UserLecturerUser E.==. E.val uid E.where_ $ user E.^. UserFunctionUser E.==. E.val uid
E.&&. user E.^. UserLecturerSchool E.==. course E.^. CourseSchool E.&&. user E.^. UserFunctionSchool E.==. course E.^. CourseSchool
E.&&. user E.^. UserFunctionFunction E.==. E.val SchoolLecturer
let courseCreated c = let courseCreated c =
E.sub_select . E.from $ \edit -> do -- oldest edit must be creation E.sub_select . E.from $ \edit -> do -- oldest edit must be creation
E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
@ -528,21 +525,28 @@ courseEditHandler miButtonAction mbCourseForm = do
, formEncoding = formEnctype , formEncoding = formEnctype
} }
upsertAllocationCourse :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m () upsertAllocationCourse :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m ()
upsertAllocationCourse cid cfAllocation = do upsertAllocationCourse cid cfAllocation = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
uid <- liftHandlerT requireAuthId
Course{..} <- getJust cid Course{..} <- getJust cid
prevAllocationCourse <- getBy $ UniqueAllocationCourse cid prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
userAdmin <- liftHandlerT . runDB . getBy $ UniqueUserAdmin uid courseSchool -- FIXME: This /needs/ to be a call to `isAuthorized` on a route userAdmin <- hasWriteAccessTo $ SchoolR courseSchool SchoolEditR
doEdit <- if doEdit <- if
| is _Just userAdmin | userAdmin
-> return True -> return True
| Just Allocation{allocationStaffRegisterTo} <- prevAllocation | Just Allocation{allocationStaffRegisterTo} <- prevAllocation
, NTop allocationStaffRegisterTo <= NTop (Just now) , NTop allocationStaffRegisterTo <= NTop (Just now)
-> False <$ addMessageI Error MsgAllocationStaffRegisterToExpired -> let anyChanges
| Just AllocationCourseForm{..} <- cfAllocation
, Just (Entity _ AllocationCourse{..}) <- prevAllocationCourse
= or [ acfAllocation /= allocationCourseAllocation
, acfMinCapacity /= allocationCourseMinCapacity
]
| otherwise
= True
in False <$ when anyChanges (addMessageI Error MsgAllocationStaffRegisterToExpired)
| otherwise | otherwise
-> return True -> return True

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

@ -8,7 +8,6 @@ module Handler.Course.LecturerInvite
import Import import Import
import Utils.Lens
import Utils.Form import Utils.Form
import Handler.Utils.Invitations import Handler.Utils.Invitations
@ -62,7 +61,7 @@ lecturerInvitationConfig = InvitationConfig{..}
getKeyBy404 $ TermSchoolCourseShort tid csh ssh getKeyBy404 $ TermSchoolCourseShort tid csh ssh
invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|] invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
invitationTokenConfig _ _ = do invitationTokenConfig _ _ = do
itAuthority <- liftHandlerT requireAuthId itAuthority <- liftHandlerT requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing

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

@ -10,7 +10,6 @@ import Import
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Utils.Lens
import Utils.Form import Utils.Form
-- import Utils.DB -- import Utils.DB
import Handler.Utils import Handler.Utils
@ -26,39 +25,39 @@ import qualified Database.Esqueleto.Utils as E
-- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method. -- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School, [Entity User]) type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School, [Entity User], Maybe (Entity Allocation))
colCourse :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colCourse :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colCourse = sortable (Just "course") (i18nCell MsgCourse) colCourse = sortable (Just "course") (i18nCell MsgCourse)
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _) } -> $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _, _) } ->
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
[whamlet|_{courseName}|] [whamlet|_{courseName}|]
colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colDescription = sortable Nothing mempty colDescription = sortable Nothing mempty
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _) } -> $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _, _) } ->
case courseDescription of case courseDescription of
Nothing -> mempty Nothing -> mempty
(Just descr) -> cell $ modal (toWidget $ hasComment True) (Right $ toWidget descr) (Just descr) -> cell $ modal (toWidget $ hasComment True) (Right $ toWidget descr)
colCShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colCShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort) colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _) } -> $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _, _) } ->
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|_{courseShorthand}|] anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|_{courseShorthand}|]
colTerm :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colTerm :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colTerm = sortable (Just "term") (i18nCell MsgTerm) colTerm = sortable (Just "term") (i18nCell MsgTerm)
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _) } -> $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _, _) } ->
anchorCell (TermCourseListR courseTerm) [whamlet|#{courseTerm}|] anchorCell (TermCourseListR courseTerm) [whamlet|#{courseTerm}|]
colSchoolShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colSchoolShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort) colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}, _) } -> $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}, _, _) } ->
anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolShorthand}|] anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolShorthand}|]
colRegistered :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colRegistered :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colRegistered = sortable (Just "registered") (i18nCell MsgRegistered) colRegistered = sortable (Just "registered") (i18nCell MsgRegistered)
$ \DBRow{ dbrOutput=(_, _, registered, _, _) } -> tickmarkCell registered $ \DBRow{ dbrOutput=(_, _, registered, _, _, _) } -> tickmarkCell registered
type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School) type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School)
@ -91,7 +90,9 @@ makeCourseTable whereClause colChoices psValidator = do
dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData
dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> do dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> do
lecturerList <- lift $ E.select $ E.from $ lecturerQuery $ E.val $ entityKey course lecturerList <- lift $ E.select $ E.from $ lecturerQuery $ E.val $ entityKey course
return (course, participants, registered, school, lecturerList) courseAlloc <- lift $ getBy (UniqueAllocationCourse $ entityKey course)
>>= traverse (getJustEntity . allocationCourseAllocation . entityVal)
return (course, participants, registered, school, lecturerList, courseAlloc)
snd <$> dbTable psValidator DBTable snd <$> dbTable psValidator DBTable
{ dbtSQLQuery { dbtSQLQuery
, dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
@ -142,7 +143,22 @@ makeCourseTable whereClause colChoices psValidator = do
Nothing -> E.val True Nothing -> E.val True
Just b -> let regTo = course E.^. CourseRegisterTo Just b -> let regTo = course E.^. CourseRegisterTo
regFrom = course E.^. CourseRegisterFrom regFrom = course E.^. CourseRegisterFrom
in (E.==.) (E.val b) $ (E.isNothing regTo E.||. E.val (Just now) E.<=. regTo) E.&&. E.val (Just now) E.>=. regFrom courseOpen = E.maybe E.false (\f -> f E.<=. E.val now) regFrom
E.&&. E.maybe E.true (\t -> E.val now E.<=. t) regTo
alloc allocation = do
E.where_ . E.exists . E.from $ \allocationCourse ->
E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
return allocation
allocOpen allocation = ( E.maybe E.false (\f -> f E.<=. E.val now) (allocation E.^. AllocationRegisterFrom)
E.&&. E.maybe E.true (\t -> E.val now E.<=. t) (allocation E.^. AllocationRegisterTo)
)
E.||. ( courseOpen
E.&&. E.maybe E.false (\f -> f E.<=. E.val now) (allocation E.^. AllocationRegisterByCourse)
)
in (E.==. E.val b) $ ( courseOpen
E.&&. E.not_ (E.exists . void $ E.from alloc)
)
E.||. E.exists (E.from $ E.where_ . allocOpen <=< alloc)
) )
, ( "registered", FilterColumn $ \tExpr criterion -> case getLast (criterion :: Last Bool) of , ( "registered", FilterColumn $ \tExpr criterion -> case getLast (criterion :: Last Bool) of
Nothing -> E.val True :: E.SqlExpr (E.Value Bool) Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
@ -165,8 +181,8 @@ makeCourseTable whereClause colChoices psValidator = do
] ]
, dbtStyle = def , dbtStyle = def
{ dbsFilterLayout = defaultDBSFilterLayout { dbsFilterLayout = defaultDBSFilterLayout
, dbsTemplate = DBSTCourse (_dbrOutput . _1) (_dbrOutput . _5) (_dbrOutput . _3) (_dbrOutput . _4) , dbsTemplate = DBSTCourse (_dbrOutput . _1) (_dbrOutput . _5) (_dbrOutput . _3) (_dbrOutput . _4) (_dbrOutput . _6 . _Just)
-- ^ course ^ lecturer list ^ isRegistered ^ school -- ^ course ^ lecturer list ^ isRegistered ^ school ^ allocation
} }
, dbtParams = def , dbtParams = def
, dbtIdent = "courses" :: Text , dbtIdent = "courses" :: Text

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

@ -8,7 +8,6 @@ module Handler.Course.ParticipantInvite
import Import import Import
import Utils.Lens
import Utils.Form import Utils.Form
import Handler.Utils import Handler.Utils
import Handler.Utils.Invitations import Handler.Utils.Invitations
@ -75,7 +74,7 @@ participantInvitationConfig = InvitationConfig{..}
getKeyBy404 $ TermSchoolCourseShort tid csh ssh getKeyBy404 $ TermSchoolCourseShort tid csh ssh
invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand
invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|] invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
invitationTokenConfig _ _ = do invitationTokenConfig _ _ = do
itAuthority <- liftHandlerT requireAuthId itAuthority <- liftHandlerT requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing

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

@ -7,7 +7,6 @@ module Handler.Course.Register
import Import import Import
import Utils.Lens
import Handler.Utils import Handler.Utils
import Data.Function ((&)) import Data.Function ((&))
@ -114,26 +113,26 @@ courseRegisterForm (Entity cid Course{..}) = liftHandlerT $ do
let appFilesInfo = (,) <$> hasFiles <*> appCID let appFilesInfo = (,) <$> hasFiles <*> appCID
filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired
if when (isn't _NoUpload courseApplicationsFiles || fromMaybe False hasFiles) $
| isn't _NoUpload courseApplicationsFiles || fromMaybe False hasFiles let filesLinkField = Field{..}
-> let filesLinkField = Field{..} where
where fieldParse _ _ = return $ Right Nothing
fieldParse _ _ = return $ Right Nothing fieldEnctype = mempty
fieldEnctype = mempty fieldView theId _ attrs _ _
fieldView theId _ attrs _ _ = [whamlet|
= [whamlet| $newline never
$newline never $case appFilesInfo
$case appFilesInfo $of Just (True, appCID)
$of Just (True, appCID) <a ##{theId} *{attrs} href=@{CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR}>
<a ##{theId} *{attrs} href=@{CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR}> _{filesMsg}
_{filesMsg} $of _
$of _ <span ##{theId} *{attrs}>
<span ##{theId} *{attrs}> _{MsgCourseApplicationNoFiles}
_{MsgCourseApplicationNoFiles} |]
|] in void $ wforced filesLinkField (fslI filesMsg) Nothing
in void $ wforced filesLinkField (fslI filesMsg) Nothing
| otherwise when (fromMaybe False hasFiles && isn't _NoUpload courseApplicationsFiles) $
-> return () wformMessage <=< messageIconI Info IconFileUpload $ bool MsgCourseRegistrationFilesNeedReupload MsgCourseApplicationFilesNeedReupload courseApplicationsRequired
appFilesRes <- let mkFs | courseApplicationsRequired = bool MsgCourseApplicationFile MsgCourseApplicationArchive appFilesRes <- let mkFs | courseApplicationsRequired = bool MsgCourseApplicationFile MsgCourseApplicationArchive
| otherwise = bool MsgCourseRegistrationFile MsgCourseRegistrationArchive | otherwise = bool MsgCourseRegistrationFile MsgCourseRegistrationArchive
@ -177,7 +176,7 @@ postCRegisterR tid ssh csh = do
= void <$> do = void <$> do
appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] [] appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] []
appRes <- case appIds of appRes <- case appIds of
[] -> insertUnique $ CourseApplication cid uid crfStudyFeatures crfApplicationText Nothing Nothing Nothing Nothing cTime [] -> insertUnique $ CourseApplication cid uid crfStudyFeatures crfApplicationText False Nothing Nothing Nothing Nothing cTime Nothing
(prevId:ps) -> do (prevId:ps) -> do
forM_ ps $ \appId -> do forM_ ps $ \appId -> do
deleteApplicationFiles appId deleteApplicationFiles appId
@ -218,8 +217,14 @@ postCRegisterR tid ssh csh = do
Just _ -> addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk Just _ -> addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
BtnCourseDeregister -> runDB $ do BtnCourseDeregister -> runDB $ do
deleteApplications deleteApplications
deleteBy $ UniqueParticipant uid cid part <- getBy $ UniqueParticipant uid cid
audit $ TransactionCourseParticipantDeleted cid uid forM_ part $ \(Entity partId CourseParticipant{..}) -> do
delete $ partId
audit $ TransactionCourseParticipantDeleted cid uid
when courseParticipantAllocated $ do
now <- liftIO getCurrentTime
insert_ $ AllocationDeregister courseParticipantUser (Just courseParticipantCourse) now Nothing
examRegistrations <- E.select . E.from $ \(examRegistration `E.InnerJoin` exam) -> do examRegistrations <- E.select . E.from $ \(examRegistration `E.InnerJoin` exam) -> do
E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId

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

@ -12,7 +12,6 @@ import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH import Database.Esqueleto.Utils.TH
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Utils.Lens
import qualified Data.Map as Map import qualified Data.Map as Map
@ -79,6 +78,10 @@ getCShowR tid ssh csh = do
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration
cID <- encrypt cid :: Handler CryptoUUIDCourse
mAllocation' <- for mAllocation $ \Allocation{..} -> (,)
<$> pure allocationName
<*> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID)
regForm <- if regForm <- if
| is _Just mbAid -> do | is _Just mbAid -> do
(courseRegisterForm', regButton) <- courseRegisterForm (Entity cid course) (courseRegisterForm', regButton) <- courseRegisterForm (Entity cid course)

1
src/Handler/Course/User.hs
View File

@ -4,7 +4,6 @@ module Handler.Course.User
import Import import Import
import Utils.Lens
import Utils.Form import Utils.Form
import Handler.Utils import Handler.Utils
import Database.Esqueleto.Utils.TH import Database.Esqueleto.Utils.TH

1
src/Handler/Course/Users.hs
View File

@ -9,7 +9,6 @@ module Handler.Course.Users
import Import import Import
import Utils.Lens
import Utils.Form import Utils.Form
import Handler.Utils import Handler.Utils
import Handler.Utils.Database import Handler.Utils.Database

2
src/Handler/CryptoIDDispatch.hs
View File

@ -5,8 +5,6 @@ module Handler.CryptoIDDispatch
import Import import Import
import Data.Proxy
import qualified Data.Text as Text import qualified Data.Text as Text
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..)) import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))

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

@ -9,8 +9,6 @@ import Handler.Utils
import Handler.Utils.Exam import Handler.Utils.Exam
import Handler.Utils.Invitations import Handler.Utils.Invitations
import Utils.Lens
import qualified Data.Set as Set import qualified Data.Set as Set
import Data.Semigroup (Option(..)) import Data.Semigroup (Option(..))

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

@ -12,8 +12,6 @@ import Import
import Handler.Utils.Invitations import Handler.Utils.Invitations
import Handler.Utils.Exam import Handler.Utils.Exam
import Utils.Lens
import Text.Hamlet (ihamlet) import Text.Hamlet (ihamlet)
import Data.Aeson hiding (Result(..)) import Data.Aeson hiding (Result(..))
@ -63,7 +61,7 @@ examCorrectorInvitationConfig = InvitationConfig{..}
Course{..} <- get404 examCourse Course{..} <- get404 examCourse
return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName
invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|] invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|]
invitationTokenConfig _ _ = do invitationTokenConfig _ _ = do
itAuthority <- liftHandlerT requireAuthId itAuthority <- liftHandlerT requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing

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

@ -6,8 +6,6 @@ import Import
import Handler.Exam.Form import Handler.Exam.Form
import Handler.Exam.CorrectorInvite import Handler.Exam.CorrectorInvite
import Utils.Lens
import qualified Data.Set as Set import qualified Data.Set as Set
import Handler.Utils import Handler.Utils

12
src/Handler/Exam/Form.hs
View File

@ -8,8 +8,6 @@ module Handler.Exam.Form
) where ) where
import Import import Import
import Utils.Lens hiding (parts)
import Handler.Exam.CorrectorInvite import Handler.Exam.CorrectorInvite
import Handler.Utils import Handler.Utils
@ -164,8 +162,8 @@ examOccurrenceForm prev = wFormToAForm $ do
(eofNameRes, eofNameView) <- mpreq ciField ("" & addName (nudge "name")) (eofName <$> mPrev) (eofNameRes, eofNameView) <- mpreq ciField ("" & addName (nudge "name")) (eofName <$> mPrev)
(eofRoomRes, eofRoomView) <- mpreq textField ("" & addName (nudge "room")) (eofRoom <$> mPrev) (eofRoomRes, eofRoomView) <- mpreq textField ("" & addName (nudge "room")) (eofRoom <$> mPrev)
(eofCapacityRes, eofCapacityView) <- mpreq (natFieldI MsgExamRoomCapacityNegative) ("" & addName (nudge "capacity")) (eofCapacity <$> mPrev) (eofCapacityRes, eofCapacityView) <- mpreq (natFieldI MsgExamRoomCapacityNegative) ("" & addName (nudge "capacity")) (eofCapacity <$> mPrev)
(eofStartRes, eofStartView) <- mpreq utcTimeField ("" & addName (nudge "start")) (eofStart <$> mPrev) (eofStartRes, eofStartView) <- mpreq utcTimeField ("" & addName (nudge "start") & addDatepickerPositionAttr DPBottom) (eofStart <$> mPrev)
(eofEndRes, eofEndView) <- mopt utcTimeField ("" & addName (nudge "end")) (eofEnd <$> mPrev) (eofEndRes, eofEndView) <- mopt utcTimeField ("" & addName (nudge "end") & addDatepickerPositionAttr DPBottom) (eofEnd <$> mPrev)
(eofDescRes, eofDescView) <- mopt htmlFieldSmall ("" & addName (nudge "description")) (eofDescription <$> mPrev) (eofDescRes, eofDescView) <- mopt htmlFieldSmall ("" & addName (nudge "description")) (eofDescription <$> mPrev)
return ( ExamOccurrenceForm return ( ExamOccurrenceForm
@ -230,12 +228,12 @@ examPartsForm prev = wFormToAForm $ do
examFormTemplate :: Entity Exam -> DB ExamForm examFormTemplate :: Entity Exam -> DB ExamForm
examFormTemplate (Entity eId Exam{..}) = do examFormTemplate (Entity eId Exam{..}) = do
parts <- selectList [ ExamPartExam ==. eId ] [] examParts <- selectList [ ExamPartExam ==. eId ] []
occurrences <- selectList [ ExamOccurrenceExam ==. eId ] [] occurrences <- selectList [ ExamOccurrenceExam ==. eId ] []
correctors <- selectList [ ExamCorrectorExam ==. eId ] [] correctors <- selectList [ ExamCorrectorExam ==. eId ] []
invitations <- map (\(email, InvDBDataExamCorrector) -> email) <$> sourceInvitationsList eId invitations <- map (\(email, InvDBDataExamCorrector) -> email) <$> sourceInvitationsList eId
parts' <- forM parts $ \(Entity pid part) -> (,) <$> encrypt pid <*> pure part examParts' <- forM examParts $ \(Entity pid part) -> (,) <$> encrypt pid <*> pure part
occurrences' <- forM occurrences $ \(Entity oid occ) -> (,) <$> encrypt oid <*> pure occ occurrences' <- forM occurrences $ \(Entity oid occ) -> (,) <$> encrypt oid <*> pure occ
return ExamForm return ExamForm
@ -267,7 +265,7 @@ examFormTemplate (Entity eId Exam{..}) = do
, eofDescription = examOccurrenceDescription , eofDescription = examOccurrenceDescription
} }
, efExamParts = Set.fromList $ do , efExamParts = Set.fromList $ do
(Just -> epfId, ExamPart{..}) <- parts' (Just -> epfId, ExamPart{..}) <- examParts'
return ExamPartForm return ExamPartForm
{ epfId { epfId
, epfName = examPartName , epfName = examPartName

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

@ -17,8 +17,6 @@ import qualified Data.Set as Set
import Text.Hamlet (ihamlet) import Text.Hamlet (ihamlet)
import Utils.Lens
import Data.Aeson hiding (Result(..)) import Data.Aeson hiding (Result(..))
@ -71,7 +69,7 @@ examRegistrationInvitationConfig = InvitationConfig{..}
Course{..} <- get404 examCourse Course{..} <- get404 examCourse
return . SomeMessage $ MsgMailSubjectExamRegistrationInvitation courseTerm courseSchool courseShorthand examName return . SomeMessage $ MsgMailSubjectExamRegistrationInvitation courseTerm courseSchool courseShorthand examName
invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|] invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|]
invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do
itAuthority <- liftHandlerT requireAuthId itAuthority <- liftHandlerT requireAuthId
let itExpiresAt = Just $ Just invDBExamRegistrationDeadline let itExpiresAt = Just $ Just invDBExamRegistrationDeadline

10
src/Handler/Exam/Show.hs
View File

@ -5,8 +5,6 @@ module Handler.Exam.Show
import Import import Import
import Handler.Exam.Register import Handler.Exam.Register
import Utils.Lens hiding (parts)
import Data.Map ((!?)) import Data.Map ((!?))
import qualified Data.Map as Map import qualified Data.Map as Map
@ -24,7 +22,7 @@ getEShowR tid ssh csh examn = do
cTime <- liftIO getCurrentTime cTime <- liftIO getCurrentTime
mUid <- maybeAuthId mUid <- maybeAuthId
(Entity _ Exam{..}, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) <- runDB $ do (Entity _ Exam{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) <- runDB $ do
exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn
let examVisible = NTop (Just cTime) >= NTop examVisibleFrom let examVisible = NTop (Just cTime) >= NTop examVisibleFrom
@ -35,12 +33,12 @@ getEShowR tid ssh csh examn = do
let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments
occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR
parts <- selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ] examParts <- selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ]
resultsRaw <- for mUid $ \uid -> resultsRaw <- for mUid $ \uid ->
E.select . E.from $ \examPartResult -> do E.select . E.from $ \examPartResult -> do
E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val uid E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val uid
E.&&. examPartResult E.^. ExamPartResultExamPart `E.in_` E.valList (map entityKey parts) E.&&. examPartResult E.^. ExamPartResultExamPart `E.in_` E.valList (map entityKey examParts)
return examPartResult return examPartResult
let results = maybe Map.empty (\rs -> Map.fromList [ (examPartResultExamPart, res) | res@(Entity _ ExamPartResult{..}) <- rs ]) resultsRaw let results = maybe Map.empty (\rs -> Map.fromList [ (examPartResultExamPart, res) | res@(Entity _ ExamPartResult{..}) <- rs ]) resultsRaw
@ -66,7 +64,7 @@ getEShowR tid ssh csh examn = do
occurrenceNamesShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR occurrenceNamesShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR
return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) return (exam, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown)
let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences
registerWidget registerWidget

119
src/Handler/Exam/Users.hs
View File

@ -6,7 +6,6 @@ module Handler.Exam.Users
import Import import Import
import Utils.Lens
import Handler.Utils import Handler.Utils
import Handler.Utils.Exam import Handler.Utils.Exam
import Handler.Utils.Table.Columns import Handler.Utils.Table.Columns
@ -31,7 +30,6 @@ import qualified Data.Conduit.List as C
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Numeric.Lens (integral) import Numeric.Lens (integral)
import Control.Arrow (Kleisli(..))
import Database.Persist.Sql (deleteWhereCount, updateWhereCount) import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
@ -109,7 +107,7 @@ data ExamUserTableCsv = ExamUserTableCsv
, csvEUserExerciseNumPasses :: Maybe Int , csvEUserExerciseNumPasses :: Maybe Int
, csvEUserExercisePointsMax :: Maybe Points , csvEUserExercisePointsMax :: Maybe Points
, csvEUserExerciseNumPassesMax :: Maybe Int , csvEUserExerciseNumPassesMax :: Maybe Int
, csvEUserExamResult :: Maybe (Either ExamResultPassed ExamResultGrade) , csvEUserExamResult :: Maybe ExamResultPassedGrade
, csvEUserCourseNote :: Maybe Html , csvEUserCourseNote :: Maybe Html
} }
deriving (Generic) deriving (Generic)
@ -124,23 +122,20 @@ instance ToNamedRecord ExamUserTableCsv where
instance FromNamedRecord ExamUserTableCsv where instance FromNamedRecord ExamUserTableCsv where
parseNamedRecord csv -- Manually defined awaiting issue #427 parseNamedRecord csv -- Manually defined awaiting issue #427
= ExamUserTableCsv = ExamUserTableCsv
<$> csv .:? "surname" <$> csv .:?? "surname"
<*> csv .:? "first-name" <*> csv .:?? "first-name"
<*> csv .:? "name" <*> csv .:?? "name"
<*> csv .:? "matriculation" <*> csv .:?? "matriculation"
<*> csv .:? "field" <*> csv .:?? "field"
<*> csv .:? "degree" <*> csv .:?? "degree"
<*> csv .:? "semester" <*> csv .:?? "semester"
<*> csv .:? "occurrence" <*> csv .:?? "occurrence"
<*> csv .:? "exercise-points" <*> csv .:?? "exercise-points"
<*> csv .:? "exercise-num-passes" <*> csv .:?? "exercise-num-passes"
<*> csv .:? "exercise-points-max" <*> csv .:?? "exercise-points-max"
<*> csv .:? "exercise-num-passes-max" <*> csv .:?? "exercise-num-passes-max"
<*> csv .:? "exam-result" <*> csv .:?? "exam-result"
<*> csv .:? "course-note" <*> csv .:?? "course-note"
where
(.:?) :: FromField (Maybe a) => Csv.NamedRecord -> ByteString -> Csv.Parser (Maybe a)
m .:? name = Csv.lookup m name <|> return Nothing
instance DefaultOrdered ExamUserTableCsv where instance DefaultOrdered ExamUserTableCsv where
headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions
@ -209,7 +204,7 @@ data ExamUserCsvAction
} }
| ExamUserCsvSetResultData | ExamUserCsvSetResultData
{ examUserCsvActUser :: UserId { examUserCsvActUser :: UserId
, examUserCsvActExamResult :: Maybe (Either ExamResultPassed ExamResultGrade) , examUserCsvActExamResult :: Maybe ExamResultPassedGrade
} }
| ExamUserCsvSetCourseNoteData | ExamUserCsvSetCourseNoteData
{ examUserCsvActUser :: UserId { examUserCsvActUser :: UserId
@ -244,8 +239,8 @@ postEUsersR tid ssh csh examn = do
showPasses = numSheetsPasses allBoni /= 0 showPasses = numSheetsPasses allBoni /= 0
showPoints = getSum (numSheetsPoints allBoni) /= 0 showPoints = getSum (numSheetsPoints allBoni) /= 0
resultView :: ExamResultGrade -> Either ExamResultPassed ExamResultGrade resultView :: ExamResultGrade -> ExamResultPassedGrade
resultView = bool (Left . over _examResult (view passingGrade)) Right examShowGrades resultView = fmap $ bool (Left . view passingGrade) Right examShowGrades
let let
examUsersDBTable = DBTable{..} examUsersDBTable = DBTable{..}
@ -471,7 +466,7 @@ postEUsersR tid ssh csh examn = do
deleteBy $ UniqueExamResult eid examUserCsvActUser deleteBy $ UniqueExamResult eid examUserCsvActUser
audit $ TransactionExamResultDeleted eid examUserCsvActUser audit $ TransactionExamResultDeleted eid examUserCsvActUser
Just res -> do Just res -> do
let res' = either (over _examResult $ review passingGrade) id res let res' = either (review passingGrade) id <$> res
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
void $ upsertBy void $ upsertBy
(UniqueExamResult eid examUserCsvActUser) (UniqueExamResult eid examUserCsvActUser)
@ -550,11 +545,7 @@ postEUsersR tid ssh csh examn = do
$newline never $newline never
^{nameWidget userDisplayName userSurname} ^{nameWidget userDisplayName userSurname}
$maybe newResult <- examUserCsvActExamResult $maybe newResult <- examUserCsvActExamResult
$case newResult , _{newResult}
$of Left pResult
, _{pResult}
$of Right gResult
, _{gResult}
$nothing $nothing
, _{MsgExamResultNone} , _{MsgExamResultNone}
|] |]
@ -572,14 +563,6 @@ postEUsersR tid ssh csh examn = do
, dbtCsvRenderException = ap getMessageRender . pure :: ExamUserCsvException -> DB Text , dbtCsvRenderException = ap getMessageRender . pure :: ExamUserCsvException -> DB Text
} }
where where
studyFeaturesWidget :: StudyFeaturesId -> Widget
studyFeaturesWidget featId = do
(StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField)
[whamlet|
$newline never
_{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester}
|]
registeredUserName :: Map (E.Value ExamRegistrationId) ExamUserTableData -> ExamRegistrationId -> Widget registeredUserName :: Map (E.Value ExamRegistrationId) ExamUserTableData -> ExamRegistrationId -> Widget
registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname
where where
@ -617,30 +600,39 @@ postEUsersR tid ssh csh examn = do
lookupStudyFeatures :: ExamUserTableCsv -> DB (Maybe StudyFeaturesId) lookupStudyFeatures :: ExamUserTableCsv -> DB (Maybe StudyFeaturesId)
lookupStudyFeatures csv@ExamUserTableCsv{..} = do lookupStudyFeatures csv@ExamUserTableCsv{..} = do
uid <- view _2 <$> guessUser csv uid <- view _2 <$> guessUser csv
studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) -> do oldFeatures <- getBy $ UniqueParticipant uid examCourse
E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) ->
E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree E.distinctOnOrderBy [ E.asc (studyFeatures E.^. StudyFeaturesField)
E.where_ . E.and $ catMaybes , E.asc (studyFeatures E.^. StudyFeaturesDegree)
[ do , E.asc (studyFeatures E.^. StudyFeaturesSemester)] $ do
field <- csvEUserField E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField
return . E.or $ catMaybes E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree
[ Just $ studyTerms E.^. StudyTermsName `E.ciEq` E.just (E.val field) E.where_ . E.and $ catMaybes
, Just $ studyTerms E.^. StudyTermsShorthand `E.ciEq` E.just (E.val field) [ do
, (studyTerms E.^. StudyTermsKey E.==.) . E.val <$> readMay field field <- csvEUserField
] return . E.or $ catMaybes
, do [ Just $ studyTerms E.^. StudyTermsName `E.ciEq` E.just (E.val field)
degree <- csvEUserDegree , Just $ studyTerms E.^. StudyTermsShorthand `E.ciEq` E.just (E.val field)
return . E.or $ catMaybes , (studyTerms E.^. StudyTermsKey E.==.) . E.val <$> readMay field
[ Just $ studyDegree E.^. StudyDegreeName `E.ciEq` E.just (E.val degree) ]
, Just $ studyDegree E.^. StudyDegreeShorthand `E.ciEq` E.just (E.val degree) , do
, (studyDegree E.^. StudyDegreeKey E.==.) . E.val <$> readMay degree degree <- csvEUserDegree
] return . E.or $ catMaybes
, (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvEUserSemester [ Just $ studyDegree E.^. StudyDegreeName `E.ciEq` E.just (E.val degree)
] , Just $ studyDegree E.^. StudyDegreeShorthand `E.ciEq` E.just (E.val degree)
E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid , (studyDegree E.^. StudyDegreeKey E.==.) . E.val <$> readMay degree
E.&&. studyFeatures E.^. StudyFeaturesValid E.==. E.val True ]
E.limit 2 , (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvEUserSemester
return $ studyFeatures E.^. StudyFeaturesId ]
E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
let isActive = studyFeatures E.^. StudyFeaturesValid E.==. E.val True
isActiveOrPrevious = case oldFeatures of
Just (Entity _ CourseParticipant{courseParticipantField = Just sfid})
-> isActive E.||. (E.val sfid E.==. studyFeatures E.^. StudyFeaturesId)
_ -> isActive
E.where_ isActiveOrPrevious -- either active studyFeature or the one previously associated with this course
E.orderBy [E.desc isActiveOrPrevious, E.asc (E.orderByOrd $ studyFeatures E.^. StudyFeaturesType)]
return $ studyFeatures E.^. StudyFeaturesId
case studyFeatures of case studyFeatures of
[E.Value fid] -> return $ Just fid [E.Value fid] -> return $ Just fid
_other _other
@ -648,6 +640,11 @@ postEUsersR tid ssh csh examn = do
, is _Nothing csvEUserDegree , is _Nothing csvEUserDegree
, is _Nothing csvEUserSemester , is _Nothing csvEUserSemester
-> return Nothing -> return Nothing
_other
| Just (Entity _ CourseParticipant{..}) <- oldFeatures
, Just sfid <- courseParticipantField
, E.Value sfid `elem` studyFeatures
-> return $ Just sfid
_other -> throwM ExamUserCsvExceptionNoMatchingStudyFeatures _other -> throwM ExamUserCsvExceptionNoMatchingStudyFeatures
examUsersDBTableValidator = def & defaultSorting [SortAscBy "user-name"] examUsersDBTableValidator = def & defaultSorting [SortAscBy "user-name"]

2
src/Handler/Health.hs
View File

@ -5,8 +5,6 @@ import Import
import qualified Data.Aeson.Encode.Pretty as Aeson import qualified Data.Aeson.Encode.Pretty as Aeson
import qualified Data.Text.Lazy.Builder as Builder import qualified Data.Text.Lazy.Builder as Builder
import Utils.Lens
import qualified Data.UUID as UUID import qualified Data.UUID as UUID
import Data.Semigroup (Min(..), Max(..)) import Data.Semigroup (Min(..), Max(..))

328
src/Handler/Home.hs
View File

@ -2,7 +2,6 @@ module Handler.Home where
import Import import Import
import Utils.Lens
import Handler.Utils import Handler.Utils
import Handler.Utils.Table.Cells import Handler.Utils.Table.Cells
@ -15,78 +14,16 @@ import qualified Database.Esqueleto.Utils as E
getHomeR :: Handler Html getHomeR :: Handler Html
getHomeR = do getHomeR = do
muid <- maybeAuthId muid <- maybeAuthId
upcomingExamsWidget <- for muid $ runDB . homeUpcomingExams
defaultLayout $ do defaultLayout $ do
setTitleI MsgHomeHeading setTitleI MsgHomeHeading
fromMaybe mempty upcomingExamsWidget case muid of
maybe mempty homeUpcomingSheets muid Just uid -> do
homeOpenCourses homeUpcomingExams uid
homeUpcomingSheets uid
Nothing ->
$(i18nWidgetFile "unauth-home")
homeOpenCourses :: Widget
homeOpenCourses = do
cTime <- liftIO getCurrentTime
let tableData :: E.SqlExpr (Entity Course)
-> E.SqlQuery (E.SqlExpr (Entity Course))
tableData course = do
E.where_ $ E.not_ (E.isNothing $ course E.^. CourseRegisterFrom) -- DO: do this with isAuthorized in dbtProj
E.&&. (course E.^. CourseRegisterFrom E.<=. E.val (Just cTime))
E.&&. ( E.isNothing (course E.^. CourseRegisterTo)
E.||. course E.^. CourseRegisterTo E.>=. E.val (Just cTime)
)
return course
colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (HandlerT UniWorX IO) ())
colonnade = mconcat
[ -- dbRow
sortable (Just "term") (i18nCell MsgTerm)
$ \DBRow{ dbrOutput=Entity{entityVal = Course{..}} } ->
anchorCell (TermCourseListR courseTerm) [whamlet|#{courseTerm}|]
, sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
$ \DBRow{ dbrOutput=(Entity _ Course{..}) } ->
anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{unSchoolKey courseSchool}|]
, sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> do
let tid = courseTerm course
ssh = courseSchool course
csh = courseShorthand course
anchorCell (CourseR tid ssh csh CShowR) csh
, sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget
]
courseTable <- liftHandlerT . runDB $ dbTableWidget' def DBTable
{ dbtSQLQuery = tableData
, dbtRowKey = (E.^. CourseId)
, dbtColonnade = colonnade
, dbtProj = return
, dbtSorting = Map.fromList
[ ( "term"
, SortColumn $ \course -> course E.^. CourseTerm
)
, ( "schoolshort"
, SortColumn $ \course -> course E.^. CourseSchool
)
, ( "course"
, SortColumn $ \course -> course E.^. CourseShorthand
)
, ( "deadline"
, SortColumn $ \course -> course E.^. CourseRegisterTo
)
]
, dbtFilter = mempty {- [ ( "term"
, FilterColumn $ \(course `E.InnerJoin` _ `E.InnerJoin` _ ) tids -> if
| Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
)
] -}
, dbtFilterUI = mempty
, dbtStyle = def
, dbtParams = def
, dbtIdent = "open-courses" :: Text
, dbtCsvEncode = noCsvEncode
, dbtCsvDecode = Nothing
}
$(widgetFile "home/openCourses")
homeUpcomingSheets :: UserId -> Widget homeUpcomingSheets :: UserId -> Widget
homeUpcomingSheets uid = do homeUpcomingSheets uid = do
cTime <- liftIO getCurrentTime cTime <- liftIO getCurrentTime
@ -189,134 +126,137 @@ homeUpcomingSheets uid = do
$(widgetFile "home/upcomingSheets") $(widgetFile "home/upcomingSheets")
homeUpcomingExams :: UserId -> Widget
homeUpcomingExams :: UserId -> DB Widget
homeUpcomingExams uid = do homeUpcomingExams uid = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let fortnight = addWeeks 2 now ((Any hasExams, examTable), warningDays) <- liftHandlerT . runDB $ do
let -- code copied and slightly adapted from Handler.Course.getCShowR: User {userWarningDays} <- get404 uid
examDBTable = DBTable{..} let fortnight = addUTCTime userWarningDays now
where let -- code copied and slightly adapted from Handler.Course.getCShowR:
-- for ease of refactoring: examDBTable = DBTable{..}
queryCourse = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) where
queryExam = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) -- for ease of refactoring:
lensCourse = _1 queryCourse = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
lensExam = _2 queryExam = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
lensRegister = _3 . _Just lensCourse = _1
lensOccurrence = _4 . _Just lensExam = _2
lensRegister = _3 . _Just
lensOccurrence = _4 . _Just
dbtSQLQuery ((course `E.InnerJoin` exam) `E.LeftOuterJoin` register `E.LeftOuterJoin` occurrence) = do dbtSQLQuery ((course `E.InnerJoin` exam) `E.LeftOuterJoin` register `E.LeftOuterJoin` occurrence) = do
E.on $ register E.?. ExamRegistrationOccurrence E.==. E.just (occurrence E.?. ExamOccurrenceId) E.on $ register E.?. ExamRegistrationOccurrence E.==. E.just (occurrence E.?. ExamOccurrenceId)
E.on $ register E.?. ExamRegistrationExam E.==. E.just (exam E.^. ExamId) E.on $ register E.?. ExamRegistrationExam E.==. E.just (exam E.^. ExamId)
E.&&. register E.?. ExamRegistrationUser E.==. E.just (E.val uid) E.&&. register E.?. ExamRegistrationUser E.==. E.just (E.val uid)
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
E.where_ $ E.exists $ E.from $ \participant -> E.where_ $ E.exists $ E.from $ \participant ->
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
E.&&. participant E.^. CourseParticipantCourse E.==. course E.^. CourseId E.&&. participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
let regToWithinFortnight = exam E.^. ExamRegisterTo E.<=. E.just (E.val fortnight) let regToWithinFortnight = exam E.^. ExamRegisterTo E.<=. E.just (E.val fortnight)
E.&&. exam E.^. ExamRegisterTo E.>=. E.just (E.val now) E.&&. exam E.^. ExamRegisterTo E.>=. E.just (E.val now)
E.&&. E.isNothing (register E.?. ExamRegistrationId) E.&&. E.isNothing (register E.?. ExamRegistrationId)
startExamFortnight = exam E.^. ExamStart E.<=. E.just (E.val fortnight) startExamFortnight = exam E.^. ExamStart E.<=. E.just (E.val fortnight)
E.&&. exam E.^. ExamStart E.>=. E.just (E.val now) E.&&. exam E.^. ExamStart E.>=. E.just (E.val now)
E.&&. E.isJust (register E.?. ExamRegistrationId) E.&&. E.isJust (register E.?. ExamRegistrationId)
startOccurFortnight = occurrence E.?. ExamOccurrenceStart E.<=. E.just (E.val fortnight) startOccurFortnight = occurrence E.?. ExamOccurrenceStart E.<=. E.just (E.val fortnight)
E.&&. occurrence E.?. ExamOccurrenceStart E.>=. E.just (E.val now) E.&&. occurrence E.?. ExamOccurrenceStart E.>=. E.just (E.val now)
E.&&. E.isJust (register E.?. ExamRegistrationId) E.&&. E.isJust (register E.?. ExamRegistrationId)
earliestOccurrence = E.sub_select $ E.from $ \occ -> do earliestOccurrence = E.sub_select $ E.from $ \occ -> do
E.where_ $ occ E.^. ExamOccurrenceExam E.==. exam E.^. ExamId E.where_ $ occ E.^. ExamOccurrenceExam E.==. exam E.^. ExamId
E.&&. occ E.^. ExamOccurrenceStart E.>=. E.val now E.&&. occ E.^. ExamOccurrenceStart E.>=. E.val now
return $ E.min_ $ occ E.^. ExamOccurrenceStart return $ E.min_ $ occ E.^. ExamOccurrenceStart
startEarliest = E.isNothing (occurrence E.?. ExamOccurrenceId) startEarliest = E.isNothing (occurrence E.?. ExamOccurrenceId)
E.&&. earliestOccurrence E.<=. E.just (E.val fortnight) E.&&. earliestOccurrence E.<=. E.just (E.val fortnight)
-- E.&&. earliestOccurrence E.>=. E.just (E.val now) -- E.&&. earliestOccurrence E.>=. E.just (E.val now)
E.where_ $ regToWithinFortnight E.||. startExamFortnight E.||. startOccurFortnight E.||. startEarliest E.where_ $ regToWithinFortnight E.||. startExamFortnight E.||. startOccurFortnight E.||. startEarliest
return (course, exam, register, occurrence) return (course, exam, register, occurrence)
dbtRowKey = queryExam >>> (E.^. ExamId) dbtRowKey = queryExam >>> (E.^. ExamId)
dbtProj r@DBRow{ dbrOutput } = do dbtProj r@DBRow{ dbrOutput } = do
let Entity _ Exam{..} = view lensExam dbrOutput let Entity _ Exam{..} = view lensExam dbrOutput
Entity _ Course{..} = view lensCourse dbrOutput Entity _ Course{..} = view lensCourse dbrOutput
guardM . hasReadAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EShowR -- check access rights guardM . hasReadAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EShowR -- check access rights
return r return r
dbtColonnade = dbColonnade $ mconcat dbtColonnade = dbColonnade $ mconcat
[ sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } -> [ sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
msgCell courseTerm msgCell courseTerm
, sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } -> , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
msgCell courseSchool msgCell courseSchool
, sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } -> , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) (toWgt courseShorthand) anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) (toWgt courseShorthand)
-- continue here -- continue here
, sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput } -> do , sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput } -> do
let Entity _ Exam{..} = view lensExam dbrOutput let Entity _ Exam{..} = view lensExam dbrOutput
Entity _ Course{..} = view lensCourse dbrOutput Entity _ Course{..} = view lensCourse dbrOutput
indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) examName indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) examName
, sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom , sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
, sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo , sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
, sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput } -> , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput } ->
if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput
-> cell $ formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd -> cell $ formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd
| Entity _ Exam{..} <- view lensExam dbrOutput | Entity _ Exam{..} <- view lensExam dbrOutput
, Just start <- examStart -> cell $ formatTimeRangeW SelFormatDateTime start examEnd , Just start <- examStart -> cell $ formatTimeRangeW SelFormatDateTime start examEnd
| otherwise -> mempty | otherwise -> mempty
{- NOTE: We do not want thoughtless exam registrations, since many people click "register" and don't show up, causing logistic problems. {- NOTE: We do not want thoughtless exam registrations, since many people click "register" and don't show up, causing logistic problems.
Hence we force them here to click twice. Maybe add a captcha where users have to distinguish pictures showing pink elephants and course lecturers. Hence we force them here to click twice. Maybe add a captcha where users have to distinguish pictures showing pink elephants and course lecturers.
, sortable Nothing mempty $ \DBRow{ dbrOutput } -> sqlCell $ do , sortable Nothing mempty $ \DBRow{ dbrOutput } -> sqlCell $ do
let Entity eId Exam{..} = view lensExam dbrOutput let Entity eId Exam{..} = view lensExam dbrOutput
Entity _ Course{..} = view lensCourse dbrOutput Entity _ Course{..} = view lensCourse dbrOutput
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True
isRegistered <- existsBy $ UniqueExamRegistration eId uid isRegistered <- existsBy $ UniqueExamRegistration eId uid
if if
| mayRegister -> do | mayRegister -> do
(examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
return $ wrapForm examRegisterForm def return $ wrapForm examRegisterForm def
{ formAction = Just . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName ERegisterR { formAction = Just . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName ERegisterR
, formEncoding = examRegisterEnctype , formEncoding = examRegisterEnctype
, formSubmit = FormNoSubmit , formSubmit = FormNoSubmit
} }
| isRegistered -> return [whamlet|_{MsgExamRegistered}|] | isRegistered -> return [whamlet|_{MsgExamRegistered}|]
| otherwise -> return mempty | otherwise -> return mempty
-} -}
, sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput } -> sqlCell $ do , sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput } -> sqlCell $ do
let Entity _ Exam{..} = view lensExam dbrOutput let Entity _ Exam{..} = view lensExam dbrOutput
Entity _ Course{..} = view lensCourse dbrOutput Entity _ Course{..} = view lensCourse dbrOutput
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True
let isRegistered = has lensRegister dbrOutput let isRegistered = has lensRegister dbrOutput
label = bool MsgExamNotRegistered MsgExamRegistered isRegistered label = bool MsgExamNotRegistered MsgExamRegistered isRegistered
examUrl = CExamR courseTerm courseSchool courseShorthand examName EShowR examUrl = CExamR courseTerm courseSchool courseShorthand examName EShowR
if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl
| otherwise -> return [whamlet|_{label}|] | otherwise -> return [whamlet|_{label}|]
, sortable (toNothingS "occurrence") (i18nCell MsgExamOccurrence) $ \DBRow{ dbrOutput } -> , sortable (toNothingS "occurrence") (i18nCell MsgExamOccurrence) $ \DBRow{ dbrOutput } ->
if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput
-> textCell examOccurrenceRoom -> textCell examOccurrenceRoom
| otherwise -> mempty | otherwise -> mempty
] ]
dbtSorting = Map.fromList dbtSorting = Map.fromList
[ ("demo-both", SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName)) [ ("demo-both", SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName))
, ("term", SortColumn $ queryCourse >>> (E.^. CourseTerm )) , ("term", SortColumn $ queryCourse >>> (E.^. CourseTerm ))
, ("school", SortColumn $ queryCourse >>> (E.^. CourseSchool )) , ("school", SortColumn $ queryCourse >>> (E.^. CourseSchool ))
, ("course", SortColumn $ queryCourse >>> (E.^. CourseShorthand )) , ("course", SortColumn $ queryCourse >>> (E.^. CourseShorthand ))
, ("name", SortColumn $ queryExam >>> (E.^. ExamName )) , ("name", SortColumn $ queryExam >>> (E.^. ExamName ))
, ("time", SortColumn $ queryExam >>> (E.^. ExamStart )) , ("time", SortColumn $ queryExam >>> (E.^. ExamStart ))
, ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom )) , ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom ))
, ("register-to", SortColumn $ queryExam >>> (E.^. ExamRegisterTo )) , ("register-to", SortColumn $ queryExam >>> (E.^. ExamRegisterTo ))
, ("visible", SortColumn $ queryExam >>> (E.^. ExamVisibleFrom )) , ("visible", SortColumn $ queryExam >>> (E.^. ExamVisibleFrom ))
, ("registered", SortColumn $ queryExam >>> (\exam -> , ("registered", SortColumn $ queryExam >>> (\exam ->
E.exists $ E.from $ \registration -> do E.exists $ E.from $ \registration -> do
E.where_ $ registration E.^. ExamRegistrationUser E.==. E.val uid E.where_ $ registration E.^. ExamRegistrationUser E.==. E.val uid
E.where_ $ registration E.^. ExamRegistrationExam E.==. exam E.^. ExamId E.where_ $ registration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
)) ))
] ]
dbtFilter = Map.empty dbtFilter = Map.empty
dbtFilterUI = const mempty dbtFilterUI = const mempty
dbtStyle = def dbtStyle = def
dbtParams = def dbtParams = def
dbtIdent :: Text dbtIdent :: Text
dbtIdent = "exams" dbtIdent = "exams"
dbtCsvEncode = noCsvEncode dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing dbtCsvDecode = Nothing
examDBTableValidator = def examDBTableValidator = def
& defaultSorting [SortAscBy "time"] & defaultSorting [SortAscBy "time"]
(Any hasExams, examTable) <- dbTable examDBTableValidator examDBTable
return $(widgetFile "home/upcomingExams") (, userWarningDays) <$> dbTable examDBTableValidator examDBTable
$(widgetFile "home/upcomingExams")

1
src/Handler/Material.hs
View File

@ -14,7 +14,6 @@ import qualified Data.Conduit.List as C
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import Database.Esqueleto.Utils.TH import Database.Esqueleto.Utils.TH
import Utils.Lens
import Utils.Form import Utils.Form
import Handler.Utils import Handler.Utils
import Handler.Utils.Delete import Handler.Utils.Delete

148
src/Handler/Profile.hs
View File

@ -5,7 +5,6 @@ import Import
import Handler.Utils import Handler.Utils
import Handler.Utils.Table.Cells import Handler.Utils.Table.Cells
import Utils.Lens
-- import Colonnade hiding (fromMaybe, singleton) -- import Colonnade hiding (fromMaybe, singleton)
-- import Yesod.Colonnade -- import Yesod.Colonnade
import Data.Monoid (Any(..)) import Data.Monoid (Any(..))
@ -16,6 +15,7 @@ import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
-- import Database.Esqueleto ((^.)) -- import Database.Esqueleto ((^.))
import qualified Data.CaseInsensitive as CI
data SettingsForm = SettingsForm data SettingsForm = SettingsForm
@ -25,15 +25,32 @@ data SettingsForm = SettingsForm
, stgDate :: DateTimeFormat , stgDate :: DateTimeFormat
, stgTime :: DateTimeFormat , stgTime :: DateTimeFormat
, stgDownloadFiles :: Bool , stgDownloadFiles :: Bool
, stgWarningDays :: NominalDiffTime
, stgSchools :: Set SchoolId
, stgNotificationSettings :: NotificationSettings , stgNotificationSettings :: NotificationSettings
} }
data NotificationTriggerKind = NTKAll | NTKCourseParticipant | NTKExamParticipant | NTKCorrector | NTKLecturer | NTKAdmin data NotificationTriggerKind
deriving (Eq, Ord, Enum, Bounded, Generic, Typeable) = NTKAll
instance Universe NotificationTriggerKind | NTKCourseParticipant
instance Finite NotificationTriggerKind | NTKExamParticipant
| NTKCorrector
| NTKFunctionary SchoolFunction
deriving (Eq, Ord, Generic, Typeable)
deriveFinite ''NotificationTriggerKind
embedRenderMessage ''UniWorX ''NotificationTriggerKind $ ("NotificationTriggerKind" <>) . mconcat . drop 1 . splitCamel instance RenderMessage UniWorX NotificationTriggerKind where
renderMessage f ls = \case
NTKAll -> mr MsgNotificationTriggerKindAll
NTKCourseParticipant -> mr MsgNotificationTriggerKindCourseParticipant
NTKExamParticipant -> mr MsgNotificationTriggerKindExamParticipant
NTKCorrector -> mr MsgNotificationTriggerKindCorrector
NTKFunctionary SchoolAdmin -> mr MsgNotificationTriggerKindAdmin
NTKFunctionary SchoolLecturer -> mr MsgNotificationTriggerKindLecturer
NTKFunctionary SchoolExamOffice -> mr MsgNotificationTriggerKindExamOffice
NTKFunctionary SchoolEvaluation -> mr MsgNotificationTriggerKindEvaluation
where
mr = renderMessage f ls
makeSettingForm :: Maybe SettingsForm -> Form SettingsForm makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
@ -51,39 +68,40 @@ makeSettingForm template html = do
<*> apopt checkBoxField (fslI MsgDownloadFiles <*> apopt checkBoxField (fslI MsgDownloadFiles
& setTooltip MsgDownloadFilesTip & setTooltip MsgDownloadFilesTip
) (stgDownloadFiles <$> template) ) (stgDownloadFiles <$> template)
<*> areq daysField (fslI MsgWarningDays
& setTooltip MsgWarningDaysTip
) (stgWarningDays <$> template)
<* aformSection MsgFormNotifications <* aformSection MsgFormNotifications
<*> schoolsForm (stgSchools <$> template)
<*> notificationForm (stgNotificationSettings <$> template) <*> notificationForm (stgNotificationSettings <$> template)
return (result, widget) -- no validation required here return (result, widget) -- no validation required here
where where
themeList = [Option (toMessage t) t (toPathPiece t) | t <- universeF] themeList = [Option (toMessage t) t (toPathPiece t) | t <- universeF]
--
-- Version with proper grouping: schoolsForm :: Maybe (Set SchoolId) -> AForm Handler (Set SchoolId)
-- schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandard schoolsForm' mempty
-- makeSettingForm :: Maybe SettingsForm -> Form SettingsForm where
-- makeSettingForm template = identForm FIDsettings $ \html -> do schoolsForm' :: WForm Handler (FormResult (Set SchoolId))
-- (result, widget) <- flip (renderAForm FormStandard) html $ settingsFormT5T2 schoolsForm' = do
-- <$> aFormGroup "Cosmetics" cosmeticsForm allSchools <- liftHandlerT . runDB $ selectList [] [Asc SchoolName]
-- <*> aFormGroup "Notifications" notificationsForm
-- <* submitButton let
-- return (result, widget) -- no validation required here schoolForm (Entity ssh School{schoolName})
-- where = fmap (bool Set.empty $ Set.singleton ssh) <$> wpopt checkBoxField (fsl $ CI.original schoolName) (Set.member ssh <$> template)
-- settingsFormT5T2 :: (Int,Theme,DateTimeFormat,DateTimeFormat,DateTimeFormat) -> (Bool,NotificationSettings) -> SettingsForm
-- settingsFormT5T2 = $(uncurryN 2) . $(uncurryN 5) SettingsForm fold <$> mapM schoolForm allSchools
-- themeList = [Option (display t) t (toPathPiece t) | t <- universeF]
-- cosmeticsForm = (,,,,) schoolsFormView :: (FormResult (Set SchoolId), Widget) -> MForm Handler (FormResult (Set SchoolId), [FieldView UniWorX])
-- <$> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here schoolsFormView (res, fvInput) = do
-- (fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template) mr <- getMessageRender
-- <*> areq (selectField . return $ mkOptionList themeList) let fvLabel = toHtml $ mr MsgUserSchools
-- (fslI MsgTheme) { fsId = Just "theme-select" } (stgTheme <$> template) fvTooltip = Just . toHtml $ mr MsgUserSchoolsTip
-- <*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template) fvRequired = False
-- <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) (stgDate <$> template) fvErrors
-- <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) (stgTime <$> template) | FormFailure (err : _) <- res = Just $ toHtml err
-- notificationsForm = (,) | otherwise = Nothing
-- <$> areq checkBoxField (fslI MsgDownloadFiles fvId <- newIdent
-- & setTooltip MsgDownloadFilesTip return (res, pure FieldView{..})
-- ) (stgDownloadFiles <$> template)
-- <*> (NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True)
-- nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template)
notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings
notificationForm template = wFormToAForm $ do notificationForm template = wFormToAForm $ do
@ -96,13 +114,10 @@ notificationForm template = wFormToAForm $ do
| isAdmin | isAdmin
= return False = return False
| Just uid <- mbUid | Just uid <- mbUid
, NTKAdmin <- nt , NTKFunctionary f <- nt
= fmap not . E.selectExists . E.from $ \userAdmin -> = fmap not . E.selectExists . E.from $ \userFunction ->
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
| Just uid <- mbUid E.&&. userFunction E.^. UserFunctionFunction E.==. E.val f
, NTKLecturer <- nt
= fmap not . E.selectExists . E.from $ \userLecturer ->
E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid
| Just uid <- mbUid | Just uid <- mbUid
, NTKCorrector <- nt , NTKCorrector <- nt
= fmap not . E.selectExists . E.from $ \sheetCorrector -> = fmap not . E.selectExists . E.from $ \sheetCorrector ->
@ -138,9 +153,9 @@ notificationForm template = wFormToAForm $ do
NTSubmissionRated -> Just NTKCourseParticipant NTSubmissionRated -> Just NTKCourseParticipant
NTSheetActive -> Just NTKCourseParticipant NTSheetActive -> Just NTKCourseParticipant
NTSheetSoonInactive -> Just NTKCourseParticipant NTSheetSoonInactive -> Just NTKCourseParticipant
NTSheetInactive -> Just NTKLecturer NTSheetInactive -> Just $ NTKFunctionary SchoolLecturer
NTCorrectionsAssigned -> Just NTKCorrector NTCorrectionsAssigned -> Just NTKCorrector
NTCorrectionsNotDistributed -> Just NTKLecturer NTCorrectionsNotDistributed -> Just $ NTKFunctionary SchoolLecturer
NTUserRightsUpdate -> Just NTKAll NTUserRightsUpdate -> Just NTKAll
NTUserAuthModeUpdate -> Just NTKAll NTUserAuthModeUpdate -> Just NTKAll
NTExamResult -> Just NTKExamParticipant NTExamResult -> Just NTKExamParticipant
@ -174,6 +189,12 @@ getProfileR, postProfileR :: Handler Html
getProfileR = postProfileR getProfileR = postProfileR
postProfileR = do postProfileR = do
(uid, User{..}) <- requireAuthPair (uid, User{..}) <- requireAuthPair
userSchools <- fmap (setOf $ folded . _Value) . runDB . E.select . E.from $ \school -> do
E.where_ . E.exists . E.from $ \userSchool ->
E.where_ $ E.not_ (userSchool E.^. UserSchoolIsOptOut)
E.&&. userSchool E.^. UserSchoolUser E.==. E.val uid
E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId
return $ school E.^. SchoolId
let settingsTemplate = Just SettingsForm let settingsTemplate = Just SettingsForm
{ stgMaxFavourties = userMaxFavourites { stgMaxFavourties = userMaxFavourites
, stgTheme = userTheme , stgTheme = userTheme
@ -181,7 +202,9 @@ postProfileR = do
, stgDate = userDateFormat , stgDate = userDateFormat
, stgTime = userTimeFormat , stgTime = userTimeFormat
, stgDownloadFiles = userDownloadFiles , stgDownloadFiles = userDownloadFiles
, stgSchools = userSchools
, stgNotificationSettings = userNotificationSettings , stgNotificationSettings = userNotificationSettings
, stgWarningDays = userWarningDays
} }
((res,formWidget), formEnctype) <- runFormPost . identifyForm ProfileSettings $ makeSettingForm settingsTemplate ((res,formWidget), formEnctype) <- runFormPost . identifyForm ProfileSettings $ makeSettingForm settingsTemplate
@ -193,6 +216,7 @@ postProfileR = do
, UserDateFormat =. stgDate , UserDateFormat =. stgDate
, UserTimeFormat =. stgTime , UserTimeFormat =. stgTime
, UserDownloadFiles =. stgDownloadFiles , UserDownloadFiles =. stgDownloadFiles
, UserWarningDays =. stgWarningDays
, UserNotificationSettings =. stgNotificationSettings , UserNotificationSettings =. stgNotificationSettings
] ]
when (stgMaxFavourties < userMaxFavourites) $ do when (stgMaxFavourties < userMaxFavourites) $ do
@ -202,6 +226,25 @@ postProfileR = do
, OffsetBy stgMaxFavourties , OffsetBy stgMaxFavourties
] ]
mapM_ delete oldFavs mapM_ delete oldFavs
let
symDiff = (stgSchools `Set.difference` userSchools) `Set.union` (userSchools `Set.difference` stgSchools)
forM_ symDiff $ \ssh -> if
| ssh `Set.member` stgSchools
-> void $ upsert UserSchool
{ userSchoolSchool = ssh
, userSchoolUser = uid
, userSchoolIsOptOut = False
}
[ UserSchoolIsOptOut =. False
]
| otherwise
-> void $ upsert UserSchool
{ userSchoolSchool = ssh
, userSchoolUser = uid
, userSchoolIsOptOut = True
}
[ UserSchoolIsOptOut =. True
]
addMessageI Info MsgSettingsUpdate addMessageI Info MsgSettingsUpdate
redirect $ ProfileR :#: ProfileSettings redirect $ ProfileR :#: ProfileSettings
@ -250,14 +293,7 @@ getProfileDataR = do
makeProfileData :: Entity User -> DB Widget makeProfileData :: Entity User -> DB Widget
makeProfileData (Entity uid User{..}) = do makeProfileData (Entity uid User{..}) = do
-- MsgRenderer mr <- getMsgRenderer -- MsgRenderer mr <- getMsgRenderer
admin_rights <- E.select $ E.from $ \(adright `E.InnerJoin` school) -> do functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] []
E.where_ $ adright E.^. UserAdminUser E.==. E.val uid
E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId
return (school E.^. SchoolShorthand)
lecturer_rights <- E.select $ E.from $ \(lecright `E.InnerJoin` school) -> do
E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid
E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId
return (school E.^. SchoolShorthand)
lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
@ -309,7 +345,7 @@ mkOwnedCoursesTable =
return $ indicatorCell -- return True if one cell is produced here return $ indicatorCell -- return True if one cell is produced here
`mappend` termCell tid `mappend` termCell tid
, sortable (Just "school") (i18nCell MsgCourseSchool) $ , sortable (Just "school") (i18nCell MsgCourseSchool) $
schoolCell <$> view (_dbrOutput . _1 . re _Just) schoolCell <$> view (_dbrOutput . _1)
<*> view (_dbrOutput . _2 ) <*> view (_dbrOutput . _2 )
, sortable (Just "course") (i18nCell MsgCourse) $ , sortable (Just "course") (i18nCell MsgCourse) $
courseCellCL <$> view _dbrOutput courseCellCL <$> view _dbrOutput
@ -357,8 +393,8 @@ mkEnrolledCoursesTable =
, sortable (Just "term") (i18nCell MsgTerm) $ , sortable (Just "term") (i18nCell MsgTerm) $
termCell <$> view (_dbrOutput . _1 . _entityVal . _courseTerm) termCell <$> view (_dbrOutput . _1 . _entityVal . _courseTerm)
, sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $ , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $
schoolCell <$> view ( _courseTerm . re _Just) schoolCell <$> view _courseTerm
<*> view _courseSchool <*> view _courseSchool
, sortable (Just "course") (i18nCell MsgCourse) $ , sortable (Just "course") (i18nCell MsgCourse) $
courseCell <$> view (_dbrOutput . _1 . _entityVal) courseCell <$> view (_dbrOutput . _1 . _entityVal)
, sortable (Just "time") (i18nCell MsgRegistered) $ do , sortable (Just "time") (i18nCell MsgRegistered) $ do
@ -425,7 +461,7 @@ mkSubmissionTable =
, sortable (Just "term") (i18nCell MsgTerm) $ , sortable (Just "term") (i18nCell MsgTerm) $
termCell <$> view (_dbrOutput . _1 . _1) termCell <$> view (_dbrOutput . _1 . _1)
, sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $ , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $
schoolCell <$> view ( _1. re _Just) schoolCell <$> view _1
<*> view _2 <*> view _2
, sortable (Just "course") (i18nCell MsgCourse) $ , sortable (Just "course") (i18nCell MsgCourse) $
courseCellCL <$> view (_dbrOutput . _1) courseCellCL <$> view (_dbrOutput . _1)
@ -507,7 +543,7 @@ mkSubmissionGroupTable =
, sortable (Just "term") (i18nCell MsgTerm) $ , sortable (Just "term") (i18nCell MsgTerm) $
termCell <$> view (_dbrOutput . _1 . _1) termCell <$> view (_dbrOutput . _1 . _1)
, sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $ , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $
schoolCell <$> view ( _1. re _Just) schoolCell <$> view _1
<*> view _2 <*> view _2
, sortable (Just "course") (i18nCell MsgCourse) $ , sortable (Just "course") (i18nCell MsgCourse) $
courseCellCL <$> view (_dbrOutput . _1) courseCellCL <$> view (_dbrOutput . _1)

165
src/Handler/School.hs
View File

@ -1,10 +1,169 @@
module Handler.School where module Handler.School where
import Import import Import
import Handler.Utils
import Handler.Utils.Table.Columns
import qualified Database.Esqueleto as E
import qualified Data.Set as Set
import qualified Data.CaseInsensitive as CI
import qualified Data.Text as Text
getSchoolListR :: Handler Html getSchoolListR :: Handler Html
getSchoolListR = error "getSchoolListR: Not implemented" getSchoolListR = do
let
schoolLink :: SchoolId -> SomeRoute UniWorX
schoolLink ssh = SomeRoute $ SchoolR ssh SchoolEditR
getSchoolShowR :: SchoolId -> Handler Html dbtSQLQuery :: E.SqlExpr (Entity School) -> E.SqlQuery _
getSchoolShowR = error "getSchoolShowR: Not implemented" dbtSQLQuery = return
dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) (DBRow (Entity School))
dbtProj = return
dbtRowKey = (E.^. SchoolId)
dbtColonnade :: Colonnade Sortable _ _
dbtColonnade = mconcat
[ colSchoolShort $ _dbrOutput . _entityKey
, anchorColonnade (views (_dbrOutput . _entityKey) schoolLink) $ colSchoolName (_dbrOutput . _entityVal . _schoolName)
]
dbtSorting = mconcat
[ sortSchoolShort $ to (E.^. SchoolId)
, sortSchoolName $ to (E.^. SchoolName)
]
dbtFilter = mempty
dbtFilterUI = mempty
dbtStyle = def
dbtParams = def
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
dbtIdent :: Text
dbtIdent = "schools"
psValidator = def
& defaultSorting [SortAscBy "school-name"]
table <- runDB $ dbTableWidget' psValidator DBTable{..}
let title = MsgMenuSchoolList
siteLayoutMsg title $ do
setTitleI title
table
data SchoolForm = SchoolForm
{ sfShorthand :: CI Text
, sfName :: CI Text
, sfOrgUnits :: Set (CI Text)
}
mkSchoolForm :: Maybe SchoolId -> Maybe SchoolForm -> Form SchoolForm
mkSchoolForm mSsh template = renderAForm FormStandard $ SchoolForm
<$> maybe (\f fs -> areq f fs (sfShorthand <$> template)) (\ssh f fs -> aforced f fs (unSchoolKey ssh)) mSsh ciField (fslI MsgSchoolShort)
<*> areq ciField (fslI MsgSchoolName) (sfName <$> template)
<*> (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip) <$> massInputListA (textField & addDatalist ldapOrgs) (const "") (const Nothing) ("ldap-organisations" :: Text) (fslI MsgSchoolLdapOrganisations & setTooltip MsgSchoolLdapOrganisationsTip) False (fmap CI.original . Set.toList . sfOrgUnits <$> template))
where
ldapOrgs :: WidgetT UniWorX IO (Set (CI Text))
ldapOrgs = liftHandlerT . runDB $
setOf (folded . _entityVal . _schoolLdapOrgUnit) <$> selectList [] []
schoolToForm :: SchoolId -> DB (Form SchoolForm)
schoolToForm ssh = do
School{..} <- get404 ssh
ldapFrags <- selectList [SchoolLdapSchool ==. Just ssh] []
return . mkSchoolForm (Just ssh) $ Just SchoolForm
{ sfShorthand = schoolShorthand
, sfName = schoolName
, sfOrgUnits = setOf (folded . _entityVal . _schoolLdapOrgUnit) ldapFrags
}
getSchoolEditR, postSchoolEditR :: SchoolId -> Handler Html
getSchoolEditR = postSchoolEditR
postSchoolEditR ssh = do
sForm <- runDB $ schoolToForm ssh
((sfResult, sfView), sfEnctype) <- runFormPost sForm
formResult sfResult $ \SchoolForm{..} -> do
runDB $ do
update ssh [ SchoolName =. sfName ]
forM_ sfOrgUnits $ \schoolLdapOrgUnit ->
void $ upsert SchoolLdap
{ schoolLdapSchool = Just ssh
, ..
}
[ SchoolLdapSchool =. Just ssh
]
deleteWhere [SchoolLdapSchool ==. Just ssh, SchoolLdapOrgUnit /<-. Set.toList sfOrgUnits]
addMessageI Success $ MsgSchoolUpdated ssh
redirect $ SchoolR ssh SchoolEditR
let sfView' = wrapForm sfView FormSettings
{ formMethod = POST
, formAction = Just . SomeRoute $ SchoolR ssh SchoolEditR
, formEncoding = sfEnctype
, formAttrs = []
, formSubmit = FormSubmit
, formAnchor = Nothing :: Maybe Text
}
siteLayoutMsg (MsgSchoolTitle ssh) $ do
setTitleI $ MsgSchoolTitle ssh
sfView'
getSchoolNewR, postSchoolNewR :: Handler Html
getSchoolNewR = postSchoolNewR
postSchoolNewR = do
uid <- requireAuthId
((sfResult, sfView), sfEnctype) <- runFormPost $ mkSchoolForm Nothing Nothing
formResult sfResult $ \SchoolForm{..} -> do
let ssh = SchoolKey sfShorthand
insertOkay <- runDB $ do
didInsert <- is _Just <$> insertUnique School
{ schoolShorthand = sfShorthand
, schoolName = sfName
}
when didInsert $ do
insert_ UserFunction
{ userFunctionUser = uid
, userFunctionSchool = ssh
, userFunctionFunction = SchoolAdmin
}
forM_ sfOrgUnits $ \schoolLdapOrgUnit ->
void $ upsert SchoolLdap
{ schoolLdapSchool = Just ssh
, ..
}
[ SchoolLdapSchool =. Just ssh
]
return didInsert
if
| insertOkay -> do
addMessageI Success $ MsgSchoolCreated ssh
redirect $ SchoolR ssh SchoolEditR
| otherwise
-> addMessageI Error $ MsgSchoolExists ssh
let sfView' = wrapForm sfView FormSettings
{ formMethod = POST
, formAction = Just $ SomeRoute SchoolNewR
, formEncoding = sfEnctype
, formAttrs = []
, formSubmit = FormSubmit
, formAnchor = Nothing :: Maybe Text
}
siteLayoutMsg MsgTitleSchoolNew $ do
setTitleI MsgTitleSchoolNew
sfView'

17
src/Handler/Sheet.hs
View File

@ -49,11 +49,6 @@ import Data.Map (Map, (!))
import Data.Monoid (Any(..)) import Data.Monoid (Any(..))
-- import Control.Lens
import Utils.Lens
--import qualified Data.Aeson as Aeson
import Control.Monad.Random.Class (MonadRandom(..)) import Control.Monad.Random.Class (MonadRandom(..))
import Utils.Sql import Utils.Sql
@ -186,7 +181,7 @@ getSheetListR tid ssh csh = do
let let
hasSFT :: (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool) -> [SheetFileType] hasSFT :: (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool) -> [SheetFileType]
hasSFT (E.Value hasExercise, E.Value hasHint, E.Value hasSolution, E.Value hasMarking) hasSFT (E.Value hasExercise, E.Value hasHint, E.Value hasSolution, E.Value hasMarking)
= [ sft | sft <- [minBound..maxBound] = [ sft | sft <- universeF
, sft /= SheetExercise || hasExercise , sft /= SheetExercise || hasExercise
, sft /= SheetHint || hasHint , sft /= SheetHint || hasHint
, sft /= SheetSolution || hasSolution , sft /= SheetSolution || hasSolution
@ -204,7 +199,7 @@ getSheetListR tid ssh csh = do
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
sheetFilter :: SheetName -> DB Bool sheetFilter :: SheetName -> DB Bool
sheetFilter sheetName = (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False sheetFilter sheetName = hasReadAccessTo $ CSheetR tid ssh csh sheetName SShowR
sheetCol = widgetColonnade . mconcat $ sheetCol = widgetColonnade . mconcat $
[ -- dbRow , [ -- dbRow ,
@ -220,9 +215,9 @@ getSheetListR tid ssh csh = do
| let existingSFTs = hasSFT existFiles | let existingSFTs = hasSFT existFiles
, sft <- [minBound..maxBound] , sft <- [minBound..maxBound]
, let link = CSheetR tid ssh csh sheetName $ SZipR sft , let link = CSheetR tid ssh csh sheetName $ SZipR sft
, let icn = toWidget $ sheetFile2markup sft , let icn = toWgt $ sheetFile2markup sft
, let icnCell = if sft `elem` existingSFTs , let icnCell = if sft `elem` existingSFTs
then linkEmptyCell link icn then linkEitherCell link (icn, [whamlet|&emsp;|])
else spacerCell else spacerCell
] id & cellAttrs <>~ [("class","list--inline list--space-separated")] ] id & cellAttrs <>~ [("class","list--inline list--space-separated")]
, sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom) , sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
@ -726,7 +721,7 @@ correctorForm shid = wFormToAForm $ do
-- when (not (Map.null loads) && applyDefaultLoads) $ -- Alert Message -- when (not (Map.null loads) && applyDefaultLoads) $ -- Alert Message
-- addMessageI Warning MsgCorrectorsDefaulted -- addMessageI Warning MsgCorrectorsDefaulted
when (not (Map.null loads) && applyDefaultLoads) $ -- Alert Notification when (not (Map.null loads) && applyDefaultLoads) $ -- Alert Notification
wformMessage =<< messageI Warning MsgCorrectorsDefaulted wformMessage =<< messageIconI Warning IconNoCorrectors MsgCorrectorsDefaulted
let let
@ -907,7 +902,7 @@ correctorInvitationConfig = InvitationConfig{..}
Course{..} <- get404 sheetCourse Course{..} <- get404 sheetCourse
return . SomeMessage $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName return . SomeMessage $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName
invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|] invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|]
invitationTokenConfig _ _ = do invitationTokenConfig _ _ = do
itAuthority <- liftHandlerT requireAuthId itAuthority <- liftHandlerT requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing

4
src/Handler/Submission.hs
View File

@ -6,8 +6,6 @@ import Import
import Jobs import Jobs
import Utils.Lens
-- import Yesod.Form.Bootstrap3 -- import Yesod.Form.Bootstrap3
import Handler.Utils import Handler.Utils
@ -102,7 +100,7 @@ submissionUserInvitationConfig = InvitationConfig{..}
invitationHeading (Entity _ Submission{..}) _ = do invitationHeading (Entity _ Submission{..}) _ = do
Sheet{..} <- getJust submissionSheet Sheet{..} <- getJust submissionSheet
return . SomeMessage $ MsgSubmissionUserInviteHeading sheetName return . SomeMessage $ MsgSubmissionUserInviteHeading sheetName
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSubmissionUserInviteExplanation}|] invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSubmissionUserInviteExplanation}|]
invitationTokenConfig (Entity _ Submission{..}) _ = do invitationTokenConfig (Entity _ Submission{..}) _ = do
Sheet{..} <- getJust submissionSheet Sheet{..} <- getJust submissionSheet
Course{..} <- getJust sheetCourse Course{..} <- getJust sheetCourse

2
src/Handler/SystemMessage.hs
View File

@ -11,8 +11,6 @@ import qualified Data.List.NonEmpty as NonEmpty
import Handler.Utils import Handler.Utils
import Handler.Utils.Table.Cells import Handler.Utils.Table.Cells
import Utils.Lens
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
-- htmlField' moved to Handler.Utils.Form/Fields -- htmlField' moved to Handler.Utils.Form/Fields

11
src/Handler/Term.hs
View File

@ -5,8 +5,6 @@ import Handler.Utils
import Handler.Utils.Table.Cells import Handler.Utils.Table.Cells
import qualified Data.Map as Map import qualified Data.Map as Map
import Utils.Lens
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Data.Set as Set import qualified Data.Set as Set
@ -259,7 +257,14 @@ newTermForm template html = do
= aforced termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) tid = aforced termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) tid
| otherwise | otherwise
= areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) Nothing = areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) Nothing
holidayForm = formToAForm . over (mapped._2) pure $ massInputList dayField (const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder)) (const Nothing) ("holidays" :: Text) (fslI MsgTermHolidays & setTooltip MsgMassInputTip) True (tftHolidays template) mempty holidayForm = massInputListA
dayField
(const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder))
(const Nothing)
("holidays" :: Text)
(fslI MsgTermHolidays & setTooltip MsgMassInputTip)
True
(tftHolidays template)
(result, widget) <- flip (renderAForm FormStandard) html $ Term (result, widget) <- flip (renderAForm FormStandard) html $ Term
<$> tidForm <$> tidForm
<*> areq dayField (fslI MsgTermStartDay & setTooltip MsgTermStartDayTooltip) (tftStart template) <*> areq dayField (fslI MsgTermStartDay & setTooltip MsgTermStartDayTooltip) (tftStart template)

4
src/Handler/Tutorial.hs
View File

@ -25,8 +25,6 @@ import qualified Data.CaseInsensitive as CI
import qualified Data.Text as Text import qualified Data.Text as Text
import Utils.Lens
import Data.Aeson hiding (Result(..)) import Data.Aeson hiding (Result(..))
import Text.Hamlet (ihamlet) import Text.Hamlet (ihamlet)
@ -260,7 +258,7 @@ tutorInvitationConfig = InvitationConfig{..}
Course{..} <- get404 tutorialCourse Course{..} <- get404 tutorialCourse
return . SomeMessage $ MsgMailSubjectTutorInvitation courseTerm courseSchool courseShorthand tutorialName return . SomeMessage $ MsgMailSubjectTutorInvitation courseTerm courseSchool courseShorthand tutorialName
invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|] invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|]
invitationTokenConfig _ _ = do invitationTokenConfig _ _ = do
itAuthority <- liftHandlerT requireAuthId itAuthority <- liftHandlerT requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing

1
src/Handler/Tutorial/Users.hs
View File

@ -4,7 +4,6 @@ module Handler.Tutorial.Users
import Import import Import
import Utils.Lens
import Utils.Form import Utils.Form
-- import Utils.DB -- import Utils.DB
import Handler.Utils import Handler.Utils

276
src/Handler/Users.hs
View File

@ -13,8 +13,6 @@ import Handler.Utils.Invitations
import qualified Auth.LDAP as Auth import qualified Auth.LDAP as Auth
import Utils.Lens
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.Set as Set import qualified Data.Set as Set
@ -60,30 +58,20 @@ getUsersR = do
-- (AdminUserR <$> encrypt uid) -- (AdminUserR <$> encrypt uid)
-- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName) -- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName)
, sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication , sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication
, sortable Nothing (i18nCell MsgAdminFor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do , flip foldMap universeF $ \function ->
schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userAdmin) -> do sortable Nothing (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
E.on $ school E.^. SchoolId E.==. userAdmin E.^. UserAdminSchool schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid E.on $ school E.^. SchoolId E.==. userFunction E.^. UserFunctionSchool
E.orderBy [E.asc $ school E.^. SchoolShorthand] E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
return $ school E.^. SchoolShorthand E.&&. userFunction E.^. UserFunctionFunction E.==. E.val function
return [whamlet| E.orderBy [E.asc $ school E.^. SchoolShorthand]
$newline never return $ school E.^. SchoolShorthand
<ul .list--inline .list--comma-separated> return [whamlet|
$forall (E.Value sh) <- schools $newline never
<li>#{sh} <ul .list--inline .list--comma-separated>
|] $forall (E.Value sh) <- schools
, sortable Nothing (i18nCell MsgLecturerFor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do <li>#{sh}
schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userLecturer) -> do |]
E.on $ school E.^. SchoolId E.==. userLecturer E.^. UserLecturerSchool
E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid
E.orderBy [E.asc $ school E.^. SchoolShorthand]
return $ school E.^. SchoolShorthand
return [whamlet|
$newline never
<ul .list--inline .list--comma-separated>
$forall (E.Value sh) <- schools
<li>#{sh}
|]
, sortable Nothing mempty $ \DBRow{ dbrOutput = Entity uid _ } -> cell $ do , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity uid _ } -> cell $ do
cID <- encrypt uid cID <- encrypt uid
mayHijack <- (== Authorized) <$> evalAccess (AdminHijackUserR cID) True mayHijack <- (== Authorized) <$> evalAccess (AdminHijackUserR cID) True
@ -144,14 +132,8 @@ getUsersR = do
, ( "school", FilterColumn $ \user criterion -> if , ( "school", FilterColumn $ \user criterion -> if
| Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool) | Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> let schools = E.valList (Set.toList criterion) in | otherwise -> let schools = E.valList (Set.toList criterion) in
E.exists ( E.from $ \ulectr -> do E.exists . E.from $ \ufunc -> E.where_ $ ufunc E.^. UserFunctionUser E.==. user E.^. UserId
E.where_ $ ulectr E.^. UserLecturerUser E.==. user E.^. UserId E.&&. ufunc E.^. UserFunctionFunction `E.in_` schools
E.where_ $ ulectr E.^. UserLecturerSchool `E.in_` schools
) E.||.
E.exists ( E.from $ \uadmin -> do
E.where_ $ uadmin E.^. UserAdminUser E.==. user E.^. UserId
E.where_ $ uadmin E.^. UserAdminSchool `E.in_` schools
)
) )
] ]
, dbtFilterUI = \mPrev -> mconcat , dbtFilterUI = \mPrev -> mconcat
@ -201,56 +183,57 @@ getAdminUserR = postAdminUserR
postAdminUserR uuid = do postAdminUserR uuid = do
adminId <- requireAuthId adminId <- requireAuthId
uid <- decrypt uuid uid <- decrypt uuid
let fromSchoolList = Set.fromList . map (userAdminSchool . entityVal) (user@User{..}, adminSchools, functions, schools) <- runDB $ do
let unValueRights (school, E.Value isAdmin, E.Value isLecturer) = (school,isAdmin,isLecturer) user <- get404 uid
(user@User{..}, fromSchoolList -> adminSchools, fmap unValueRights -> userRights) <- runDB $ (,,)
<$> get404 uid schools <- E.select . E.from $ \(school `E.LeftOuterJoin` userFunction) -> do
<*> selectList [UserAdminUser ==. adminId] [] E.on $ userFunction E.?. UserFunctionSchool E.==. E.just (school E.^. SchoolId)
<*> E.select ( E.from $ \school -> do E.&&. userFunction E.?. UserFunctionUser E.==. E.just (E.val uid)
E.orderBy [E.asc $ school E.^. SchoolName] let isAdmin = E.exists . E.from $ \adminFunction ->
let schAdmin = E.exists $ E.from $ \userAdmin -> do E.where_ $ adminFunction E.^. UserFunctionUser E.==. E.val adminId
E.where_ $ userAdmin E.^. UserAdminSchool E.==. school E.^. SchoolId E.&&. adminFunction E.^. UserFunctionSchool E.==. school E.^. SchoolId
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid E.&&. adminFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
let schLecturer = E.exists $ E.from $ \userLecturer -> do return (school, userFunction E.?. UserFunctionFunction, isAdmin)
E.where_ $ userLecturer E.^. UserLecturerSchool E.==. school E.^. SchoolId
E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid return ( user
return (school,schAdmin,schLecturer) , setOf (folded . filtered (view $ _3 . _Value) . _1 . _entityKey) schools
) , setOf (folded . folding (\x -> (,) <$> preview (_2 . _Value . _Just) x <*> preview (_1 . _entityKey) x)) schools
, setOf (folded . _1) schools
)
let allFunctions = Set.fromList universeF
allSchools = Set.mapMonotonic entityKey schools
-- above data is needed for both form generation and result evaluation -- above data is needed for both form generation and result evaluation
let userRightsForm :: Form [(SchoolId, Bool, Bool)] let userRightsForm :: Form (Set (SchoolFunction, SchoolId))
userRightsForm = identifyForm FIDuserRights $ \csrf -> do userRightsForm = identifyForm FIDuserRights $ \csrf -> do
boxRights <- forM userRights $ \(school@(Entity sid _), isAdmin, isLecturer) -> boxRights <- sequence . flip Map.fromSet (allFunctions `setProduct` allSchools) $ \(function, sid) -> if
if Set.member sid adminSchools | sid `Set.member` adminSchools
then do -> mpopt checkBoxField "" . Just $ (function, sid) `Set.member` functions
cbAdmin <- mreq checkBoxField "" (Just isAdmin) | otherwise
cbLecturer <- mreq checkBoxField "" (Just isLecturer) -> mforced checkBoxField "" $ (function, sid) `Set.member` functions
return (school, cbAdmin, cbLecturer) let result = Map.keysSet . Map.filter id <$> mapM (view _1) boxRights
else do return (result, $(widgetFile "widgets/user-rights-form/user-rights-form"))
cbAdmin <- mforced checkBoxField "" isAdmin
cbLecturer <- mforced checkBoxField "" isLecturer
return (school, cbAdmin, cbLecturer)
let result = forM boxRights $ \(Entity sid _, (resAdmin,_), (resLecturer, _)) ->
(,,) <$> pure sid <*> resAdmin <*> resLecturer
return (result,$(widgetFile "widgets/user-rights-form/user-rights-form"))
userAuthenticationForm :: Form ButtonAuthMode userAuthenticationForm :: Form ButtonAuthMode
userAuthenticationForm = buttonForm' $ if userAuthenticationForm = buttonForm' $ if
| userAuthentication == AuthLDAP -> [BtnAuthPWHash] | userAuthentication == AuthLDAP -> [BtnAuthPWHash]
| otherwise -> [BtnAuthLDAP, BtnPasswordReset] | otherwise -> [BtnAuthLDAP, BtnPasswordReset]
let userRightsAction changes = do let userRightsAction changes = do
runDBJobs $ do let symDiff = (changes `Set.difference` functions) `Set.union` (functions `Set.difference` changes)
forM_ changes $ \(sid, userAdmin, userLecturer) -> updates = (allFunctions `setProduct` adminSchools) `Set.intersection` symDiff
if Set.notMember sid adminSchools if
then return () | not $ Set.null updates -> runDBJobs $ do
else do $logInfoS "user-rights-update" $ tshow updates
if userAdmin forM_ updates $ \(function, sid) -> do
then void . insertUnique $ UserAdmin uid sid $logDebugS "user-rights-update" [st|#{tshow (function, sid)}: #{tshow (Set.member (function, sid) functions)} → #{tshow (Set.member (function,sid) changes)}|]
else deleteBy $ UniqueUserAdmin uid sid if
if userLecturer | (function, sid) `Set.member` changes
then void . insertUnique $ UserLecturer uid sid -> void . insertUnique $ UserFunction uid sid function
else deleteBy $ UniqueSchoolLecturer uid sid | otherwise
-- Note: deleteWhere would not work well here since we filter by adminSchools -> deleteBy $ UniqueUserFunction uid sid function
queueDBJob . JobQueueNotification $ NotificationUserRightsUpdate uid (over _1 (schoolShorthand . entityVal) <$> userRights) -- original rights to check for difference queueDBJob . JobQueueNotification . NotificationUserRightsUpdate uid $ Set.mapMonotonic (over _2 unSchoolKey) functions -- original rights to check for difference
addMessageI Info MsgAccessRightsSaved addMessageI Success MsgAccessRightsSaved
| otherwise
-> addMessageI Info MsgAccessRightsNotChanged
redirect $ AdminUserR uuid redirect $ AdminUserR uuid
userAuthenticationAction = \case userAuthenticationAction = \case
@ -437,54 +420,76 @@ postUserPasswordR cID = do
} }
instance IsInvitableJunction UserLecturer where instance IsInvitableJunction UserFunction where
type InvitationFor UserLecturer = School type InvitationFor UserFunction = School
data InvitableJunction UserLecturer = JunctionUserLecturer data InvitableJunction UserFunction = JunctionUserFunction
{ jFunction :: SchoolFunction
}
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
data InvitationDBData UserLecturer = InvDBDataUserLecturer data InvitationDBData UserFunction = InvDBDataUserFunction
{ invDBUserFunctionDeadline :: UTCTime
}
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
data InvitationTokenData UserLecturer = InvTokenDataUserLecturer data InvitationTokenData UserFunction = InvTokenDataUserFunction
{ invTokenUserLecturerSchool :: SchoolShorthand { invTokenUserFunctionSchool :: SchoolShorthand
, invTokenUserFunctionFunction :: SchoolFunction
} }
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
_InvitableJunction = iso _InvitableJunction = iso
(\UserLecturer{..} -> (userLecturerUser, userLecturerSchool, JunctionUserLecturer)) (\UserFunction{..} -> (userFunctionUser, userFunctionSchool, JunctionUserFunction userFunctionFunction))
(\(userLecturerUser, userLecturerSchool, JunctionUserLecturer) -> UserLecturer{..}) (\(userFunctionUser, userFunctionSchool, JunctionUserFunction userFunctionFunction) -> UserFunction{..})
instance ToJSON (InvitableJunction UserLecturer) where instance ToJSON (InvitableJunction UserFunction) where
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 } toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 1 } , fieldLabelModifier = camelToPathPiece' 1
instance FromJSON (InvitableJunction UserLecturer) where }
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 } toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 1
, fieldLabelModifier = camelToPathPiece' 1
}
instance FromJSON (InvitableJunction UserFunction) where
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1
, fieldLabelModifier = camelToPathPiece' 1
}
instance ToJSON (InvitationDBData UserLecturer) where instance ToJSON (InvitationDBData UserFunction) where
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 } toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
instance FromJSON (InvitationDBData UserLecturer) where instance FromJSON (InvitationDBData UserFunction) where
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
instance ToJSON (InvitationTokenData UserLecturer) where instance ToJSON (InvitationTokenData UserFunction) where
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
instance FromJSON (InvitationTokenData UserLecturer) where instance FromJSON (InvitationTokenData UserFunction) where
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
lecturerInvitationConfig :: InvitationConfig UserLecturer functionInvitationConfig :: InvitationConfig UserFunction
lecturerInvitationConfig = InvitationConfig{..} functionInvitationConfig = InvitationConfig{..}
where where
invitationRoute _ _ = return AdminLecturerInviteR invitationRoute _ _ = return AdminFunctionaryInviteR
invitationResolveFor InvTokenDataUserLecturer{..} = return $ SchoolKey invTokenUserLecturerSchool invitationResolveFor InvTokenDataUserFunction{..} = return $ SchoolKey invTokenUserFunctionSchool
invitationSubject (Entity _ School{..}) _ = return . SomeMessage $ MsgMailSubjectSchoolLecturerInvitation schoolName invitationSubject (Entity _ School{..}) (_, InvTokenDataUserFunction{..}) = do
invitationHeading (Entity _ School{..}) _ = return . SomeMessage $ MsgMailSchoolLecturerInviteHeading schoolName MsgRenderer mr <- getMsgRenderer
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSchoolLecturerInviteExplanation}|] return . SomeMessage . MsgMailSubjectSchoolFunctionInvitation schoolName $ mr invTokenUserFunctionFunction
invitationTokenConfig _ _ = do invitationHeading (Entity _ School{..}) (_, InvTokenDataUserFunction{..}) = do
MsgRenderer mr <- getMsgRenderer
return . SomeMessage . MsgMailSchoolFunctionInviteHeading schoolName $ mr invTokenUserFunctionFunction
invitationExplanation _ (_, InvTokenDataUserFunction{..}) = do
MsgRenderer mr <- getMsgRenderer
return [ihamlet|_{SomeMessage $ MsgSchoolFunctionInviteExplanation (mr $ SomeMessage invTokenUserFunctionFunction)}|]
invitationTokenConfig _ (InvDBDataUserFunction{..}, _) = do
itAuthority <- liftHandlerT requireAuthId itAuthority <- liftHandlerT requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing let itExpiresAt = Just $ Just invDBUserFunctionDeadline
itAddAuth = Nothing
itStartsAt = Nothing
return InvitationTokenConfig{..}
invitationRestriction _ _ = return Authorized invitationRestriction _ _ = return Authorized
invitationForm _ _ _ = pure $ (JunctionUserLecturer, ()) invitationForm _ (_, InvTokenDataUserFunction{..}) _ = pure $ (JunctionUserFunction invTokenUserFunctionFunction, ())
invitationInsertHook _ _ _ _ = id invitationInsertHook _ _ _ _ = id
invitationSuccessMsg (Entity _ School{..}) _ = return . SomeMessage $ MsgSchoolLecturerInvitationAccepted schoolName invitationSuccessMsg (Entity _ School{..}) (Entity _ UserFunction{..}) = do
MsgRenderer mr <- getMsgRenderer
return . SomeMessage . MsgSchoolFunctionInvitationAccepted schoolName $ mr userFunctionFunction
invitationUltDest (Entity ssh _) _ = do invitationUltDest (Entity ssh _) _ = do
currentTerm <- E.select . E.from $ \term -> do currentTerm <- E.select . E.from $ \term -> do
E.where_ $ term E.^. TermActive E.where_ $ term E.^. TermActive
@ -496,39 +501,50 @@ lecturerInvitationConfig = InvitationConfig{..}
_other -> CourseListR _other -> CourseListR
getAdminNewLecturerInviteR, postAdminNewLecturerInviteR :: Handler Html getAdminNewFunctionaryInviteR, postAdminNewFunctionaryInviteR :: Handler Html
getAdminNewLecturerInviteR = postAdminNewLecturerInviteR getAdminNewFunctionaryInviteR = postAdminNewFunctionaryInviteR
postAdminNewLecturerInviteR = do postAdminNewFunctionaryInviteR = do
uid <- requireAuthId uid <- requireAuthId
userSchools <- runDB . E.select . E.from $ \userAdmin -> do userSchools <- runDB . E.select . E.from $ \userAdmin -> do
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val uid
return $ userAdmin E.^. UserAdminSchool E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
return $ userAdmin E.^. UserFunctionSchool
((invitesResult, invitesWgt), invitesEncoding) <- runFormPost . renderWForm FormStandard $ do ((invitesResult, invitesWgt), invitesEncoding) <- runFormPost . renderWForm FormStandard $ do
school <- wreq (schoolFieldFor $ map E.unValue userSchools) (fslI MsgLecturerInviteSchool) Nothing now <- liftIO getCurrentTime
users <- wreq (multiUserField False Nothing) (fslI MsgLecturerInviteField & setTooltip MsgMultiEmailFieldTip) Nothing let
return $ (,) <$> school <*> users localNow = utcToLocalTime now
beginToday = case localTimeToUTC (LocalTime (localDay localNow) midnight) of
LTUUnique utc' _ -> utc'
_other -> UTCTime (utctDay now) 0
defDeadline = beginToday{ utctDay = 14 `addDays` utctDay beginToday }
formResultModal invitesResult UsersR $ \(schoolId, users) -> do function <- wreq (selectField optionsFinite) (fslI MsgFunctionaryInviteFunction) Nothing
school <- wreq (schoolFieldFor $ map E.unValue userSchools) (fslI MsgFunctionaryInviteSchool) Nothing
deadline <- wreq utcTimeField (fslI MsgExamRegistrationInviteDeadline) (Just defDeadline)
users <- wreq (multiUserField False Nothing) (fslI MsgFunctionaryInviteField & setTooltip MsgMultiEmailFieldTip) Nothing
return $ (,,,) <$> function <*> school <*> deadline <*> users
formResultModal invitesResult UsersR $ \(function, schoolId, deadline, users) -> do
let (emails, uids) = partitionEithers $ Set.toList users let (emails, uids) = partitionEithers $ Set.toList users
lift . runDBJobs $ do lift . runDBJobs $ do
forM_ uids $ \lecId -> forM_ uids $ \lecId ->
void . insertUnique $ UserLecturer lecId schoolId void . insertUnique $ UserFunction lecId schoolId function
sinkInvitationsF lecturerInvitationConfig [ (mail, schoolId, (InvDBDataUserLecturer, InvTokenDataUserLecturer $ unSchoolKey schoolId)) | mail <- emails ] sinkInvitationsF functionInvitationConfig [ (mail, schoolId, (InvDBDataUserFunction deadline, InvTokenDataUserFunction (unSchoolKey schoolId) function)) | mail <- emails ]
unless (null emails) $ unless (null emails) $
tell . pure <=< messageI Success . MsgLecturersInvited $ length emails tell . pure <=< messageI Success . MsgFunctionariesInvited $ length emails
unless (null uids) $ unless (null uids) $
tell . pure <=< messageI Success . MsgLecturersAdded $ length uids tell . pure <=< messageI Success . MsgFunctionariesAdded $ length uids
siteLayoutMsg MsgLecturerInviteHeading $ do siteLayoutMsg MsgFunctionaryInviteHeading $ do
setTitleI MsgLecturerInviteHeading setTitleI MsgFunctionaryInviteHeading
wrapForm invitesWgt def wrapForm invitesWgt def
{ formEncoding = invitesEncoding { formEncoding = invitesEncoding
, formAction = Just $ SomeRoute AdminNewLecturerInviteR , formAction = Just $ SomeRoute AdminNewFunctionaryInviteR
} }
getAdminLecturerInviteR, postAdminLecturerInviteR :: Handler Html getAdminFunctionaryInviteR, postAdminFunctionaryInviteR :: Handler Html
getAdminLecturerInviteR = postAdminLecturerInviteR getAdminFunctionaryInviteR = postAdminFunctionaryInviteR
postAdminLecturerInviteR = invitationR lecturerInvitationConfig postAdminFunctionaryInviteR = invitationR functionInvitationConfig

51
src/Handler/Utils.hs
View File

@ -4,8 +4,6 @@ module Handler.Utils
import Import import Import
import Utils.Lens
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding as T
import Data.Map ((!)) import Data.Map ((!))
@ -15,10 +13,6 @@ import Data.CaseInsensitive (original)
-- import qualified Data.CaseInsensitive as CI -- import qualified Data.CaseInsensitive as CI
import qualified Data.Conduit.List as Conduit import qualified Data.Conduit.List as Conduit
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (qRunIO)
-- import Language.Haskell.TH.Datatype
import Text.Hamlet (shamletFile) import Text.Hamlet (shamletFile)
import Handler.Utils.DateTime as Handler.Utils import Handler.Utils.DateTime as Handler.Utils
@ -32,12 +26,9 @@ import Handler.Utils.Rating as Handler.Utils hiding (extractRatings)
import Handler.Utils.Sheet as Handler.Utils import Handler.Utils.Sheet as Handler.Utils
import Handler.Utils.Mail as Handler.Utils import Handler.Utils.Mail as Handler.Utils
import Handler.Utils.ContentDisposition as Handler.Utils import Handler.Utils.ContentDisposition as Handler.Utils
import Handler.Utils.I18n as Handler.Utils
import System.Directory (listDirectory) import System.FilePath.Posix (takeFileName)
import System.FilePath.Posix (takeBaseName, takeFileName)
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
import Control.Monad.Logger import Control.Monad.Logger
@ -218,36 +209,6 @@ warnTermDays tid timeNames = do
forM_ outoflecture $ warnI MsgDayIsOutOfLecture forM_ outoflecture $ warnI MsgDayIsOutOfLecture
forM_ outoftermdays $ warnI MsgDayIsOutOfTerm forM_ outoftermdays $ warnI MsgDayIsOutOfTerm
-- | Add language dependent template files
--
-- For large files which are translated as a whole.
--
-- Argument musst be a directory under @/templates@,
-- which contains a file for each language,
-- eg. @imprint@ for choosing between
-- @/templates/imprint/de.hamlet@, @/templates/imprint/de-at.hamlet@,
-- and @/templates/imprint/en.hamlet@
--
-- Dependency detection cannot work properly (no `addDependentFile`-equivalent
-- for directories)
-- @$ stack clean@ is required so new translations show up
i18nWidgetFile :: FilePath -> Q Exp
i18nWidgetFile basename = do
-- Construct list of available translations (@de@, @en@, ...) at compile time
let i18nDirectory = "templates" </> "i18n" </> basename
availableFiles <- qRunIO $ listDirectory i18nDirectory
let availableTranslations = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . List.nub $ pack . takeBaseName <$> availableFiles
availableTranslations' <- maybe (fail $ "‘" <> i18nDirectory <> "’ is empty") return $ NonEmpty.nonEmpty availableTranslations
-- 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 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)|]
-- | return a value only if the current user ist authorized for a given route -- | return a value only if the current user ist authorized for a given route
guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadLogger h guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadLogger h
@ -264,3 +225,11 @@ runAppLoggingT app@(appLogger -> (_, loggerTVar)) = flip runLoggingT logFunc
f <- messageLoggerSource app <$> readTVarIO loggerTVar f <- messageLoggerSource app <$> readTVarIO loggerTVar
f loc src lvl str f loc src lvl str
studyFeaturesWidget :: StudyFeaturesId -> Widget
studyFeaturesWidget featId = do
(StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField)
[whamlet|
$newline never
_{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester}
|]

1
src/Handler/Utils/Communication.hs
View File

@ -9,7 +9,6 @@ module Handler.Utils.Communication
import Import import Import
import Handler.Utils import Handler.Utils
import Utils.Lens
import Jobs.Queue import Jobs.Queue
import Control.Monad.Trans.Reader (mapReaderT) import Control.Monad.Trans.Reader (mapReaderT)

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

@ -5,8 +5,6 @@ module Handler.Utils.ContentDisposition
import Import import Import
import Utils.Lens
-- | Check whether the user's preference for files is inline-viewing or downloading -- | Check whether the user's preference for files is inline-viewing or downloading
downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
downloadFiles = do downloadFiles = do

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

@ -16,8 +16,6 @@ module Handler.Utils.DateTime
import Import import Import
import Utils.Lens
import Data.Time.Zones import Data.Time.Zones
import qualified Data.Time.Zones as TZ import qualified Data.Time.Zones as TZ

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

@ -17,8 +17,6 @@ module Handler.Utils.Delete
import Import import Import
import Handler.Utils.Form import Handler.Utils.Form
import Utils.Lens
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Set as Set import qualified Data.Set as Set

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

@ -12,8 +12,6 @@ import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.Internal.Sql as E import qualified Database.Esqueleto.Internal.Sql as E
import Database.Esqueleto.Utils.TH import Database.Esqueleto.Utils.TH
import Utils.Lens
import qualified Data.Conduit.List as C import qualified Data.Conduit.List as C
import qualified Data.Map as Map import qualified Data.Map as Map

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

@ -40,13 +40,9 @@ import Control.Monad.Error.Class (MonadError(..))
import Data.Either (partitionEithers) import Data.Either (partitionEithers)
import Utils.Lens
import Data.Aeson (eitherDecodeStrict') import Data.Aeson (eitherDecodeStrict')
import Data.Aeson.Text (encodeToLazyText) import Data.Aeson.Text (encodeToLazyText)
import Data.Proxy
import qualified Text.Email.Validate as Email import qualified Text.Email.Validate as Email
import Yesod.Core.Types (FileInfo(..)) import Yesod.Core.Types (FileInfo(..))
@ -852,7 +848,7 @@ localTimeField = Field
where where
fieldTimeFormat :: String fieldTimeFormat :: String
--fieldTimeFormat = "%e.%m.%y %k:%M" --fieldTimeFormat = "%e.%m.%y %k:%M"
fieldTimeFormat = "%Y-%m-%dT%H:%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
readTime :: Text -> Either UniWorXMessage LocalTime readTime :: Text -> Either UniWorXMessage LocalTime

19
src/Handler/Utils/Form/MassInput.hs
View File

@ -7,7 +7,7 @@ module Handler.Utils.Form.MassInput
, massInput , massInput
, module Handler.Utils.Form.MassInput.Liveliness , module Handler.Utils.Form.MassInput.Liveliness
, massInputA, massInputW , massInputA, massInputW
, massInputList , massInputList, massInputListA
, massInputAccum, massInputAccumA, massInputAccumW , massInputAccum, massInputAccumA, massInputAccumW
, massInputAccumEdit, massInputAccumEditA, massInputAccumEditW , massInputAccumEdit, massInputAccumEditA, massInputAccumEditW
, ListLength(..), ListPosition(..), miDeleteList , ListLength(..), ListPosition(..), miDeleteList
@ -17,7 +17,6 @@ module Handler.Utils.Form.MassInput
import Import import Import
import Utils.Form import Utils.Form
import Utils.Lens
import Handler.Utils.Form.MassInput.Liveliness import Handler.Utils.Form.MassInput.Liveliness
import Handler.Utils.Form.MassInput.TH import Handler.Utils.Form.MassInput.TH
@ -487,6 +486,22 @@ massInputList field fieldSettings miButtonAction miIdent miSettings miRequired m
miRequired miRequired
(Map.fromList . zip [0..] . map ((), ) <$> miPrevResult) (Map.fromList . zip [0..] . map ((), ) <$> miPrevResult)
massInputListA :: forall handler cellResult ident.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, MonadLogger handler
, PathPiece ident
)
=> Field handler cellResult
-> (ListPosition -> FieldSettings UniWorX)
-> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
-> ident
-> FieldSettings UniWorX
-> Bool
-> Maybe [cellResult]
-> AForm handler [cellResult]
massInputListA field fieldSettings miButtonAction miIdent miSettings miRequired miPrevResult = formToAForm . fmap (over _2 pure) $ massInputList field fieldSettings miButtonAction miIdent miSettings miRequired miPrevResult mempty
-- | Wrapper around `massInput` for the common case, that we just want a list of data with no option to modify it except deletion and addition -- | Wrapper around `massInput` for the common case, that we just want a list of data with no option to modify it except deletion and addition
massInputAccum :: forall handler cellData ident. massInputAccum :: forall handler cellData ident.
( MonadHandler handler, HandlerSite handler ~ UniWorX ( MonadHandler handler, HandlerSite handler ~ UniWorX

2
src/Handler/Utils/Form/Occurrences.hs
View File

@ -10,8 +10,6 @@ import qualified Data.Set as Set
import Data.Map ((!)) import Data.Map ((!))
import qualified Data.Map as Map import qualified Data.Map as Map
import Utils.Lens
data OccurrenceScheduleKind = ScheduleKindWeekly data OccurrenceScheduleKind = ScheduleKindWeekly
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)

43
src/Handler/Utils/I18n.hs Normal file
View File

@ -0,0 +1,43 @@
module Handler.Utils.I18n
where
import Import
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (qRunIO)
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
import System.Directory (listDirectory)
import System.FilePath.Posix (takeBaseName)
-- | Add language dependent template files
--
-- For large files which are translated as a whole.
--
-- Argument musst be a directory under @/templates@,
-- which contains a file for each language,
-- eg. @imprint@ for choosing between
-- @/templates/imprint/de.hamlet@, @/templates/imprint/de-at.hamlet@,
-- and @/templates/imprint/en.hamlet@
--
-- Dependency detection cannot work properly (no `addDependentFile`-equivalent
-- for directories)
-- @$ stack clean@ is required so new translations show up
i18nWidgetFile :: FilePath -> Q Exp
i18nWidgetFile basename = do
-- Construct list of available translations (@de@, @en@, ...) at compile time
let i18nDirectory = "templates" </> "i18n" </> basename
availableFiles <- qRunIO $ listDirectory i18nDirectory
let availableTranslations = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . List.nub $ pack . takeBaseName <$> availableFiles
availableTranslations' <- maybe (fail $ "‘" <> i18nDirectory <> "’ is empty") return $ NonEmpty.nonEmpty availableTranslations
-- 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 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)|]

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

@ -16,7 +16,6 @@ module Handler.Utils.Invitations
) where ) where
import Import import Import
import Utils.Lens
import Utils.Form import Utils.Form
import Jobs.Queue import Jobs.Queue
@ -123,7 +122,7 @@ data InvitationConfig junction = forall formCtx. InvitationConfig
-- ^ Subject of the e-mail which sends the token to the user -- ^ Subject of the e-mail which sends the token to the user
, invitationHeading :: Entity (InvitationFor junction) -> InvitationData junction -> DB (SomeMessage UniWorX) , invitationHeading :: Entity (InvitationFor junction) -> InvitationData junction -> DB (SomeMessage UniWorX)
-- ^ Heading of the page which allows the invitee to accept/decline the invitation (`invitationR` -- ^ Heading of the page which allows the invitee to accept/decline the invitation (`invitationR`
, invitationExplanation :: Entity (InvitationFor junction) -> InvitationData junction -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) , invitationExplanation :: Entity (InvitationFor junction) -> InvitationData junction -> DB (HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX))
-- ^ Explanation of what kind of invitation this is (used both in the e-mail and in `invitationR`) -- ^ Explanation of what kind of invitation this is (used both in the e-mail and in `invitationR`)
, invitationTokenConfig :: Entity (InvitationFor junction) -> InvitationData junction -> DB InvitationTokenConfig , invitationTokenConfig :: Entity (InvitationFor junction) -> InvitationData junction -> DB InvitationTokenConfig
-- ^ Parameters for creating the invitation token (`InvitationTokenData` is handled transparently) -- ^ Parameters for creating the invitation token (`InvitationTokenData` is handled transparently)
@ -176,7 +175,7 @@ sinkInvitations :: forall junction.
-- updated, instead. -- updated, instead.
-- --
-- For new junctions an invitation is sent by e-mail. -- For new junctions an invitation is sent by e-mail.
sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lift . sinkInvitations' sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations'
where where
determineExists :: Conduit (Invitation' junction) determineExists :: Conduit (Invitation' junction)
(YesodJobDB UniWorX) (YesodJobDB UniWorX)
@ -202,13 +201,9 @@ sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lif
JSON.Success dbData -> return dbData JSON.Success dbData -> return dbData
JSON.Error str -> fail $ "Could not decode invitationData: " <> str JSON.Error str -> fail $ "Could not decode invitationData: " <> str
sinkInvitations' :: [Invitation' junction] sinkInvitations' :: Sink (Invitation' junction) (YesodJobDB UniWorX) ()
-> YesodJobDB UniWorX () sinkInvitations' = do
sinkInvitations' new = do C.mapM_ $ \(jInvitee, fid, dat) -> do
when (is _Nothing (ephemeralInvitation @junction)) $ do
insertMany_ $ map (\(email, fid, dat) -> Invitation email (invRef @junction fid) (toJSON $ dat ^. _invitationDBData)) new
-- forM_ existing $ \(iid, oldDat) -> update iid [ InvitationData =. toJSON (dat ^. _invitationDBData) ]
forM_ new $ \(jInvitee, fid, dat) -> do
app <- getYesod app <- getYesod
let mr = renderMessage app $ NonEmpty.toList appLanguages let mr = renderMessage app $ NonEmpty.toList appLanguages
ur <- getUrlRenderParams ur <- getUrlRenderParams
@ -223,7 +218,14 @@ sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lif
jwt <- encodeToken token jwt <- encodeToken token
jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece jwt)]) jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece jwt)])
jInvitationSubject <- fmap mr . mapReaderT liftHandlerT $ invitationSubject fEnt dat jInvitationSubject <- fmap mr . mapReaderT liftHandlerT $ invitationSubject fEnt dat
let jInvitationExplanation = invitationExplanation fEnt dat (toHtml . mr) ur jInvitationExplanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> mapReaderT liftHandlerT (invitationExplanation fEnt dat)
when (is _Nothing (ephemeralInvitation @junction)) $ insert_ $ Invitation
{ invitationEmail = jInvitee
, invitationFor = invRef @junction fid
, invitationData = toJSON $ dat ^. _invitationDBData
, invitationExpiresAt = tokenExpiresAt token
}
queueDBJob JobInvitation{..} queueDBJob JobInvitation{..}
@ -246,9 +248,9 @@ sourceInvitations :: forall junction.
-> Source (YesodDB UniWorX) (UserEmail, InvitationDBData junction) -> Source (YesodDB UniWorX) (UserEmail, InvitationDBData junction)
sourceInvitations forKey = selectSource [InvitationFor ==. invRef @junction forKey] [] .| C.mapM decode sourceInvitations forKey = selectSource [InvitationFor ==. invRef @junction forKey] [] .| C.mapM decode
where where
decode (Entity _ (Invitation email _ invitationData)) decode (Entity _ (Invitation{invitationEmail, invitationData}))
= case fromJSON invitationData of = case fromJSON invitationData of
JSON.Success dbData -> return (email, dbData) JSON.Success dbData -> return (invitationEmail, dbData)
JSON.Error str -> fail $ "Could not decode invitationData: " <> str JSON.Error str -> fail $ "Could not decode invitationData: " <> str
sourceInvitationsList :: forall junction. sourceInvitationsList :: forall junction.
@ -309,7 +311,7 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do
MsgRenderer mr <- getMsgRenderer MsgRenderer mr <- getMsgRenderer
ur <- getUrlRenderParams ur <- getUrlRenderParams
heading <- invitationHeading fEnt iData heading <- invitationHeading fEnt iData
let explanation = invitationExplanation fEnt iData (toHtml . mr) ur explanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> invitationExplanation fEnt iData
fmap (, (dataWidget, dataEnctype), heading, explanation) . formResultMaybe dataRes $ \case fmap (, (dataWidget, dataEnctype), heading, explanation) . formResultMaybe dataRes $ \case
Nothing -> do Nothing -> do

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

@ -7,8 +7,6 @@ module Handler.Utils.Mail
import Import import Import
import Utils.Lens
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy as LBS

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

@ -39,8 +39,6 @@ import qualified Database.Esqueleto as E
import qualified Data.Conduit.List as Conduit import qualified Data.Conduit.List as Conduit
import Utils.Lens
instance HasResolution prec => Pretty (Fixed prec) where instance HasResolution prec => Pretty (Fixed prec) where
pretty = pretty . show pretty = pretty . show
@ -159,7 +157,7 @@ parseRating File{ fileContent = Just input, .. } = do
ratingStr = Text.unpack $ Text.strip ratingLine ratingStr = Text.unpack $ Text.strip ratingLine
ratingPoints <- case () of ratingPoints <- case () of
_ | null ratingStr -> return Nothing _ | null ratingStr -> return Nothing
| otherwise -> either (throw . RatingInvalid) return $ Just <$> readEither ratingStr | otherwise -> either (throw . RatingInvalid . pack) return $ Just <$> readEither ratingStr
return Rating'{ ratingTime = Just fileModified, .. } return Rating'{ ratingTime = Just fileModified, .. }
parseRating _ = throwM RatingFileIsDirectory parseRating _ = throwM RatingFileIsDirectory

32
src/Handler/Utils/SchoolLdap.hs Normal file
View File

@ -0,0 +1,32 @@
module Handler.Utils.SchoolLdap
( parseLdapSchools
) where
import Import.NoFoundation hiding (try, (<|>), choice)
import Text.Parsec
import Text.Parsec.Text
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import qualified Data.Set as Set
parseLdapSchools :: Text -> Either ParseError (Set (CI Text))
parseLdapSchools = parse pLdapSchools ""
pLdapSchools :: Parser (Set (CI Text))
pLdapSchools = Set.fromList . map CI.mk <$> pSegment `sepBy` char ','
pSegment :: Parser Text
pSegment = do
let
fragStart = flip label "fragment start" $ do
void . choice . map (try . string) $ sortOn Down
[ "l", "st", "o", "ou", "c", "street", "dc" ]
void $ char '='
fragStart
pack <$> manyTill anyChar (try (lookAhead $ char ',' >> fragStart) <|> eof)

1
src/Handler/Utils/SheetType.hs
View File

@ -5,7 +5,6 @@ module Handler.Utils.SheetType
import Import import Import
import Data.Monoid (Sum(..)) import Data.Monoid (Sum(..))
import Utils.Lens
addBonusToPoints :: SheetTypeSummary -> SheetTypeSummary addBonusToPoints :: SheetTypeSummary -> SheetTypeSummary
addBonusToPoints sts = addBonusToPoints sts =

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